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