aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/symbol.cc
diff options
context:
space:
mode:
authorMartin Liska <mliska@suse.cz>2022-01-14 16:56:44 +0100
committerMartin Liska <mliska@suse.cz>2022-01-17 22:12:04 +0100
commit5c69acb32329d49e58c26fa41ae74229a52b9106 (patch)
treeddb05f9d73afb6f998457d2ac4b720e3b3b60483 /gcc/fortran/symbol.cc
parent490e23032baaece71f2ec09fa1805064b150fbc2 (diff)
downloadgcc-5c69acb32329d49e58c26fa41ae74229a52b9106.zip
gcc-5c69acb32329d49e58c26fa41ae74229a52b9106.tar.gz
gcc-5c69acb32329d49e58c26fa41ae74229a52b9106.tar.bz2
Rename .c files to .cc files.
gcc/ada/ChangeLog: * adadecode.c: Moved to... * adadecode.cc: ...here. * affinity.c: Moved to... * affinity.cc: ...here. * argv-lynxos178-raven-cert.c: Moved to... * argv-lynxos178-raven-cert.cc: ...here. * argv.c: Moved to... * argv.cc: ...here. * aux-io.c: Moved to... * aux-io.cc: ...here. * cio.c: Moved to... * cio.cc: ...here. * cstreams.c: Moved to... * cstreams.cc: ...here. * env.c: Moved to... * env.cc: ...here. * exit.c: Moved to... * exit.cc: ...here. * expect.c: Moved to... * expect.cc: ...here. * final.c: Moved to... * final.cc: ...here. * gcc-interface/cuintp.c: Moved to... * gcc-interface/cuintp.cc: ...here. * gcc-interface/decl.c: Moved to... * gcc-interface/decl.cc: ...here. * gcc-interface/misc.c: Moved to... * gcc-interface/misc.cc: ...here. * gcc-interface/targtyps.c: Moved to... * gcc-interface/targtyps.cc: ...here. * gcc-interface/trans.c: Moved to... * gcc-interface/trans.cc: ...here. * gcc-interface/utils.c: Moved to... * gcc-interface/utils.cc: ...here. * gcc-interface/utils2.c: Moved to... * gcc-interface/utils2.cc: ...here. * init.c: Moved to... * init.cc: ...here. * initialize.c: Moved to... * initialize.cc: ...here. * libgnarl/thread.c: Moved to... * libgnarl/thread.cc: ...here. * link.c: Moved to... * link.cc: ...here. * locales.c: Moved to... * locales.cc: ...here. * mkdir.c: Moved to... * mkdir.cc: ...here. * raise.c: Moved to... * raise.cc: ...here. * rtfinal.c: Moved to... * rtfinal.cc: ...here. * rtinit.c: Moved to... * rtinit.cc: ...here. * seh_init.c: Moved to... * seh_init.cc: ...here. * sigtramp-armdroid.c: Moved to... * sigtramp-armdroid.cc: ...here. * sigtramp-ios.c: Moved to... * sigtramp-ios.cc: ...here. * sigtramp-qnx.c: Moved to... * sigtramp-qnx.cc: ...here. * sigtramp-vxworks.c: Moved to... * sigtramp-vxworks.cc: ...here. * socket.c: Moved to... * socket.cc: ...here. * tracebak.c: Moved to... * tracebak.cc: ...here. * version.c: Moved to... * version.cc: ...here. * vx_stack_info.c: Moved to... * vx_stack_info.cc: ...here. gcc/ChangeLog: * adjust-alignment.c: Moved to... * adjust-alignment.cc: ...here. * alias.c: Moved to... * alias.cc: ...here. * alloc-pool.c: Moved to... * alloc-pool.cc: ...here. * asan.c: Moved to... * asan.cc: ...here. * attribs.c: Moved to... * attribs.cc: ...here. * auto-inc-dec.c: Moved to... * auto-inc-dec.cc: ...here. * auto-profile.c: Moved to... * auto-profile.cc: ...here. * bb-reorder.c: Moved to... * bb-reorder.cc: ...here. * bitmap.c: Moved to... * bitmap.cc: ...here. * btfout.c: Moved to... * btfout.cc: ...here. * builtins.c: Moved to... * builtins.cc: ...here. * caller-save.c: Moved to... * caller-save.cc: ...here. * calls.c: Moved to... * calls.cc: ...here. * ccmp.c: Moved to... * ccmp.cc: ...here. * cfg.c: Moved to... * cfg.cc: ...here. * cfganal.c: Moved to... * cfganal.cc: ...here. * cfgbuild.c: Moved to... * cfgbuild.cc: ...here. * cfgcleanup.c: Moved to... * cfgcleanup.cc: ...here. * cfgexpand.c: Moved to... * cfgexpand.cc: ...here. * cfghooks.c: Moved to... * cfghooks.cc: ...here. * cfgloop.c: Moved to... * cfgloop.cc: ...here. * cfgloopanal.c: Moved to... * cfgloopanal.cc: ...here. * cfgloopmanip.c: Moved to... * cfgloopmanip.cc: ...here. * cfgrtl.c: Moved to... * cfgrtl.cc: ...here. * cgraph.c: Moved to... * cgraph.cc: ...here. * cgraphbuild.c: Moved to... * cgraphbuild.cc: ...here. * cgraphclones.c: Moved to... * cgraphclones.cc: ...here. * cgraphunit.c: Moved to... * cgraphunit.cc: ...here. * collect-utils.c: Moved to... * collect-utils.cc: ...here. * collect2-aix.c: Moved to... * collect2-aix.cc: ...here. * collect2.c: Moved to... * collect2.cc: ...here. * combine-stack-adj.c: Moved to... * combine-stack-adj.cc: ...here. * combine.c: Moved to... * combine.cc: ...here. * common/common-targhooks.c: Moved to... * common/common-targhooks.cc: ...here. * common/config/aarch64/aarch64-common.c: Moved to... * common/config/aarch64/aarch64-common.cc: ...here. * common/config/alpha/alpha-common.c: Moved to... * common/config/alpha/alpha-common.cc: ...here. * common/config/arc/arc-common.c: Moved to... * common/config/arc/arc-common.cc: ...here. * common/config/arm/arm-common.c: Moved to... * common/config/arm/arm-common.cc: ...here. * common/config/avr/avr-common.c: Moved to... * common/config/avr/avr-common.cc: ...here. * common/config/bfin/bfin-common.c: Moved to... * common/config/bfin/bfin-common.cc: ...here. * common/config/bpf/bpf-common.c: Moved to... * common/config/bpf/bpf-common.cc: ...here. * common/config/c6x/c6x-common.c: Moved to... * common/config/c6x/c6x-common.cc: ...here. * common/config/cr16/cr16-common.c: Moved to... * common/config/cr16/cr16-common.cc: ...here. * common/config/cris/cris-common.c: Moved to... * common/config/cris/cris-common.cc: ...here. * common/config/csky/csky-common.c: Moved to... * common/config/csky/csky-common.cc: ...here. * common/config/default-common.c: Moved to... * common/config/default-common.cc: ...here. * common/config/epiphany/epiphany-common.c: Moved to... * common/config/epiphany/epiphany-common.cc: ...here. * common/config/fr30/fr30-common.c: Moved to... * common/config/fr30/fr30-common.cc: ...here. * common/config/frv/frv-common.c: Moved to... * common/config/frv/frv-common.cc: ...here. * common/config/gcn/gcn-common.c: Moved to... * common/config/gcn/gcn-common.cc: ...here. * common/config/h8300/h8300-common.c: Moved to... * common/config/h8300/h8300-common.cc: ...here. * common/config/i386/i386-common.c: Moved to... * common/config/i386/i386-common.cc: ...here. * common/config/ia64/ia64-common.c: Moved to... * common/config/ia64/ia64-common.cc: ...here. * common/config/iq2000/iq2000-common.c: Moved to... * common/config/iq2000/iq2000-common.cc: ...here. * common/config/lm32/lm32-common.c: Moved to... * common/config/lm32/lm32-common.cc: ...here. * common/config/m32r/m32r-common.c: Moved to... * common/config/m32r/m32r-common.cc: ...here. * common/config/m68k/m68k-common.c: Moved to... * common/config/m68k/m68k-common.cc: ...here. * common/config/mcore/mcore-common.c: Moved to... * common/config/mcore/mcore-common.cc: ...here. * common/config/microblaze/microblaze-common.c: Moved to... * common/config/microblaze/microblaze-common.cc: ...here. * common/config/mips/mips-common.c: Moved to... * common/config/mips/mips-common.cc: ...here. * common/config/mmix/mmix-common.c: Moved to... * common/config/mmix/mmix-common.cc: ...here. * common/config/mn10300/mn10300-common.c: Moved to... * common/config/mn10300/mn10300-common.cc: ...here. * common/config/msp430/msp430-common.c: Moved to... * common/config/msp430/msp430-common.cc: ...here. * common/config/nds32/nds32-common.c: Moved to... * common/config/nds32/nds32-common.cc: ...here. * common/config/nios2/nios2-common.c: Moved to... * common/config/nios2/nios2-common.cc: ...here. * common/config/nvptx/nvptx-common.c: Moved to... * common/config/nvptx/nvptx-common.cc: ...here. * common/config/or1k/or1k-common.c: Moved to... * common/config/or1k/or1k-common.cc: ...here. * common/config/pa/pa-common.c: Moved to... * common/config/pa/pa-common.cc: ...here. * common/config/pdp11/pdp11-common.c: Moved to... * common/config/pdp11/pdp11-common.cc: ...here. * common/config/pru/pru-common.c: Moved to... * common/config/pru/pru-common.cc: ...here. * common/config/riscv/riscv-common.c: Moved to... * common/config/riscv/riscv-common.cc: ...here. * common/config/rs6000/rs6000-common.c: Moved to... * common/config/rs6000/rs6000-common.cc: ...here. * common/config/rx/rx-common.c: Moved to... * common/config/rx/rx-common.cc: ...here. * common/config/s390/s390-common.c: Moved to... * common/config/s390/s390-common.cc: ...here. * common/config/sh/sh-common.c: Moved to... * common/config/sh/sh-common.cc: ...here. * common/config/sparc/sparc-common.c: Moved to... * common/config/sparc/sparc-common.cc: ...here. * common/config/tilegx/tilegx-common.c: Moved to... * common/config/tilegx/tilegx-common.cc: ...here. * common/config/tilepro/tilepro-common.c: Moved to... * common/config/tilepro/tilepro-common.cc: ...here. * common/config/v850/v850-common.c: Moved to... * common/config/v850/v850-common.cc: ...here. * common/config/vax/vax-common.c: Moved to... * common/config/vax/vax-common.cc: ...here. * common/config/visium/visium-common.c: Moved to... * common/config/visium/visium-common.cc: ...here. * common/config/xstormy16/xstormy16-common.c: Moved to... * common/config/xstormy16/xstormy16-common.cc: ...here. * common/config/xtensa/xtensa-common.c: Moved to... * common/config/xtensa/xtensa-common.cc: ...here. * compare-elim.c: Moved to... * compare-elim.cc: ...here. * config/aarch64/aarch64-bti-insert.c: Moved to... * config/aarch64/aarch64-bti-insert.cc: ...here. * config/aarch64/aarch64-builtins.c: Moved to... * config/aarch64/aarch64-builtins.cc: ...here. * config/aarch64/aarch64-c.c: Moved to... * config/aarch64/aarch64-c.cc: ...here. * config/aarch64/aarch64-d.c: Moved to... * config/aarch64/aarch64-d.cc: ...here. * config/aarch64/aarch64.c: Moved to... * config/aarch64/aarch64.cc: ...here. * config/aarch64/cortex-a57-fma-steering.c: Moved to... * config/aarch64/cortex-a57-fma-steering.cc: ...here. * config/aarch64/driver-aarch64.c: Moved to... * config/aarch64/driver-aarch64.cc: ...here. * config/aarch64/falkor-tag-collision-avoidance.c: Moved to... * config/aarch64/falkor-tag-collision-avoidance.cc: ...here. * config/aarch64/host-aarch64-darwin.c: Moved to... * config/aarch64/host-aarch64-darwin.cc: ...here. * config/alpha/alpha.c: Moved to... * config/alpha/alpha.cc: ...here. * config/alpha/driver-alpha.c: Moved to... * config/alpha/driver-alpha.cc: ...here. * config/arc/arc-c.c: Moved to... * config/arc/arc-c.cc: ...here. * config/arc/arc.c: Moved to... * config/arc/arc.cc: ...here. * config/arc/driver-arc.c: Moved to... * config/arc/driver-arc.cc: ...here. * config/arm/aarch-common.c: Moved to... * config/arm/aarch-common.cc: ...here. * config/arm/arm-builtins.c: Moved to... * config/arm/arm-builtins.cc: ...here. * config/arm/arm-c.c: Moved to... * config/arm/arm-c.cc: ...here. * config/arm/arm-d.c: Moved to... * config/arm/arm-d.cc: ...here. * config/arm/arm.c: Moved to... * config/arm/arm.cc: ...here. * config/arm/driver-arm.c: Moved to... * config/arm/driver-arm.cc: ...here. * config/avr/avr-c.c: Moved to... * config/avr/avr-c.cc: ...here. * config/avr/avr-devices.c: Moved to... * config/avr/avr-devices.cc: ...here. * config/avr/avr-log.c: Moved to... * config/avr/avr-log.cc: ...here. * config/avr/avr.c: Moved to... * config/avr/avr.cc: ...here. * config/avr/driver-avr.c: Moved to... * config/avr/driver-avr.cc: ...here. * config/avr/gen-avr-mmcu-specs.c: Moved to... * config/avr/gen-avr-mmcu-specs.cc: ...here. * config/avr/gen-avr-mmcu-texi.c: Moved to... * config/avr/gen-avr-mmcu-texi.cc: ...here. * config/bfin/bfin.c: Moved to... * config/bfin/bfin.cc: ...here. * config/bpf/bpf.c: Moved to... * config/bpf/bpf.cc: ...here. * config/bpf/coreout.c: Moved to... * config/bpf/coreout.cc: ...here. * config/c6x/c6x.c: Moved to... * config/c6x/c6x.cc: ...here. * config/cr16/cr16.c: Moved to... * config/cr16/cr16.cc: ...here. * config/cris/cris.c: Moved to... * config/cris/cris.cc: ...here. * config/csky/csky.c: Moved to... * config/csky/csky.cc: ...here. * config/darwin-c.c: Moved to... * config/darwin-c.cc: ...here. * config/darwin-d.c: Moved to... * config/darwin-d.cc: ...here. * config/darwin-driver.c: Moved to... * config/darwin-driver.cc: ...here. * config/darwin-f.c: Moved to... * config/darwin-f.cc: ...here. * config/darwin.c: Moved to... * config/darwin.cc: ...here. * config/default-c.c: Moved to... * config/default-c.cc: ...here. * config/default-d.c: Moved to... * config/default-d.cc: ...here. * config/dragonfly-d.c: Moved to... * config/dragonfly-d.cc: ...here. * config/epiphany/epiphany.c: Moved to... * config/epiphany/epiphany.cc: ...here. * config/epiphany/mode-switch-use.c: Moved to... * config/epiphany/mode-switch-use.cc: ...here. * config/epiphany/resolve-sw-modes.c: Moved to... * config/epiphany/resolve-sw-modes.cc: ...here. * config/fr30/fr30.c: Moved to... * config/fr30/fr30.cc: ...here. * config/freebsd-d.c: Moved to... * config/freebsd-d.cc: ...here. * config/frv/frv.c: Moved to... * config/frv/frv.cc: ...here. * config/ft32/ft32.c: Moved to... * config/ft32/ft32.cc: ...here. * config/gcn/driver-gcn.c: Moved to... * config/gcn/driver-gcn.cc: ...here. * config/gcn/gcn-run.c: Moved to... * config/gcn/gcn-run.cc: ...here. * config/gcn/gcn-tree.c: Moved to... * config/gcn/gcn-tree.cc: ...here. * config/gcn/gcn.c: Moved to... * config/gcn/gcn.cc: ...here. * config/gcn/mkoffload.c: Moved to... * config/gcn/mkoffload.cc: ...here. * config/glibc-c.c: Moved to... * config/glibc-c.cc: ...here. * config/glibc-d.c: Moved to... * config/glibc-d.cc: ...here. * config/h8300/h8300.c: Moved to... * config/h8300/h8300.cc: ...here. * config/host-darwin.c: Moved to... * config/host-darwin.cc: ...here. * config/host-hpux.c: Moved to... * config/host-hpux.cc: ...here. * config/host-linux.c: Moved to... * config/host-linux.cc: ...here. * config/host-netbsd.c: Moved to... * config/host-netbsd.cc: ...here. * config/host-openbsd.c: Moved to... * config/host-openbsd.cc: ...here. * config/host-solaris.c: Moved to... * config/host-solaris.cc: ...here. * config/i386/djgpp.c: Moved to... * config/i386/djgpp.cc: ...here. * config/i386/driver-i386.c: Moved to... * config/i386/driver-i386.cc: ...here. * config/i386/driver-mingw32.c: Moved to... * config/i386/driver-mingw32.cc: ...here. * config/i386/gnu-property.c: Moved to... * config/i386/gnu-property.cc: ...here. * config/i386/host-cygwin.c: Moved to... * config/i386/host-cygwin.cc: ...here. * config/i386/host-i386-darwin.c: Moved to... * config/i386/host-i386-darwin.cc: ...here. * config/i386/host-mingw32.c: Moved to... * config/i386/host-mingw32.cc: ...here. * config/i386/i386-builtins.c: Moved to... * config/i386/i386-builtins.cc: ...here. * config/i386/i386-c.c: Moved to... * config/i386/i386-c.cc: ...here. * config/i386/i386-d.c: Moved to... * config/i386/i386-d.cc: ...here. * config/i386/i386-expand.c: Moved to... * config/i386/i386-expand.cc: ...here. * config/i386/i386-features.c: Moved to... * config/i386/i386-features.cc: ...here. * config/i386/i386-options.c: Moved to... * config/i386/i386-options.cc: ...here. * config/i386/i386.c: Moved to... * config/i386/i386.cc: ...here. * config/i386/intelmic-mkoffload.c: Moved to... * config/i386/intelmic-mkoffload.cc: ...here. * config/i386/msformat-c.c: Moved to... * config/i386/msformat-c.cc: ...here. * config/i386/winnt-cxx.c: Moved to... * config/i386/winnt-cxx.cc: ...here. * config/i386/winnt-d.c: Moved to... * config/i386/winnt-d.cc: ...here. * config/i386/winnt-stubs.c: Moved to... * config/i386/winnt-stubs.cc: ...here. * config/i386/winnt.c: Moved to... * config/i386/winnt.cc: ...here. * config/i386/x86-tune-sched-atom.c: Moved to... * config/i386/x86-tune-sched-atom.cc: ...here. * config/i386/x86-tune-sched-bd.c: Moved to... * config/i386/x86-tune-sched-bd.cc: ...here. * config/i386/x86-tune-sched-core.c: Moved to... * config/i386/x86-tune-sched-core.cc: ...here. * config/i386/x86-tune-sched.c: Moved to... * config/i386/x86-tune-sched.cc: ...here. * config/ia64/ia64-c.c: Moved to... * config/ia64/ia64-c.cc: ...here. * config/ia64/ia64.c: Moved to... * config/ia64/ia64.cc: ...here. * config/iq2000/iq2000.c: Moved to... * config/iq2000/iq2000.cc: ...here. * config/linux.c: Moved to... * config/linux.cc: ...here. * config/lm32/lm32.c: Moved to... * config/lm32/lm32.cc: ...here. * config/m32c/m32c-pragma.c: Moved to... * config/m32c/m32c-pragma.cc: ...here. * config/m32c/m32c.c: Moved to... * config/m32c/m32c.cc: ...here. * config/m32r/m32r.c: Moved to... * config/m32r/m32r.cc: ...here. * config/m68k/m68k.c: Moved to... * config/m68k/m68k.cc: ...here. * config/mcore/mcore.c: Moved to... * config/mcore/mcore.cc: ...here. * config/microblaze/microblaze-c.c: Moved to... * config/microblaze/microblaze-c.cc: ...here. * config/microblaze/microblaze.c: Moved to... * config/microblaze/microblaze.cc: ...here. * config/mips/driver-native.c: Moved to... * config/mips/driver-native.cc: ...here. * config/mips/frame-header-opt.c: Moved to... * config/mips/frame-header-opt.cc: ...here. * config/mips/mips-d.c: Moved to... * config/mips/mips-d.cc: ...here. * config/mips/mips.c: Moved to... * config/mips/mips.cc: ...here. * config/mmix/mmix.c: Moved to... * config/mmix/mmix.cc: ...here. * config/mn10300/mn10300.c: Moved to... * config/mn10300/mn10300.cc: ...here. * config/moxie/moxie.c: Moved to... * config/moxie/moxie.cc: ...here. * config/msp430/driver-msp430.c: Moved to... * config/msp430/driver-msp430.cc: ...here. * config/msp430/msp430-c.c: Moved to... * config/msp430/msp430-c.cc: ...here. * config/msp430/msp430-devices.c: Moved to... * config/msp430/msp430-devices.cc: ...here. * config/msp430/msp430.c: Moved to... * config/msp430/msp430.cc: ...here. * config/nds32/nds32-cost.c: Moved to... * config/nds32/nds32-cost.cc: ...here. * config/nds32/nds32-fp-as-gp.c: Moved to... * config/nds32/nds32-fp-as-gp.cc: ...here. * config/nds32/nds32-intrinsic.c: Moved to... * config/nds32/nds32-intrinsic.cc: ...here. * config/nds32/nds32-isr.c: Moved to... * config/nds32/nds32-isr.cc: ...here. * config/nds32/nds32-md-auxiliary.c: Moved to... * config/nds32/nds32-md-auxiliary.cc: ...here. * config/nds32/nds32-memory-manipulation.c: Moved to... * config/nds32/nds32-memory-manipulation.cc: ...here. * config/nds32/nds32-pipelines-auxiliary.c: Moved to... * config/nds32/nds32-pipelines-auxiliary.cc: ...here. * config/nds32/nds32-predicates.c: Moved to... * config/nds32/nds32-predicates.cc: ...here. * config/nds32/nds32-relax-opt.c: Moved to... * config/nds32/nds32-relax-opt.cc: ...here. * config/nds32/nds32-utils.c: Moved to... * config/nds32/nds32-utils.cc: ...here. * config/nds32/nds32.c: Moved to... * config/nds32/nds32.cc: ...here. * config/netbsd-d.c: Moved to... * config/netbsd-d.cc: ...here. * config/netbsd.c: Moved to... * config/netbsd.cc: ...here. * config/nios2/nios2.c: Moved to... * config/nios2/nios2.cc: ...here. * config/nvptx/mkoffload.c: Moved to... * config/nvptx/mkoffload.cc: ...here. * config/nvptx/nvptx-c.c: Moved to... * config/nvptx/nvptx-c.cc: ...here. * config/nvptx/nvptx.c: Moved to... * config/nvptx/nvptx.cc: ...here. * config/openbsd-d.c: Moved to... * config/openbsd-d.cc: ...here. * config/or1k/or1k.c: Moved to... * config/or1k/or1k.cc: ...here. * config/pa/pa-d.c: Moved to... * config/pa/pa-d.cc: ...here. * config/pa/pa.c: Moved to... * config/pa/pa.cc: ...here. * config/pdp11/pdp11.c: Moved to... * config/pdp11/pdp11.cc: ...here. * config/pru/pru-passes.c: Moved to... * config/pru/pru-passes.cc: ...here. * config/pru/pru-pragma.c: Moved to... * config/pru/pru-pragma.cc: ...here. * config/pru/pru.c: Moved to... * config/pru/pru.cc: ...here. * config/riscv/riscv-builtins.c: Moved to... * config/riscv/riscv-builtins.cc: ...here. * config/riscv/riscv-c.c: Moved to... * config/riscv/riscv-c.cc: ...here. * config/riscv/riscv-d.c: Moved to... * config/riscv/riscv-d.cc: ...here. * config/riscv/riscv-shorten-memrefs.c: Moved to... * config/riscv/riscv-shorten-memrefs.cc: ...here. * config/riscv/riscv-sr.c: Moved to... * config/riscv/riscv-sr.cc: ...here. * config/riscv/riscv.c: Moved to... * config/riscv/riscv.cc: ...here. * config/rl78/rl78-c.c: Moved to... * config/rl78/rl78-c.cc: ...here. * config/rl78/rl78.c: Moved to... * config/rl78/rl78.cc: ...here. * config/rs6000/driver-rs6000.c: Moved to... * config/rs6000/driver-rs6000.cc: ...here. * config/rs6000/host-darwin.c: Moved to... * config/rs6000/host-darwin.cc: ...here. * config/rs6000/host-ppc64-darwin.c: Moved to... * config/rs6000/host-ppc64-darwin.cc: ...here. * config/rs6000/rbtree.c: Moved to... * config/rs6000/rbtree.cc: ...here. * config/rs6000/rs6000-c.c: Moved to... * config/rs6000/rs6000-c.cc: ...here. * config/rs6000/rs6000-call.c: Moved to... * config/rs6000/rs6000-call.cc: ...here. * config/rs6000/rs6000-d.c: Moved to... * config/rs6000/rs6000-d.cc: ...here. * config/rs6000/rs6000-gen-builtins.c: Moved to... * config/rs6000/rs6000-gen-builtins.cc: ...here. * config/rs6000/rs6000-linux.c: Moved to... * config/rs6000/rs6000-linux.cc: ...here. * config/rs6000/rs6000-logue.c: Moved to... * config/rs6000/rs6000-logue.cc: ...here. * config/rs6000/rs6000-p8swap.c: Moved to... * config/rs6000/rs6000-p8swap.cc: ...here. * config/rs6000/rs6000-pcrel-opt.c: Moved to... * config/rs6000/rs6000-pcrel-opt.cc: ...here. * config/rs6000/rs6000-string.c: Moved to... * config/rs6000/rs6000-string.cc: ...here. * config/rs6000/rs6000.c: Moved to... * config/rs6000/rs6000.cc: ...here. * config/rx/rx.c: Moved to... * config/rx/rx.cc: ...here. * config/s390/driver-native.c: Moved to... * config/s390/driver-native.cc: ...here. * config/s390/s390-c.c: Moved to... * config/s390/s390-c.cc: ...here. * config/s390/s390-d.c: Moved to... * config/s390/s390-d.cc: ...here. * config/s390/s390.c: Moved to... * config/s390/s390.cc: ...here. * config/sh/divtab-sh4-300.c: Moved to... * config/sh/divtab-sh4-300.cc: ...here. * config/sh/divtab-sh4.c: Moved to... * config/sh/divtab-sh4.cc: ...here. * config/sh/divtab.c: Moved to... * config/sh/divtab.cc: ...here. * config/sh/sh-c.c: Moved to... * config/sh/sh-c.cc: ...here. * config/sh/sh.c: Moved to... * config/sh/sh.cc: ...here. * config/sol2-c.c: Moved to... * config/sol2-c.cc: ...here. * config/sol2-cxx.c: Moved to... * config/sol2-cxx.cc: ...here. * config/sol2-d.c: Moved to... * config/sol2-d.cc: ...here. * config/sol2-stubs.c: Moved to... * config/sol2-stubs.cc: ...here. * config/sol2.c: Moved to... * config/sol2.cc: ...here. * config/sparc/driver-sparc.c: Moved to... * config/sparc/driver-sparc.cc: ...here. * config/sparc/sparc-c.c: Moved to... * config/sparc/sparc-c.cc: ...here. * config/sparc/sparc-d.c: Moved to... * config/sparc/sparc-d.cc: ...here. * config/sparc/sparc.c: Moved to... * config/sparc/sparc.cc: ...here. * config/stormy16/stormy16.c: Moved to... * config/stormy16/stormy16.cc: ...here. * config/tilegx/mul-tables.c: Moved to... * config/tilegx/mul-tables.cc: ...here. * config/tilegx/tilegx-c.c: Moved to... * config/tilegx/tilegx-c.cc: ...here. * config/tilegx/tilegx.c: Moved to... * config/tilegx/tilegx.cc: ...here. * config/tilepro/mul-tables.c: Moved to... * config/tilepro/mul-tables.cc: ...here. * config/tilepro/tilepro-c.c: Moved to... * config/tilepro/tilepro-c.cc: ...here. * config/tilepro/tilepro.c: Moved to... * config/tilepro/tilepro.cc: ...here. * config/v850/v850-c.c: Moved to... * config/v850/v850-c.cc: ...here. * config/v850/v850.c: Moved to... * config/v850/v850.cc: ...here. * config/vax/vax.c: Moved to... * config/vax/vax.cc: ...here. * config/visium/visium.c: Moved to... * config/visium/visium.cc: ...here. * config/vms/vms-c.c: Moved to... * config/vms/vms-c.cc: ...here. * config/vms/vms-f.c: Moved to... * config/vms/vms-f.cc: ...here. * config/vms/vms.c: Moved to... * config/vms/vms.cc: ...here. * config/vxworks-c.c: Moved to... * config/vxworks-c.cc: ...here. * config/vxworks.c: Moved to... * config/vxworks.cc: ...here. * config/winnt-c.c: Moved to... * config/winnt-c.cc: ...here. * config/xtensa/xtensa.c: Moved to... * config/xtensa/xtensa.cc: ...here. * context.c: Moved to... * context.cc: ...here. * convert.c: Moved to... * convert.cc: ...here. * coverage.c: Moved to... * coverage.cc: ...here. * cppbuiltin.c: Moved to... * cppbuiltin.cc: ...here. * cppdefault.c: Moved to... * cppdefault.cc: ...here. * cprop.c: Moved to... * cprop.cc: ...here. * cse.c: Moved to... * cse.cc: ...here. * cselib.c: Moved to... * cselib.cc: ...here. * ctfc.c: Moved to... * ctfc.cc: ...here. * ctfout.c: Moved to... * ctfout.cc: ...here. * data-streamer-in.c: Moved to... * data-streamer-in.cc: ...here. * data-streamer-out.c: Moved to... * data-streamer-out.cc: ...here. * data-streamer.c: Moved to... * data-streamer.cc: ...here. * dbgcnt.c: Moved to... * dbgcnt.cc: ...here. * dbxout.c: Moved to... * dbxout.cc: ...here. * dce.c: Moved to... * dce.cc: ...here. * ddg.c: Moved to... * ddg.cc: ...here. * debug.c: Moved to... * debug.cc: ...here. * df-core.c: Moved to... * df-core.cc: ...here. * df-problems.c: Moved to... * df-problems.cc: ...here. * df-scan.c: Moved to... * df-scan.cc: ...here. * dfp.c: Moved to... * dfp.cc: ...here. * diagnostic-color.c: Moved to... * diagnostic-color.cc: ...here. * diagnostic-show-locus.c: Moved to... * diagnostic-show-locus.cc: ...here. * diagnostic-spec.c: Moved to... * diagnostic-spec.cc: ...here. * diagnostic.c: Moved to... * diagnostic.cc: ...here. * dojump.c: Moved to... * dojump.cc: ...here. * dominance.c: Moved to... * dominance.cc: ...here. * domwalk.c: Moved to... * domwalk.cc: ...here. * double-int.c: Moved to... * double-int.cc: ...here. * dse.c: Moved to... * dse.cc: ...here. * dumpfile.c: Moved to... * dumpfile.cc: ...here. * dwarf2asm.c: Moved to... * dwarf2asm.cc: ...here. * dwarf2cfi.c: Moved to... * dwarf2cfi.cc: ...here. * dwarf2ctf.c: Moved to... * dwarf2ctf.cc: ...here. * dwarf2out.c: Moved to... * dwarf2out.cc: ...here. * early-remat.c: Moved to... * early-remat.cc: ...here. * edit-context.c: Moved to... * edit-context.cc: ...here. * emit-rtl.c: Moved to... * emit-rtl.cc: ...here. * errors.c: Moved to... * errors.cc: ...here. * et-forest.c: Moved to... * et-forest.cc: ...here. * except.c: Moved to... * except.cc: ...here. * explow.c: Moved to... * explow.cc: ...here. * expmed.c: Moved to... * expmed.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * fibonacci_heap.c: Moved to... * fibonacci_heap.cc: ...here. * file-find.c: Moved to... * file-find.cc: ...here. * file-prefix-map.c: Moved to... * file-prefix-map.cc: ...here. * final.c: Moved to... * final.cc: ...here. * fixed-value.c: Moved to... * fixed-value.cc: ...here. * fold-const-call.c: Moved to... * fold-const-call.cc: ...here. * fold-const.c: Moved to... * fold-const.cc: ...here. * fp-test.c: Moved to... * fp-test.cc: ...here. * function-tests.c: Moved to... * function-tests.cc: ...here. * function.c: Moved to... * function.cc: ...here. * fwprop.c: Moved to... * fwprop.cc: ...here. * gcc-ar.c: Moved to... * gcc-ar.cc: ...here. * gcc-main.c: Moved to... * gcc-main.cc: ...here. * gcc-rich-location.c: Moved to... * gcc-rich-location.cc: ...here. * gcc.c: Moved to... * gcc.cc: ...here. * gcov-dump.c: Moved to... * gcov-dump.cc: ...here. * gcov-io.c: Moved to... * gcov-io.cc: ...here. * gcov-tool.c: Moved to... * gcov-tool.cc: ...here. * gcov.c: Moved to... * gcov.cc: ...here. * gcse-common.c: Moved to... * gcse-common.cc: ...here. * gcse.c: Moved to... * gcse.cc: ...here. * genattr-common.c: Moved to... * genattr-common.cc: ...here. * genattr.c: Moved to... * genattr.cc: ...here. * genattrtab.c: Moved to... * genattrtab.cc: ...here. * genautomata.c: Moved to... * genautomata.cc: ...here. * gencfn-macros.c: Moved to... * gencfn-macros.cc: ...here. * gencheck.c: Moved to... * gencheck.cc: ...here. * genchecksum.c: Moved to... * genchecksum.cc: ...here. * gencodes.c: Moved to... * gencodes.cc: ...here. * genconditions.c: Moved to... * genconditions.cc: ...here. * genconfig.c: Moved to... * genconfig.cc: ...here. * genconstants.c: Moved to... * genconstants.cc: ...here. * genemit.c: Moved to... * genemit.cc: ...here. * genenums.c: Moved to... * genenums.cc: ...here. * generic-match-head.c: Moved to... * generic-match-head.cc: ...here. * genextract.c: Moved to... * genextract.cc: ...here. * genflags.c: Moved to... * genflags.cc: ...here. * gengenrtl.c: Moved to... * gengenrtl.cc: ...here. * gengtype-parse.c: Moved to... * gengtype-parse.cc: ...here. * gengtype-state.c: Moved to... * gengtype-state.cc: ...here. * gengtype.c: Moved to... * gengtype.cc: ...here. * genhooks.c: Moved to... * genhooks.cc: ...here. * genmatch.c: Moved to... * genmatch.cc: ...here. * genmddeps.c: Moved to... * genmddeps.cc: ...here. * genmddump.c: Moved to... * genmddump.cc: ...here. * genmodes.c: Moved to... * genmodes.cc: ...here. * genopinit.c: Moved to... * genopinit.cc: ...here. * genoutput.c: Moved to... * genoutput.cc: ...here. * genpeep.c: Moved to... * genpeep.cc: ...here. * genpreds.c: Moved to... * genpreds.cc: ...here. * genrecog.c: Moved to... * genrecog.cc: ...here. * gensupport.c: Moved to... * gensupport.cc: ...here. * gentarget-def.c: Moved to... * gentarget-def.cc: ...here. * genversion.c: Moved to... * genversion.cc: ...here. * ggc-common.c: Moved to... * ggc-common.cc: ...here. * ggc-none.c: Moved to... * ggc-none.cc: ...here. * ggc-page.c: Moved to... * ggc-page.cc: ...here. * ggc-tests.c: Moved to... * ggc-tests.cc: ...here. * gimple-builder.c: Moved to... * gimple-builder.cc: ...here. * gimple-expr.c: Moved to... * gimple-expr.cc: ...here. * gimple-fold.c: Moved to... * gimple-fold.cc: ...here. * gimple-iterator.c: Moved to... * gimple-iterator.cc: ...here. * gimple-laddress.c: Moved to... * gimple-laddress.cc: ...here. * gimple-loop-jam.c: Moved to... * gimple-loop-jam.cc: ...here. * gimple-low.c: Moved to... * gimple-low.cc: ...here. * gimple-match-head.c: Moved to... * gimple-match-head.cc: ...here. * gimple-pretty-print.c: Moved to... * gimple-pretty-print.cc: ...here. * gimple-ssa-backprop.c: Moved to... * gimple-ssa-backprop.cc: ...here. * gimple-ssa-evrp-analyze.c: Moved to... * gimple-ssa-evrp-analyze.cc: ...here. * gimple-ssa-evrp.c: Moved to... * gimple-ssa-evrp.cc: ...here. * gimple-ssa-isolate-paths.c: Moved to... * gimple-ssa-isolate-paths.cc: ...here. * gimple-ssa-nonnull-compare.c: Moved to... * gimple-ssa-nonnull-compare.cc: ...here. * gimple-ssa-split-paths.c: Moved to... * gimple-ssa-split-paths.cc: ...here. * gimple-ssa-sprintf.c: Moved to... * gimple-ssa-sprintf.cc: ...here. * gimple-ssa-store-merging.c: Moved to... * gimple-ssa-store-merging.cc: ...here. * gimple-ssa-strength-reduction.c: Moved to... * gimple-ssa-strength-reduction.cc: ...here. * gimple-ssa-warn-alloca.c: Moved to... * gimple-ssa-warn-alloca.cc: ...here. * gimple-ssa-warn-restrict.c: Moved to... * gimple-ssa-warn-restrict.cc: ...here. * gimple-streamer-in.c: Moved to... * gimple-streamer-in.cc: ...here. * gimple-streamer-out.c: Moved to... * gimple-streamer-out.cc: ...here. * gimple-walk.c: Moved to... * gimple-walk.cc: ...here. * gimple-warn-recursion.c: Moved to... * gimple-warn-recursion.cc: ...here. * gimple.c: Moved to... * gimple.cc: ...here. * gimplify-me.c: Moved to... * gimplify-me.cc: ...here. * gimplify.c: Moved to... * gimplify.cc: ...here. * godump.c: Moved to... * godump.cc: ...here. * graph.c: Moved to... * graph.cc: ...here. * graphds.c: Moved to... * graphds.cc: ...here. * graphite-dependences.c: Moved to... * graphite-dependences.cc: ...here. * graphite-isl-ast-to-gimple.c: Moved to... * graphite-isl-ast-to-gimple.cc: ...here. * graphite-optimize-isl.c: Moved to... * graphite-optimize-isl.cc: ...here. * graphite-poly.c: Moved to... * graphite-poly.cc: ...here. * graphite-scop-detection.c: Moved to... * graphite-scop-detection.cc: ...here. * graphite-sese-to-poly.c: Moved to... * graphite-sese-to-poly.cc: ...here. * graphite.c: Moved to... * graphite.cc: ...here. * haifa-sched.c: Moved to... * haifa-sched.cc: ...here. * hash-map-tests.c: Moved to... * hash-map-tests.cc: ...here. * hash-set-tests.c: Moved to... * hash-set-tests.cc: ...here. * hash-table.c: Moved to... * hash-table.cc: ...here. * hooks.c: Moved to... * hooks.cc: ...here. * host-default.c: Moved to... * host-default.cc: ...here. * hw-doloop.c: Moved to... * hw-doloop.cc: ...here. * hwint.c: Moved to... * hwint.cc: ...here. * ifcvt.c: Moved to... * ifcvt.cc: ...here. * inchash.c: Moved to... * inchash.cc: ...here. * incpath.c: Moved to... * incpath.cc: ...here. * init-regs.c: Moved to... * init-regs.cc: ...here. * input.c: Moved to... * input.cc: ...here. * internal-fn.c: Moved to... * internal-fn.cc: ...here. * intl.c: Moved to... * intl.cc: ...here. * ipa-comdats.c: Moved to... * ipa-comdats.cc: ...here. * ipa-cp.c: Moved to... * ipa-cp.cc: ...here. * ipa-devirt.c: Moved to... * ipa-devirt.cc: ...here. * ipa-fnsummary.c: Moved to... * ipa-fnsummary.cc: ...here. * ipa-icf-gimple.c: Moved to... * ipa-icf-gimple.cc: ...here. * ipa-icf.c: Moved to... * ipa-icf.cc: ...here. * ipa-inline-analysis.c: Moved to... * ipa-inline-analysis.cc: ...here. * ipa-inline-transform.c: Moved to... * ipa-inline-transform.cc: ...here. * ipa-inline.c: Moved to... * ipa-inline.cc: ...here. * ipa-modref-tree.c: Moved to... * ipa-modref-tree.cc: ...here. * ipa-modref.c: Moved to... * ipa-modref.cc: ...here. * ipa-param-manipulation.c: Moved to... * ipa-param-manipulation.cc: ...here. * ipa-polymorphic-call.c: Moved to... * ipa-polymorphic-call.cc: ...here. * ipa-predicate.c: Moved to... * ipa-predicate.cc: ...here. * ipa-profile.c: Moved to... * ipa-profile.cc: ...here. * ipa-prop.c: Moved to... * ipa-prop.cc: ...here. * ipa-pure-const.c: Moved to... * ipa-pure-const.cc: ...here. * ipa-ref.c: Moved to... * ipa-ref.cc: ...here. * ipa-reference.c: Moved to... * ipa-reference.cc: ...here. * ipa-split.c: Moved to... * ipa-split.cc: ...here. * ipa-sra.c: Moved to... * ipa-sra.cc: ...here. * ipa-utils.c: Moved to... * ipa-utils.cc: ...here. * ipa-visibility.c: Moved to... * ipa-visibility.cc: ...here. * ipa.c: Moved to... * ipa.cc: ...here. * ira-build.c: Moved to... * ira-build.cc: ...here. * ira-color.c: Moved to... * ira-color.cc: ...here. * ira-conflicts.c: Moved to... * ira-conflicts.cc: ...here. * ira-costs.c: Moved to... * ira-costs.cc: ...here. * ira-emit.c: Moved to... * ira-emit.cc: ...here. * ira-lives.c: Moved to... * ira-lives.cc: ...here. * ira.c: Moved to... * ira.cc: ...here. * jump.c: Moved to... * jump.cc: ...here. * langhooks.c: Moved to... * langhooks.cc: ...here. * lcm.c: Moved to... * lcm.cc: ...here. * lists.c: Moved to... * lists.cc: ...here. * loop-doloop.c: Moved to... * loop-doloop.cc: ...here. * loop-init.c: Moved to... * loop-init.cc: ...here. * loop-invariant.c: Moved to... * loop-invariant.cc: ...here. * loop-iv.c: Moved to... * loop-iv.cc: ...here. * loop-unroll.c: Moved to... * loop-unroll.cc: ...here. * lower-subreg.c: Moved to... * lower-subreg.cc: ...here. * lra-assigns.c: Moved to... * lra-assigns.cc: ...here. * lra-coalesce.c: Moved to... * lra-coalesce.cc: ...here. * lra-constraints.c: Moved to... * lra-constraints.cc: ...here. * lra-eliminations.c: Moved to... * lra-eliminations.cc: ...here. * lra-lives.c: Moved to... * lra-lives.cc: ...here. * lra-remat.c: Moved to... * lra-remat.cc: ...here. * lra-spills.c: Moved to... * lra-spills.cc: ...here. * lra.c: Moved to... * lra.cc: ...here. * lto-cgraph.c: Moved to... * lto-cgraph.cc: ...here. * lto-compress.c: Moved to... * lto-compress.cc: ...here. * lto-opts.c: Moved to... * lto-opts.cc: ...here. * lto-section-in.c: Moved to... * lto-section-in.cc: ...here. * lto-section-out.c: Moved to... * lto-section-out.cc: ...here. * lto-streamer-in.c: Moved to... * lto-streamer-in.cc: ...here. * lto-streamer-out.c: Moved to... * lto-streamer-out.cc: ...here. * lto-streamer.c: Moved to... * lto-streamer.cc: ...here. * lto-wrapper.c: Moved to... * lto-wrapper.cc: ...here. * main.c: Moved to... * main.cc: ...here. * mcf.c: Moved to... * mcf.cc: ...here. * mode-switching.c: Moved to... * mode-switching.cc: ...here. * modulo-sched.c: Moved to... * modulo-sched.cc: ...here. * multiple_target.c: Moved to... * multiple_target.cc: ...here. * omp-expand.c: Moved to... * omp-expand.cc: ...here. * omp-general.c: Moved to... * omp-general.cc: ...here. * omp-low.c: Moved to... * omp-low.cc: ...here. * omp-offload.c: Moved to... * omp-offload.cc: ...here. * omp-simd-clone.c: Moved to... * omp-simd-clone.cc: ...here. * opt-suggestions.c: Moved to... * opt-suggestions.cc: ...here. * optabs-libfuncs.c: Moved to... * optabs-libfuncs.cc: ...here. * optabs-query.c: Moved to... * optabs-query.cc: ...here. * optabs-tree.c: Moved to... * optabs-tree.cc: ...here. * optabs.c: Moved to... * optabs.cc: ...here. * opts-common.c: Moved to... * opts-common.cc: ...here. * opts-global.c: Moved to... * opts-global.cc: ...here. * opts.c: Moved to... * opts.cc: ...here. * passes.c: Moved to... * passes.cc: ...here. * plugin.c: Moved to... * plugin.cc: ...here. * postreload-gcse.c: Moved to... * postreload-gcse.cc: ...here. * postreload.c: Moved to... * postreload.cc: ...here. * predict.c: Moved to... * predict.cc: ...here. * prefix.c: Moved to... * prefix.cc: ...here. * pretty-print.c: Moved to... * pretty-print.cc: ...here. * print-rtl-function.c: Moved to... * print-rtl-function.cc: ...here. * print-rtl.c: Moved to... * print-rtl.cc: ...here. * print-tree.c: Moved to... * print-tree.cc: ...here. * profile-count.c: Moved to... * profile-count.cc: ...here. * profile.c: Moved to... * profile.cc: ...here. * read-md.c: Moved to... * read-md.cc: ...here. * read-rtl-function.c: Moved to... * read-rtl-function.cc: ...here. * read-rtl.c: Moved to... * read-rtl.cc: ...here. * real.c: Moved to... * real.cc: ...here. * realmpfr.c: Moved to... * realmpfr.cc: ...here. * recog.c: Moved to... * recog.cc: ...here. * ree.c: Moved to... * ree.cc: ...here. * reg-stack.c: Moved to... * reg-stack.cc: ...here. * regcprop.c: Moved to... * regcprop.cc: ...here. * reginfo.c: Moved to... * reginfo.cc: ...here. * regrename.c: Moved to... * regrename.cc: ...here. * regstat.c: Moved to... * regstat.cc: ...here. * reload.c: Moved to... * reload.cc: ...here. * reload1.c: Moved to... * reload1.cc: ...here. * reorg.c: Moved to... * reorg.cc: ...here. * resource.c: Moved to... * resource.cc: ...here. * rtl-error.c: Moved to... * rtl-error.cc: ...here. * rtl-tests.c: Moved to... * rtl-tests.cc: ...here. * rtl.c: Moved to... * rtl.cc: ...here. * rtlanal.c: Moved to... * rtlanal.cc: ...here. * rtlhash.c: Moved to... * rtlhash.cc: ...here. * rtlhooks.c: Moved to... * rtlhooks.cc: ...here. * rtx-vector-builder.c: Moved to... * rtx-vector-builder.cc: ...here. * run-rtl-passes.c: Moved to... * run-rtl-passes.cc: ...here. * sancov.c: Moved to... * sancov.cc: ...here. * sanopt.c: Moved to... * sanopt.cc: ...here. * sbitmap.c: Moved to... * sbitmap.cc: ...here. * sched-deps.c: Moved to... * sched-deps.cc: ...here. * sched-ebb.c: Moved to... * sched-ebb.cc: ...here. * sched-rgn.c: Moved to... * sched-rgn.cc: ...here. * sel-sched-dump.c: Moved to... * sel-sched-dump.cc: ...here. * sel-sched-ir.c: Moved to... * sel-sched-ir.cc: ...here. * sel-sched.c: Moved to... * sel-sched.cc: ...here. * selftest-diagnostic.c: Moved to... * selftest-diagnostic.cc: ...here. * selftest-rtl.c: Moved to... * selftest-rtl.cc: ...here. * selftest-run-tests.c: Moved to... * selftest-run-tests.cc: ...here. * selftest.c: Moved to... * selftest.cc: ...here. * sese.c: Moved to... * sese.cc: ...here. * shrink-wrap.c: Moved to... * shrink-wrap.cc: ...here. * simplify-rtx.c: Moved to... * simplify-rtx.cc: ...here. * sparseset.c: Moved to... * sparseset.cc: ...here. * spellcheck-tree.c: Moved to... * spellcheck-tree.cc: ...here. * spellcheck.c: Moved to... * spellcheck.cc: ...here. * sreal.c: Moved to... * sreal.cc: ...here. * stack-ptr-mod.c: Moved to... * stack-ptr-mod.cc: ...here. * statistics.c: Moved to... * statistics.cc: ...here. * stmt.c: Moved to... * stmt.cc: ...here. * stor-layout.c: Moved to... * stor-layout.cc: ...here. * store-motion.c: Moved to... * store-motion.cc: ...here. * streamer-hooks.c: Moved to... * streamer-hooks.cc: ...here. * stringpool.c: Moved to... * stringpool.cc: ...here. * substring-locations.c: Moved to... * substring-locations.cc: ...here. * symtab.c: Moved to... * symtab.cc: ...here. * target-globals.c: Moved to... * target-globals.cc: ...here. * targhooks.c: Moved to... * targhooks.cc: ...here. * timevar.c: Moved to... * timevar.cc: ...here. * toplev.c: Moved to... * toplev.cc: ...here. * tracer.c: Moved to... * tracer.cc: ...here. * trans-mem.c: Moved to... * trans-mem.cc: ...here. * tree-affine.c: Moved to... * tree-affine.cc: ...here. * tree-call-cdce.c: Moved to... * tree-call-cdce.cc: ...here. * tree-cfg.c: Moved to... * tree-cfg.cc: ...here. * tree-cfgcleanup.c: Moved to... * tree-cfgcleanup.cc: ...here. * tree-chrec.c: Moved to... * tree-chrec.cc: ...here. * tree-complex.c: Moved to... * tree-complex.cc: ...here. * tree-data-ref.c: Moved to... * tree-data-ref.cc: ...here. * tree-dfa.c: Moved to... * tree-dfa.cc: ...here. * tree-diagnostic.c: Moved to... * tree-diagnostic.cc: ...here. * tree-dump.c: Moved to... * tree-dump.cc: ...here. * tree-eh.c: Moved to... * tree-eh.cc: ...here. * tree-emutls.c: Moved to... * tree-emutls.cc: ...here. * tree-if-conv.c: Moved to... * tree-if-conv.cc: ...here. * tree-inline.c: Moved to... * tree-inline.cc: ...here. * tree-into-ssa.c: Moved to... * tree-into-ssa.cc: ...here. * tree-iterator.c: Moved to... * tree-iterator.cc: ...here. * tree-loop-distribution.c: Moved to... * tree-loop-distribution.cc: ...here. * tree-nested.c: Moved to... * tree-nested.cc: ...here. * tree-nrv.c: Moved to... * tree-nrv.cc: ...here. * tree-object-size.c: Moved to... * tree-object-size.cc: ...here. * tree-outof-ssa.c: Moved to... * tree-outof-ssa.cc: ...here. * tree-parloops.c: Moved to... * tree-parloops.cc: ...here. * tree-phinodes.c: Moved to... * tree-phinodes.cc: ...here. * tree-predcom.c: Moved to... * tree-predcom.cc: ...here. * tree-pretty-print.c: Moved to... * tree-pretty-print.cc: ...here. * tree-profile.c: Moved to... * tree-profile.cc: ...here. * tree-scalar-evolution.c: Moved to... * tree-scalar-evolution.cc: ...here. * tree-sra.c: Moved to... * tree-sra.cc: ...here. * tree-ssa-address.c: Moved to... * tree-ssa-address.cc: ...here. * tree-ssa-alias.c: Moved to... * tree-ssa-alias.cc: ...here. * tree-ssa-ccp.c: Moved to... * tree-ssa-ccp.cc: ...here. * tree-ssa-coalesce.c: Moved to... * tree-ssa-coalesce.cc: ...here. * tree-ssa-copy.c: Moved to... * tree-ssa-copy.cc: ...here. * tree-ssa-dce.c: Moved to... * tree-ssa-dce.cc: ...here. * tree-ssa-dom.c: Moved to... * tree-ssa-dom.cc: ...here. * tree-ssa-dse.c: Moved to... * tree-ssa-dse.cc: ...here. * tree-ssa-forwprop.c: Moved to... * tree-ssa-forwprop.cc: ...here. * tree-ssa-ifcombine.c: Moved to... * tree-ssa-ifcombine.cc: ...here. * tree-ssa-live.c: Moved to... * tree-ssa-live.cc: ...here. * tree-ssa-loop-ch.c: Moved to... * tree-ssa-loop-ch.cc: ...here. * tree-ssa-loop-im.c: Moved to... * tree-ssa-loop-im.cc: ...here. * tree-ssa-loop-ivcanon.c: Moved to... * tree-ssa-loop-ivcanon.cc: ...here. * tree-ssa-loop-ivopts.c: Moved to... * tree-ssa-loop-ivopts.cc: ...here. * tree-ssa-loop-manip.c: Moved to... * tree-ssa-loop-manip.cc: ...here. * tree-ssa-loop-niter.c: Moved to... * tree-ssa-loop-niter.cc: ...here. * tree-ssa-loop-prefetch.c: Moved to... * tree-ssa-loop-prefetch.cc: ...here. * tree-ssa-loop-split.c: Moved to... * tree-ssa-loop-split.cc: ...here. * tree-ssa-loop-unswitch.c: Moved to... * tree-ssa-loop-unswitch.cc: ...here. * tree-ssa-loop.c: Moved to... * tree-ssa-loop.cc: ...here. * tree-ssa-math-opts.c: Moved to... * tree-ssa-math-opts.cc: ...here. * tree-ssa-operands.c: Moved to... * tree-ssa-operands.cc: ...here. * tree-ssa-phiopt.c: Moved to... * tree-ssa-phiopt.cc: ...here. * tree-ssa-phiprop.c: Moved to... * tree-ssa-phiprop.cc: ...here. * tree-ssa-pre.c: Moved to... * tree-ssa-pre.cc: ...here. * tree-ssa-propagate.c: Moved to... * tree-ssa-propagate.cc: ...here. * tree-ssa-reassoc.c: Moved to... * tree-ssa-reassoc.cc: ...here. * tree-ssa-sccvn.c: Moved to... * tree-ssa-sccvn.cc: ...here. * tree-ssa-scopedtables.c: Moved to... * tree-ssa-scopedtables.cc: ...here. * tree-ssa-sink.c: Moved to... * tree-ssa-sink.cc: ...here. * tree-ssa-strlen.c: Moved to... * tree-ssa-strlen.cc: ...here. * tree-ssa-structalias.c: Moved to... * tree-ssa-structalias.cc: ...here. * tree-ssa-tail-merge.c: Moved to... * tree-ssa-tail-merge.cc: ...here. * tree-ssa-ter.c: Moved to... * tree-ssa-ter.cc: ...here. * tree-ssa-threadbackward.c: Moved to... * tree-ssa-threadbackward.cc: ...here. * tree-ssa-threadedge.c: Moved to... * tree-ssa-threadedge.cc: ...here. * tree-ssa-threadupdate.c: Moved to... * tree-ssa-threadupdate.cc: ...here. * tree-ssa-uncprop.c: Moved to... * tree-ssa-uncprop.cc: ...here. * tree-ssa-uninit.c: Moved to... * tree-ssa-uninit.cc: ...here. * tree-ssa.c: Moved to... * tree-ssa.cc: ...here. * tree-ssanames.c: Moved to... * tree-ssanames.cc: ...here. * tree-stdarg.c: Moved to... * tree-stdarg.cc: ...here. * tree-streamer-in.c: Moved to... * tree-streamer-in.cc: ...here. * tree-streamer-out.c: Moved to... * tree-streamer-out.cc: ...here. * tree-streamer.c: Moved to... * tree-streamer.cc: ...here. * tree-switch-conversion.c: Moved to... * tree-switch-conversion.cc: ...here. * tree-tailcall.c: Moved to... * tree-tailcall.cc: ...here. * tree-vect-data-refs.c: Moved to... * tree-vect-data-refs.cc: ...here. * tree-vect-generic.c: Moved to... * tree-vect-generic.cc: ...here. * tree-vect-loop-manip.c: Moved to... * tree-vect-loop-manip.cc: ...here. * tree-vect-loop.c: Moved to... * tree-vect-loop.cc: ...here. * tree-vect-patterns.c: Moved to... * tree-vect-patterns.cc: ...here. * tree-vect-slp-patterns.c: Moved to... * tree-vect-slp-patterns.cc: ...here. * tree-vect-slp.c: Moved to... * tree-vect-slp.cc: ...here. * tree-vect-stmts.c: Moved to... * tree-vect-stmts.cc: ...here. * tree-vector-builder.c: Moved to... * tree-vector-builder.cc: ...here. * tree-vectorizer.c: Moved to... * tree-vectorizer.cc: ...here. * tree-vrp.c: Moved to... * tree-vrp.cc: ...here. * tree.c: Moved to... * tree.cc: ...here. * tsan.c: Moved to... * tsan.cc: ...here. * typed-splay-tree.c: Moved to... * typed-splay-tree.cc: ...here. * ubsan.c: Moved to... * ubsan.cc: ...here. * valtrack.c: Moved to... * valtrack.cc: ...here. * value-prof.c: Moved to... * value-prof.cc: ...here. * var-tracking.c: Moved to... * var-tracking.cc: ...here. * varasm.c: Moved to... * varasm.cc: ...here. * varpool.c: Moved to... * varpool.cc: ...here. * vec-perm-indices.c: Moved to... * vec-perm-indices.cc: ...here. * vec.c: Moved to... * vec.cc: ...here. * vmsdbgout.c: Moved to... * vmsdbgout.cc: ...here. * vr-values.c: Moved to... * vr-values.cc: ...here. * vtable-verify.c: Moved to... * vtable-verify.cc: ...here. * web.c: Moved to... * web.cc: ...here. * xcoffout.c: Moved to... * xcoffout.cc: ...here. gcc/c-family/ChangeLog: * c-ada-spec.c: Moved to... * c-ada-spec.cc: ...here. * c-attribs.c: Moved to... * c-attribs.cc: ...here. * c-common.c: Moved to... * c-common.cc: ...here. * c-cppbuiltin.c: Moved to... * c-cppbuiltin.cc: ...here. * c-dump.c: Moved to... * c-dump.cc: ...here. * c-format.c: Moved to... * c-format.cc: ...here. * c-gimplify.c: Moved to... * c-gimplify.cc: ...here. * c-indentation.c: Moved to... * c-indentation.cc: ...here. * c-lex.c: Moved to... * c-lex.cc: ...here. * c-omp.c: Moved to... * c-omp.cc: ...here. * c-opts.c: Moved to... * c-opts.cc: ...here. * c-pch.c: Moved to... * c-pch.cc: ...here. * c-ppoutput.c: Moved to... * c-ppoutput.cc: ...here. * c-pragma.c: Moved to... * c-pragma.cc: ...here. * c-pretty-print.c: Moved to... * c-pretty-print.cc: ...here. * c-semantics.c: Moved to... * c-semantics.cc: ...here. * c-ubsan.c: Moved to... * c-ubsan.cc: ...here. * c-warn.c: Moved to... * c-warn.cc: ...here. * cppspec.c: Moved to... * cppspec.cc: ...here. * stub-objc.c: Moved to... * stub-objc.cc: ...here. gcc/c/ChangeLog: * c-aux-info.c: Moved to... * c-aux-info.cc: ...here. * c-convert.c: Moved to... * c-convert.cc: ...here. * c-decl.c: Moved to... * c-decl.cc: ...here. * c-errors.c: Moved to... * c-errors.cc: ...here. * c-fold.c: Moved to... * c-fold.cc: ...here. * c-lang.c: Moved to... * c-lang.cc: ...here. * c-objc-common.c: Moved to... * c-objc-common.cc: ...here. * c-parser.c: Moved to... * c-parser.cc: ...here. * c-typeck.c: Moved to... * c-typeck.cc: ...here. * gccspec.c: Moved to... * gccspec.cc: ...here. * gimple-parser.c: Moved to... * gimple-parser.cc: ...here. gcc/cp/ChangeLog: * call.c: Moved to... * call.cc: ...here. * class.c: Moved to... * class.cc: ...here. * constexpr.c: Moved to... * constexpr.cc: ...here. * cp-gimplify.c: Moved to... * cp-gimplify.cc: ...here. * cp-lang.c: Moved to... * cp-lang.cc: ...here. * cp-objcp-common.c: Moved to... * cp-objcp-common.cc: ...here. * cp-ubsan.c: Moved to... * cp-ubsan.cc: ...here. * cvt.c: Moved to... * cvt.cc: ...here. * cxx-pretty-print.c: Moved to... * cxx-pretty-print.cc: ...here. * decl.c: Moved to... * decl.cc: ...here. * decl2.c: Moved to... * decl2.cc: ...here. * dump.c: Moved to... * dump.cc: ...here. * error.c: Moved to... * error.cc: ...here. * except.c: Moved to... * except.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * friend.c: Moved to... * friend.cc: ...here. * g++spec.c: Moved to... * g++spec.cc: ...here. * init.c: Moved to... * init.cc: ...here. * lambda.c: Moved to... * lambda.cc: ...here. * lex.c: Moved to... * lex.cc: ...here. * mangle.c: Moved to... * mangle.cc: ...here. * method.c: Moved to... * method.cc: ...here. * name-lookup.c: Moved to... * name-lookup.cc: ...here. * optimize.c: Moved to... * optimize.cc: ...here. * parser.c: Moved to... * parser.cc: ...here. * pt.c: Moved to... * pt.cc: ...here. * ptree.c: Moved to... * ptree.cc: ...here. * rtti.c: Moved to... * rtti.cc: ...here. * search.c: Moved to... * search.cc: ...here. * semantics.c: Moved to... * semantics.cc: ...here. * tree.c: Moved to... * tree.cc: ...here. * typeck.c: Moved to... * typeck.cc: ...here. * typeck2.c: Moved to... * typeck2.cc: ...here. * vtable-class-hierarchy.c: Moved to... * vtable-class-hierarchy.cc: ...here. gcc/fortran/ChangeLog: * arith.c: Moved to... * arith.cc: ...here. * array.c: Moved to... * array.cc: ...here. * bbt.c: Moved to... * bbt.cc: ...here. * check.c: Moved to... * check.cc: ...here. * class.c: Moved to... * class.cc: ...here. * constructor.c: Moved to... * constructor.cc: ...here. * convert.c: Moved to... * convert.cc: ...here. * cpp.c: Moved to... * cpp.cc: ...here. * data.c: Moved to... * data.cc: ...here. * decl.c: Moved to... * decl.cc: ...here. * dependency.c: Moved to... * dependency.cc: ...here. * dump-parse-tree.c: Moved to... * dump-parse-tree.cc: ...here. * error.c: Moved to... * error.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * f95-lang.c: Moved to... * f95-lang.cc: ...here. * frontend-passes.c: Moved to... * frontend-passes.cc: ...here. * gfortranspec.c: Moved to... * gfortranspec.cc: ...here. * interface.c: Moved to... * interface.cc: ...here. * intrinsic.c: Moved to... * intrinsic.cc: ...here. * io.c: Moved to... * io.cc: ...here. * iresolve.c: Moved to... * iresolve.cc: ...here. * match.c: Moved to... * match.cc: ...here. * matchexp.c: Moved to... * matchexp.cc: ...here. * misc.c: Moved to... * misc.cc: ...here. * module.c: Moved to... * module.cc: ...here. * openmp.c: Moved to... * openmp.cc: ...here. * options.c: Moved to... * options.cc: ...here. * parse.c: Moved to... * parse.cc: ...here. * primary.c: Moved to... * primary.cc: ...here. * resolve.c: Moved to... * resolve.cc: ...here. * scanner.c: Moved to... * scanner.cc: ...here. * simplify.c: Moved to... * simplify.cc: ...here. * st.c: Moved to... * st.cc: ...here. * symbol.c: Moved to... * symbol.cc: ...here. * target-memory.c: Moved to... * target-memory.cc: ...here. * trans-array.c: Moved to... * trans-array.cc: ...here. * trans-common.c: Moved to... * trans-common.cc: ...here. * trans-const.c: Moved to... * trans-const.cc: ...here. * trans-decl.c: Moved to... * trans-decl.cc: ...here. * trans-expr.c: Moved to... * trans-expr.cc: ...here. * trans-intrinsic.c: Moved to... * trans-intrinsic.cc: ...here. * trans-io.c: Moved to... * trans-io.cc: ...here. * trans-openmp.c: Moved to... * trans-openmp.cc: ...here. * trans-stmt.c: Moved to... * trans-stmt.cc: ...here. * trans-types.c: Moved to... * trans-types.cc: ...here. * trans.c: Moved to... * trans.cc: ...here. gcc/go/ChangeLog: * go-backend.c: Moved to... * go-backend.cc: ...here. * go-lang.c: Moved to... * go-lang.cc: ...here. * gospec.c: Moved to... * gospec.cc: ...here. gcc/jit/ChangeLog: * dummy-frontend.c: Moved to... * dummy-frontend.cc: ...here. * jit-builtins.c: Moved to... * jit-builtins.cc: ...here. * jit-logging.c: Moved to... * jit-logging.cc: ...here. * jit-playback.c: Moved to... * jit-playback.cc: ...here. * jit-recording.c: Moved to... * jit-recording.cc: ...here. * jit-result.c: Moved to... * jit-result.cc: ...here. * jit-spec.c: Moved to... * jit-spec.cc: ...here. * jit-tempdir.c: Moved to... * jit-tempdir.cc: ...here. * jit-w32.c: Moved to... * jit-w32.cc: ...here. * libgccjit.c: Moved to... * libgccjit.cc: ...here. gcc/lto/ChangeLog: * common.c: Moved to... * common.cc: ...here. * lto-common.c: Moved to... * lto-common.cc: ...here. * lto-dump.c: Moved to... * lto-dump.cc: ...here. * lto-lang.c: Moved to... * lto-lang.cc: ...here. * lto-object.c: Moved to... * lto-object.cc: ...here. * lto-partition.c: Moved to... * lto-partition.cc: ...here. * lto-symtab.c: Moved to... * lto-symtab.cc: ...here. * lto.c: Moved to... * lto.cc: ...here. gcc/objc/ChangeLog: * objc-act.c: Moved to... * objc-act.cc: ...here. * objc-encoding.c: Moved to... * objc-encoding.cc: ...here. * objc-gnu-runtime-abi-01.c: Moved to... * objc-gnu-runtime-abi-01.cc: ...here. * objc-lang.c: Moved to... * objc-lang.cc: ...here. * objc-map.c: Moved to... * objc-map.cc: ...here. * objc-next-runtime-abi-01.c: Moved to... * objc-next-runtime-abi-01.cc: ...here. * objc-next-runtime-abi-02.c: Moved to... * objc-next-runtime-abi-02.cc: ...here. * objc-runtime-shared-support.c: Moved to... * objc-runtime-shared-support.cc: ...here. gcc/objcp/ChangeLog: * objcp-decl.c: Moved to... * objcp-decl.cc: ...here. * objcp-lang.c: Moved to... * objcp-lang.cc: ...here. libcpp/ChangeLog: * charset.c: Moved to... * charset.cc: ...here. * directives.c: Moved to... * directives.cc: ...here. * errors.c: Moved to... * errors.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * files.c: Moved to... * files.cc: ...here. * identifiers.c: Moved to... * identifiers.cc: ...here. * init.c: Moved to... * init.cc: ...here. * lex.c: Moved to... * lex.cc: ...here. * line-map.c: Moved to... * line-map.cc: ...here. * macro.c: Moved to... * macro.cc: ...here. * makeucnid.c: Moved to... * makeucnid.cc: ...here. * mkdeps.c: Moved to... * mkdeps.cc: ...here. * pch.c: Moved to... * pch.cc: ...here. * symtab.c: Moved to... * symtab.cc: ...here. * traditional.c: Moved to... * traditional.cc: ...here.
Diffstat (limited to 'gcc/fortran/symbol.cc')
-rw-r--r--gcc/fortran/symbol.cc5251
1 files changed, 5251 insertions, 0 deletions
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
new file mode 100644
index 0000000..1a4b022
--- /dev/null
+++ b/gcc/fortran/symbol.cc
@@ -0,0 +1,5251 @@
+/* Maintain binary trees of symbols.
+ Copyright (C) 2000-2022 Free Software Foundation, Inc.
+ Contributed by Andy Vaught
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
+
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+#include "gfortran.h"
+#include "parse.h"
+#include "match.h"
+#include "constructor.h"
+
+
+/* Strings for all symbol attributes. We use these for dumping the
+ parse tree, in error messages, and also when reading and writing
+ modules. */
+
+const mstring flavors[] =
+{
+ minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
+ minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
+ minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
+ minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
+ minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
+ minit ("UNION", FL_UNION), minit ("STRUCTURE", FL_STRUCT),
+ minit (NULL, -1)
+};
+
+const mstring procedures[] =
+{
+ minit ("UNKNOWN-PROC", PROC_UNKNOWN),
+ minit ("MODULE-PROC", PROC_MODULE),
+ minit ("INTERNAL-PROC", PROC_INTERNAL),
+ minit ("DUMMY-PROC", PROC_DUMMY),
+ minit ("INTRINSIC-PROC", PROC_INTRINSIC),
+ minit ("EXTERNAL-PROC", PROC_EXTERNAL),
+ minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
+ minit (NULL, -1)
+};
+
+const mstring intents[] =
+{
+ minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
+ minit ("IN", INTENT_IN),
+ minit ("OUT", INTENT_OUT),
+ minit ("INOUT", INTENT_INOUT),
+ minit (NULL, -1)
+};
+
+const mstring access_types[] =
+{
+ minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
+ minit ("PUBLIC", ACCESS_PUBLIC),
+ minit ("PRIVATE", ACCESS_PRIVATE),
+ minit (NULL, -1)
+};
+
+const mstring ifsrc_types[] =
+{
+ minit ("UNKNOWN", IFSRC_UNKNOWN),
+ minit ("DECL", IFSRC_DECL),
+ minit ("BODY", IFSRC_IFBODY)
+};
+
+const mstring save_status[] =
+{
+ minit ("UNKNOWN", SAVE_NONE),
+ minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
+ minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
+};
+
+/* Set the mstrings for DTIO procedure names. */
+const mstring dtio_procs[] =
+{
+ minit ("_dtio_formatted_read", DTIO_RF),
+ minit ("_dtio_formatted_write", DTIO_WF),
+ minit ("_dtio_unformatted_read", DTIO_RUF),
+ minit ("_dtio_unformatted_write", DTIO_WUF),
+};
+
+/* This is to make sure the backend generates setup code in the correct
+ order. */
+
+static int next_dummy_order = 1;
+
+
+gfc_namespace *gfc_current_ns;
+gfc_namespace *gfc_global_ns_list;
+
+gfc_gsymbol *gfc_gsym_root = NULL;
+
+gfc_symbol *gfc_derived_types;
+
+static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL };
+static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var;
+
+
+/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
+
+/* The following static variable indicates whether a particular element has
+ been explicitly set or not. */
+
+static int new_flag[GFC_LETTERS];
+
+
+/* Handle a correctly parsed IMPLICIT NONE. */
+
+void
+gfc_set_implicit_none (bool type, bool external, locus *loc)
+{
+ int i;
+
+ if (external)
+ gfc_current_ns->has_implicit_none_export = 1;
+
+ if (type)
+ {
+ gfc_current_ns->seen_implicit_none = 1;
+ for (i = 0; i < GFC_LETTERS; i++)
+ {
+ if (gfc_current_ns->set_flag[i])
+ {
+ gfc_error_now ("IMPLICIT NONE (type) statement at %L following an "
+ "IMPLICIT statement", loc);
+ return;
+ }
+ gfc_clear_ts (&gfc_current_ns->default_type[i]);
+ gfc_current_ns->set_flag[i] = 1;
+ }
+ }
+}
+
+
+/* Reset the implicit range flags. */
+
+void
+gfc_clear_new_implicit (void)
+{
+ int i;
+
+ for (i = 0; i < GFC_LETTERS; i++)
+ new_flag[i] = 0;
+}
+
+
+/* Prepare for a new implicit range. Sets flags in new_flag[]. */
+
+bool
+gfc_add_new_implicit_range (int c1, int c2)
+{
+ int i;
+
+ c1 -= 'a';
+ c2 -= 'a';
+
+ for (i = c1; i <= c2; i++)
+ {
+ if (new_flag[i])
+ {
+ gfc_error ("Letter %qc already set in IMPLICIT statement at %C",
+ i + 'A');
+ return false;
+ }
+
+ new_flag[i] = 1;
+ }
+
+ return true;
+}
+
+
+/* Add a matched implicit range for gfc_set_implicit(). Check if merging
+ the new implicit types back into the existing types will work. */
+
+bool
+gfc_merge_new_implicit (gfc_typespec *ts)
+{
+ int i;
+
+ if (gfc_current_ns->seen_implicit_none)
+ {
+ gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
+ return false;
+ }
+
+ for (i = 0; i < GFC_LETTERS; i++)
+ {
+ if (new_flag[i])
+ {
+ if (gfc_current_ns->set_flag[i])
+ {
+ gfc_error ("Letter %qc already has an IMPLICIT type at %C",
+ i + 'A');
+ return false;
+ }
+
+ gfc_current_ns->default_type[i] = *ts;
+ gfc_current_ns->implicit_loc[i] = gfc_current_locus;
+ gfc_current_ns->set_flag[i] = 1;
+ }
+ }
+ return true;
+}
+
+
+/* Given a symbol, return a pointer to the typespec for its default type. */
+
+gfc_typespec *
+gfc_get_default_type (const char *name, gfc_namespace *ns)
+{
+ char letter;
+
+ letter = name[0];
+
+ if (flag_allow_leading_underscore && letter == '_')
+ gfc_fatal_error ("Option %<-fallow-leading-underscore%> is for use only by "
+ "gfortran developers, and should not be used for "
+ "implicitly typed variables");
+
+ if (letter < 'a' || letter > 'z')
+ gfc_internal_error ("gfc_get_default_type(): Bad symbol %qs", name);
+
+ if (ns == NULL)
+ ns = gfc_current_ns;
+
+ return &ns->default_type[letter - 'a'];
+}
+
+
+/* Recursively append candidate SYM to CANDIDATES. Store the number of
+ candidates in CANDIDATES_LEN. */
+
+static void
+lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ gfc_symtree *p;
+
+ if (sym == NULL)
+ return;
+
+ if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE)
+ vec_push (candidates, candidates_len, sym->name);
+ p = sym->left;
+ if (p)
+ lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
+
+ p = sym->right;
+ if (p)
+ lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+
+/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account. */
+
+static const char*
+lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, candidates,
+ candidates_len);
+ return gfc_closest_fuzzy_match (sym_name, candidates);
+}
+
+
+/* Given a pointer to a symbol, set its type according to the first
+ letter of its name. Fails if the letter in question has no default
+ type. */
+
+bool
+gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
+{
+ gfc_typespec *ts;
+
+ if (sym->ts.type != BT_UNKNOWN)
+ gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
+
+ ts = gfc_get_default_type (sym->name, ns);
+
+ if (ts->type == BT_UNKNOWN)
+ {
+ if (error_flag && !sym->attr.untyped && !gfc_query_suppress_errors ())
+ {
+ const char *guessed = lookup_symbol_fuzzy (sym->name, sym);
+ if (guessed)
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type"
+ "; did you mean %qs?",
+ sym->name, &sym->declared_at, guessed);
+ else
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+ sym->name, &sym->declared_at);
+ sym->attr.untyped = 1; /* Ensure we only give an error once. */
+ }
+
+ return false;
+ }
+
+ sym->ts = *ts;
+ sym->attr.implicit_type = 1;
+
+ if (ts->type == BT_CHARACTER && ts->u.cl)
+ sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
+ else if (ts->type == BT_CLASS
+ && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
+ return false;
+
+ if (sym->attr.is_bind_c == 1 && warn_c_binding_type)
+ {
+ /* BIND(C) variables should not be implicitly declared. */
+ gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared BIND(C) "
+ "variable %qs at %L may not be C interoperable",
+ sym->name, &sym->declared_at);
+ sym->ts.f90_type = sym->ts.type;
+ }
+
+ if (sym->attr.dummy != 0)
+ {
+ if (sym->ns->proc_name != NULL
+ && (sym->ns->proc_name->attr.subroutine != 0
+ || sym->ns->proc_name->attr.function != 0)
+ && sym->ns->proc_name->attr.is_bind_c != 0
+ && warn_c_binding_type)
+ {
+ /* Dummy args to a BIND(C) routine may not be interoperable if
+ they are implicitly typed. */
+ gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared variable "
+ "%qs at %L may not be C interoperable but it is a "
+ "dummy argument to the BIND(C) procedure %qs at %L",
+ sym->name, &(sym->declared_at),
+ sym->ns->proc_name->name,
+ &(sym->ns->proc_name->declared_at));
+ sym->ts.f90_type = sym->ts.type;
+ }
+ }
+
+ return true;
+}
+
+
+/* This function is called from parse.c(parse_progunit) to check the
+ type of the function is not implicitly typed in the host namespace
+ and to implicitly type the function result, if necessary. */
+
+void
+gfc_check_function_type (gfc_namespace *ns)
+{
+ gfc_symbol *proc = ns->proc_name;
+
+ if (!proc->attr.contained || proc->result->attr.implicit_type)
+ return;
+
+ if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
+ {
+ if (gfc_set_default_type (proc->result, 0, gfc_current_ns))
+ {
+ if (proc->result != proc)
+ {
+ proc->ts = proc->result->ts;
+ proc->as = gfc_copy_array_spec (proc->result->as);
+ proc->attr.dimension = proc->result->attr.dimension;
+ proc->attr.pointer = proc->result->attr.pointer;
+ proc->attr.allocatable = proc->result->attr.allocatable;
+ }
+ }
+ else if (!proc->result->attr.proc_pointer)
+ {
+ gfc_error ("Function result %qs at %L has no IMPLICIT type",
+ proc->result->name, &proc->result->declared_at);
+ proc->result->attr.untyped = 1;
+ }
+ }
+}
+
+
+/******************** Symbol attribute stuff *********************/
+
+/* This is a generic conflict-checker. We do this to avoid having a
+ single conflict in two places. */
+
+#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
+#define conf2(a) if (attr->a) { a2 = a; goto conflict; }
+#define conf_std(a, b, std) if (attr->a && attr->b)\
+ {\
+ a1 = a;\
+ a2 = b;\
+ standard = std;\
+ goto conflict_std;\
+ }
+
+bool
+gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
+{
+ static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
+ *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
+ *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
+ *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
+ *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
+ *privat = "PRIVATE", *recursive = "RECURSIVE",
+ *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
+ *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
+ *function = "FUNCTION", *subroutine = "SUBROUTINE",
+ *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
+ *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
+ *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
+ *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
+ *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
+ *proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT",
+ *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
+ *contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC",
+ *pdt_len = "LEN", *pdt_kind = "KIND";
+ static const char *threadprivate = "THREADPRIVATE";
+ static const char *omp_declare_target = "OMP DECLARE TARGET";
+ static const char *omp_declare_target_link = "OMP DECLARE TARGET LINK";
+ static const char *oacc_declare_copyin = "OACC DECLARE COPYIN";
+ static const char *oacc_declare_create = "OACC DECLARE CREATE";
+ static const char *oacc_declare_deviceptr = "OACC DECLARE DEVICEPTR";
+ static const char *oacc_declare_device_resident =
+ "OACC DECLARE DEVICE_RESIDENT";
+
+ const char *a1, *a2;
+ int standard;
+
+ if (attr->artificial)
+ return true;
+
+ if (where == NULL)
+ where = &gfc_current_locus;
+
+ if (attr->pointer && attr->intent != INTENT_UNKNOWN)
+ {
+ a1 = pointer;
+ a2 = intent;
+ standard = GFC_STD_F2003;
+ goto conflict_std;
+ }
+
+ if (attr->in_namelist && (attr->allocatable || attr->pointer))
+ {
+ a1 = in_namelist;
+ a2 = attr->allocatable ? allocatable : pointer;
+ standard = GFC_STD_F2003;
+ goto conflict_std;
+ }
+
+ /* Check for attributes not allowed in a BLOCK DATA. */
+ if (gfc_current_state () == COMP_BLOCK_DATA)
+ {
+ a1 = NULL;
+
+ if (attr->in_namelist)
+ a1 = in_namelist;
+ if (attr->allocatable)
+ a1 = allocatable;
+ if (attr->external)
+ a1 = external;
+ if (attr->optional)
+ a1 = optional;
+ if (attr->access == ACCESS_PRIVATE)
+ a1 = privat;
+ if (attr->access == ACCESS_PUBLIC)
+ a1 = publik;
+ if (attr->intent != INTENT_UNKNOWN)
+ a1 = intent;
+
+ if (a1 != NULL)
+ {
+ gfc_error
+ ("%s attribute not allowed in BLOCK DATA program unit at %L",
+ a1, where);
+ return false;
+ }
+ }
+
+ if (attr->save == SAVE_EXPLICIT)
+ {
+ conf (dummy, save);
+ conf (in_common, save);
+ conf (result, save);
+ conf (automatic, save);
+
+ switch (attr->flavor)
+ {
+ case FL_PROGRAM:
+ case FL_BLOCK_DATA:
+ case FL_MODULE:
+ case FL_LABEL:
+ case_fl_struct:
+ case FL_PARAMETER:
+ a1 = gfc_code2string (flavors, attr->flavor);
+ a2 = save;
+ goto conflict;
+ case FL_NAMELIST:
+ gfc_error ("Namelist group name at %L cannot have the "
+ "SAVE attribute", where);
+ return false;
+ case FL_PROCEDURE:
+ /* Conflicts between SAVE and PROCEDURE will be checked at
+ resolution stage, see "resolve_fl_procedure". */
+ case FL_VARIABLE:
+ default:
+ break;
+ }
+ }
+
+ /* The copying of procedure dummy arguments for module procedures in
+ a submodule occur whilst the current state is COMP_CONTAINS. It
+ is necessary, therefore, to let this through. */
+ if (name && attr->dummy
+ && (attr->function || attr->subroutine)
+ && gfc_current_state () == COMP_CONTAINS
+ && !(gfc_new_block && gfc_new_block->abr_modproc_decl))
+ gfc_error_now ("internal procedure %qs at %L conflicts with "
+ "DUMMY argument", name, where);
+
+ conf (dummy, entry);
+ conf (dummy, intrinsic);
+ conf (dummy, threadprivate);
+ conf (dummy, omp_declare_target);
+ conf (dummy, omp_declare_target_link);
+ conf (pointer, target);
+ conf (pointer, intrinsic);
+ conf (pointer, elemental);
+ conf (pointer, codimension);
+ conf (allocatable, elemental);
+
+ conf (in_common, automatic);
+ conf (result, automatic);
+ conf (use_assoc, automatic);
+ conf (dummy, automatic);
+
+ conf (target, external);
+ conf (target, intrinsic);
+
+ if (!attr->if_source)
+ conf (external, dimension); /* See Fortran 95's R504. */
+
+ conf (external, intrinsic);
+ conf (entry, intrinsic);
+ conf (abstract, intrinsic);
+
+ if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
+ conf (external, subroutine);
+
+ if (attr->proc_pointer && !gfc_notify_std (GFC_STD_F2003,
+ "Procedure pointer at %C"))
+ return false;
+
+ conf (allocatable, pointer);
+ conf_std (allocatable, dummy, GFC_STD_F2003);
+ conf_std (allocatable, function, GFC_STD_F2003);
+ conf_std (allocatable, result, GFC_STD_F2003);
+ conf_std (elemental, recursive, GFC_STD_F2018);
+
+ conf (in_common, dummy);
+ conf (in_common, allocatable);
+ conf (in_common, codimension);
+ conf (in_common, result);
+
+ conf (in_equivalence, use_assoc);
+ conf (in_equivalence, codimension);
+ conf (in_equivalence, dummy);
+ conf (in_equivalence, target);
+ conf (in_equivalence, pointer);
+ conf (in_equivalence, function);
+ conf (in_equivalence, result);
+ conf (in_equivalence, entry);
+ conf (in_equivalence, allocatable);
+ conf (in_equivalence, threadprivate);
+ conf (in_equivalence, omp_declare_target);
+ conf (in_equivalence, omp_declare_target_link);
+ conf (in_equivalence, oacc_declare_create);
+ conf (in_equivalence, oacc_declare_copyin);
+ conf (in_equivalence, oacc_declare_deviceptr);
+ conf (in_equivalence, oacc_declare_device_resident);
+ conf (in_equivalence, is_bind_c);
+
+ conf (dummy, result);
+ conf (entry, result);
+ conf (generic, result);
+ conf (generic, omp_declare_target);
+ conf (generic, omp_declare_target_link);
+
+ conf (function, subroutine);
+
+ if (!function && !subroutine)
+ conf (is_bind_c, dummy);
+
+ conf (is_bind_c, cray_pointer);
+ conf (is_bind_c, cray_pointee);
+ conf (is_bind_c, codimension);
+ conf (is_bind_c, allocatable);
+ conf (is_bind_c, elemental);
+
+ /* Need to also get volatile attr, according to 5.1 of F2003 draft.
+ Parameter conflict caught below. Also, value cannot be specified
+ for a dummy procedure. */
+
+ /* Cray pointer/pointee conflicts. */
+ conf (cray_pointer, cray_pointee);
+ conf (cray_pointer, dimension);
+ conf (cray_pointer, codimension);
+ conf (cray_pointer, contiguous);
+ conf (cray_pointer, pointer);
+ conf (cray_pointer, target);
+ conf (cray_pointer, allocatable);
+ conf (cray_pointer, external);
+ conf (cray_pointer, intrinsic);
+ conf (cray_pointer, in_namelist);
+ conf (cray_pointer, function);
+ conf (cray_pointer, subroutine);
+ conf (cray_pointer, entry);
+
+ conf (cray_pointee, allocatable);
+ conf (cray_pointee, contiguous);
+ conf (cray_pointee, codimension);
+ conf (cray_pointee, intent);
+ conf (cray_pointee, optional);
+ conf (cray_pointee, dummy);
+ conf (cray_pointee, target);
+ conf (cray_pointee, intrinsic);
+ conf (cray_pointee, pointer);
+ conf (cray_pointee, entry);
+ conf (cray_pointee, in_common);
+ conf (cray_pointee, in_equivalence);
+ conf (cray_pointee, threadprivate);
+ conf (cray_pointee, omp_declare_target);
+ conf (cray_pointee, omp_declare_target_link);
+ conf (cray_pointee, oacc_declare_create);
+ conf (cray_pointee, oacc_declare_copyin);
+ conf (cray_pointee, oacc_declare_deviceptr);
+ conf (cray_pointee, oacc_declare_device_resident);
+
+ conf (data, dummy);
+ conf (data, function);
+ conf (data, result);
+ conf (data, allocatable);
+
+ conf (value, pointer)
+ conf (value, allocatable)
+ conf (value, subroutine)
+ conf (value, function)
+ conf (value, volatile_)
+ conf (value, dimension)
+ conf (value, codimension)
+ conf (value, external)
+
+ conf (codimension, result)
+
+ if (attr->value
+ && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
+ {
+ a1 = value;
+ a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
+ goto conflict;
+ }
+
+ conf (is_protected, intrinsic)
+ conf (is_protected, in_common)
+
+ conf (asynchronous, intrinsic)
+ conf (asynchronous, external)
+
+ conf (volatile_, intrinsic)
+ conf (volatile_, external)
+
+ if (attr->volatile_ && attr->intent == INTENT_IN)
+ {
+ a1 = volatile_;
+ a2 = intent_in;
+ goto conflict;
+ }
+
+ conf (procedure, allocatable)
+ conf (procedure, dimension)
+ conf (procedure, codimension)
+ conf (procedure, intrinsic)
+ conf (procedure, target)
+ conf (procedure, value)
+ conf (procedure, volatile_)
+ conf (procedure, asynchronous)
+ conf (procedure, entry)
+
+ conf (proc_pointer, abstract)
+ conf (proc_pointer, omp_declare_target)
+ conf (proc_pointer, omp_declare_target_link)
+
+ conf (entry, omp_declare_target)
+ conf (entry, omp_declare_target_link)
+ conf (entry, oacc_declare_create)
+ conf (entry, oacc_declare_copyin)
+ conf (entry, oacc_declare_deviceptr)
+ conf (entry, oacc_declare_device_resident)
+
+ conf (pdt_kind, allocatable)
+ conf (pdt_kind, pointer)
+ conf (pdt_kind, dimension)
+ conf (pdt_kind, codimension)
+
+ conf (pdt_len, allocatable)
+ conf (pdt_len, pointer)
+ conf (pdt_len, dimension)
+ conf (pdt_len, codimension)
+ conf (pdt_len, pdt_kind)
+
+ if (attr->access == ACCESS_PRIVATE)
+ {
+ a1 = privat;
+ conf2 (pdt_kind);
+ conf2 (pdt_len);
+ }
+
+ a1 = gfc_code2string (flavors, attr->flavor);
+
+ if (attr->in_namelist
+ && attr->flavor != FL_VARIABLE
+ && attr->flavor != FL_PROCEDURE
+ && attr->flavor != FL_UNKNOWN)
+ {
+ a2 = in_namelist;
+ goto conflict;
+ }
+
+ switch (attr->flavor)
+ {
+ case FL_PROGRAM:
+ case FL_BLOCK_DATA:
+ case FL_MODULE:
+ case FL_LABEL:
+ conf2 (codimension);
+ conf2 (dimension);
+ conf2 (dummy);
+ conf2 (volatile_);
+ conf2 (asynchronous);
+ conf2 (contiguous);
+ conf2 (pointer);
+ conf2 (is_protected);
+ conf2 (target);
+ conf2 (external);
+ conf2 (intrinsic);
+ conf2 (allocatable);
+ conf2 (result);
+ conf2 (in_namelist);
+ conf2 (optional);
+ conf2 (function);
+ conf2 (subroutine);
+ conf2 (threadprivate);
+ conf2 (omp_declare_target);
+ conf2 (omp_declare_target_link);
+ conf2 (oacc_declare_create);
+ conf2 (oacc_declare_copyin);
+ conf2 (oacc_declare_deviceptr);
+ conf2 (oacc_declare_device_resident);
+
+ if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
+ {
+ a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
+ gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
+ name, where);
+ return false;
+ }
+
+ if (attr->is_bind_c)
+ {
+ gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
+ return false;
+ }
+
+ break;
+
+ case FL_VARIABLE:
+ break;
+
+ case FL_NAMELIST:
+ conf2 (result);
+ break;
+
+ case FL_PROCEDURE:
+ /* Conflicts with INTENT, SAVE and RESULT will be checked
+ at resolution stage, see "resolve_fl_procedure". */
+
+ if (attr->subroutine)
+ {
+ a1 = subroutine;
+ conf2 (target);
+ conf2 (allocatable);
+ conf2 (volatile_);
+ conf2 (asynchronous);
+ conf2 (in_namelist);
+ conf2 (codimension);
+ conf2 (dimension);
+ conf2 (function);
+ if (!attr->proc_pointer)
+ conf2 (threadprivate);
+ }
+
+ /* Procedure pointers in COMMON blocks are allowed in F03,
+ * but forbidden per F08:C5100. */
+ if (!attr->proc_pointer || (gfc_option.allow_std & GFC_STD_F2008))
+ conf2 (in_common);
+
+ conf2 (omp_declare_target_link);
+
+ switch (attr->proc)
+ {
+ case PROC_ST_FUNCTION:
+ conf2 (dummy);
+ conf2 (target);
+ break;
+
+ case PROC_MODULE:
+ conf2 (dummy);
+ break;
+
+ case PROC_DUMMY:
+ conf2 (result);
+ conf2 (threadprivate);
+ break;
+
+ default:
+ break;
+ }
+
+ break;
+
+ case_fl_struct:
+ conf2 (dummy);
+ conf2 (pointer);
+ conf2 (target);
+ conf2 (external);
+ conf2 (intrinsic);
+ conf2 (allocatable);
+ conf2 (optional);
+ conf2 (entry);
+ conf2 (function);
+ conf2 (subroutine);
+ conf2 (threadprivate);
+ conf2 (result);
+ conf2 (omp_declare_target);
+ conf2 (omp_declare_target_link);
+ conf2 (oacc_declare_create);
+ conf2 (oacc_declare_copyin);
+ conf2 (oacc_declare_deviceptr);
+ conf2 (oacc_declare_device_resident);
+
+ if (attr->intent != INTENT_UNKNOWN)
+ {
+ a2 = intent;
+ goto conflict;
+ }
+ break;
+
+ case FL_PARAMETER:
+ conf2 (external);
+ conf2 (intrinsic);
+ conf2 (optional);
+ conf2 (allocatable);
+ conf2 (function);
+ conf2 (subroutine);
+ conf2 (entry);
+ conf2 (contiguous);
+ conf2 (pointer);
+ conf2 (is_protected);
+ conf2 (target);
+ conf2 (dummy);
+ conf2 (in_common);
+ conf2 (value);
+ conf2 (volatile_);
+ conf2 (asynchronous);
+ conf2 (threadprivate);
+ conf2 (value);
+ conf2 (codimension);
+ conf2 (result);
+ if (!attr->is_iso_c)
+ conf2 (is_bind_c);
+ break;
+
+ default:
+ break;
+ }
+
+ return true;
+
+conflict:
+ if (name == NULL)
+ gfc_error ("%s attribute conflicts with %s attribute at %L",
+ a1, a2, where);
+ else
+ gfc_error ("%s attribute conflicts with %s attribute in %qs at %L",
+ a1, a2, name, where);
+
+ return false;
+
+conflict_std:
+ if (name == NULL)
+ {
+ return gfc_notify_std (standard, "%s attribute conflicts "
+ "with %s attribute at %L", a1, a2,
+ where);
+ }
+ else
+ {
+ return gfc_notify_std (standard, "%s attribute conflicts "
+ "with %s attribute in %qs at %L",
+ a1, a2, name, where);
+ }
+}
+
+#undef conf
+#undef conf2
+#undef conf_std
+
+
+/* Mark a symbol as referenced. */
+
+void
+gfc_set_sym_referenced (gfc_symbol *sym)
+{
+
+ if (sym->attr.referenced)
+ return;
+
+ sym->attr.referenced = 1;
+
+ /* Remember which order dummy variables are accessed in. */
+ if (sym->attr.dummy)
+ sym->dummy_order = next_dummy_order++;
+}
+
+
+/* Common subroutine called by attribute changing subroutines in order
+ to prevent them from changing a symbol that has been
+ use-associated. Returns zero if it is OK to change the symbol,
+ nonzero if not. */
+
+static int
+check_used (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (attr->use_assoc == 0)
+ return 0;
+
+ if (where == NULL)
+ where = &gfc_current_locus;
+
+ if (name == NULL)
+ gfc_error ("Cannot change attributes of USE-associated symbol at %L",
+ where);
+ else
+ gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
+ name, where);
+
+ return 1;
+}
+
+
+/* Generate an error because of a duplicate attribute. */
+
+static void
+duplicate_attr (const char *attr, locus *where)
+{
+
+ if (where == NULL)
+ where = &gfc_current_locus;
+
+ gfc_error ("Duplicate %s attribute specified at %L", attr, where);
+}
+
+
+bool
+gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
+ locus *where ATTRIBUTE_UNUSED)
+{
+ attr->ext_attr |= 1 << ext_attr;
+ return true;
+}
+
+
+/* Called from decl.c (attr_decl1) to check attributes, when declared
+ separately. */
+
+bool
+gfc_add_attribute (symbol_attribute *attr, locus *where)
+{
+ if (check_used (attr, NULL, where))
+ return false;
+
+ return gfc_check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_allocatable (symbol_attribute *attr, locus *where)
+{
+
+ if (check_used (attr, NULL, where))
+ return false;
+
+ if (attr->allocatable && ! gfc_submodule_procedure(attr))
+ {
+ duplicate_attr ("ALLOCATABLE", where);
+ return false;
+ }
+
+ if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
+ && !gfc_find_state (COMP_INTERFACE))
+ {
+ gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
+ where);
+ return false;
+ }
+
+ attr->allocatable = 1;
+ return gfc_check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_automatic (symbol_attribute *attr, const char *name, locus *where)
+{
+ if (check_used (attr, name, where))
+ return false;
+
+ if (attr->automatic && !gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate AUTOMATIC attribute specified at %L", where))
+ return false;
+
+ attr->automatic = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ if (attr->codimension)
+ {
+ duplicate_attr ("CODIMENSION", where);
+ return false;
+ }
+
+ if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
+ && !gfc_find_state (COMP_INTERFACE))
+ {
+ gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body "
+ "at %L", name, where);
+ return false;
+ }
+
+ attr->codimension = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ if (attr->dimension && ! gfc_submodule_procedure(attr))
+ {
+ duplicate_attr ("DIMENSION", where);
+ return false;
+ }
+
+ if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
+ && !gfc_find_state (COMP_INTERFACE))
+ {
+ gfc_error ("DIMENSION specified for %qs outside its INTERFACE body "
+ "at %L", name, where);
+ return false;
+ }
+
+ attr->dimension = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ attr->contiguous = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_external (symbol_attribute *attr, locus *where)
+{
+
+ if (check_used (attr, NULL, where))
+ return false;
+
+ if (attr->external)
+ {
+ duplicate_attr ("EXTERNAL", where);
+ return false;
+ }
+
+ if (attr->pointer && attr->if_source != IFSRC_IFBODY)
+ {
+ attr->pointer = 0;
+ attr->proc_pointer = 1;
+ }
+
+ attr->external = 1;
+
+ return gfc_check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_intrinsic (symbol_attribute *attr, locus *where)
+{
+
+ if (check_used (attr, NULL, where))
+ return false;
+
+ if (attr->intrinsic)
+ {
+ duplicate_attr ("INTRINSIC", where);
+ return false;
+ }
+
+ attr->intrinsic = 1;
+
+ return gfc_check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_optional (symbol_attribute *attr, locus *where)
+{
+
+ if (check_used (attr, NULL, where))
+ return false;
+
+ if (attr->optional)
+ {
+ duplicate_attr ("OPTIONAL", where);
+ return false;
+ }
+
+ attr->optional = 1;
+ return gfc_check_conflict (attr, NULL, where);
+}
+
+bool
+gfc_add_kind (symbol_attribute *attr, locus *where)
+{
+ if (attr->pdt_kind)
+ {
+ duplicate_attr ("KIND", where);
+ return false;
+ }
+
+ attr->pdt_kind = 1;
+ return gfc_check_conflict (attr, NULL, where);
+}
+
+bool
+gfc_add_len (symbol_attribute *attr, locus *where)
+{
+ if (attr->pdt_len)
+ {
+ duplicate_attr ("LEN", where);
+ return false;
+ }
+
+ attr->pdt_len = 1;
+ return gfc_check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_pointer (symbol_attribute *attr, locus *where)
+{
+
+ if (check_used (attr, NULL, where))
+ return false;
+
+ if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
+ && !gfc_find_state (COMP_INTERFACE))
+ && ! gfc_submodule_procedure(attr))
+ {
+ duplicate_attr ("POINTER", where);
+ return false;
+ }
+
+ if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
+ || (attr->if_source == IFSRC_IFBODY
+ && !gfc_find_state (COMP_INTERFACE)))
+ attr->proc_pointer = 1;
+ else
+ attr->pointer = 1;
+
+ return gfc_check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
+{
+
+ if (check_used (attr, NULL, where))
+ return false;
+
+ attr->cray_pointer = 1;
+ return gfc_check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
+{
+
+ if (check_used (attr, NULL, where))
+ return false;
+
+ if (attr->cray_pointee)
+ {
+ gfc_error ("Cray Pointee at %L appears in multiple pointer()"
+ " statements", where);
+ return false;
+ }
+
+ attr->cray_pointee = 1;
+ return gfc_check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
+{
+ if (check_used (attr, name, where))
+ return false;
+
+ if (attr->is_protected)
+ {
+ if (!gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate PROTECTED attribute specified at %L",
+ where))
+ return false;
+ }
+
+ attr->is_protected = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ attr->result = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
+ locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ if (s == SAVE_EXPLICIT && gfc_pure (NULL))
+ {
+ gfc_error
+ ("SAVE attribute at %L cannot be specified in a PURE procedure",
+ where);
+ return false;
+ }
+
+ if (s == SAVE_EXPLICIT)
+ gfc_unset_implicit_pure (NULL);
+
+ if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT
+ && (flag_automatic || pedantic))
+ {
+ if (!gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate SAVE attribute specified at %L",
+ where))
+ return false;
+ }
+
+ attr->save = s;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ if (attr->value)
+ {
+ if (!gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate VALUE attribute specified at %L",
+ where))
+ return false;
+ }
+
+ attr->value = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
+{
+ /* No check_used needed as 11.2.1 of the F2003 standard allows
+ that the local identifier made accessible by a use statement can be
+ given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
+
+ if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
+ if (!gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate VOLATILE attribute specified at %L",
+ where))
+ return false;
+
+ /* F2008: C1282 A designator of a variable with the VOLATILE attribute
+ shall not appear in a pure subprogram.
+
+ F2018: C1588 A local variable of a pure subprogram, or of a BLOCK
+ construct within a pure subprogram, shall not have the SAVE or
+ VOLATILE attribute. */
+ if (gfc_pure (NULL))
+ {
+ gfc_error ("VOLATILE attribute at %L cannot be specified in a "
+ "PURE procedure", where);
+ return false;
+ }
+
+
+ attr->volatile_ = 1;
+ attr->volatile_ns = gfc_current_ns;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
+{
+ /* No check_used needed as 11.2.1 of the F2003 standard allows
+ that the local identifier made accessible by a use statement can be
+ given a ASYNCHRONOUS attribute. */
+
+ if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
+ if (!gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate ASYNCHRONOUS attribute specified at %L",
+ where))
+ return false;
+
+ attr->asynchronous = 1;
+ attr->asynchronous_ns = gfc_current_ns;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ if (attr->threadprivate)
+ {
+ duplicate_attr ("THREADPRIVATE", where);
+ return false;
+ }
+
+ attr->threadprivate = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_omp_declare_target (symbol_attribute *attr, const char *name,
+ locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ if (attr->omp_declare_target)
+ return true;
+
+ attr->omp_declare_target = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name,
+ locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ if (attr->omp_declare_target_link)
+ return true;
+
+ attr->omp_declare_target_link = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name,
+ locus *where)
+{
+ if (check_used (attr, name, where))
+ return false;
+
+ if (attr->oacc_declare_create)
+ return true;
+
+ attr->oacc_declare_create = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_oacc_declare_copyin (symbol_attribute *attr, const char *name,
+ locus *where)
+{
+ if (check_used (attr, name, where))
+ return false;
+
+ if (attr->oacc_declare_copyin)
+ return true;
+
+ attr->oacc_declare_copyin = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_oacc_declare_deviceptr (symbol_attribute *attr, const char *name,
+ locus *where)
+{
+ if (check_used (attr, name, where))
+ return false;
+
+ if (attr->oacc_declare_deviceptr)
+ return true;
+
+ attr->oacc_declare_deviceptr = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_oacc_declare_device_resident (symbol_attribute *attr, const char *name,
+ locus *where)
+{
+ if (check_used (attr, name, where))
+ return false;
+
+ if (attr->oacc_declare_device_resident)
+ return true;
+
+ attr->oacc_declare_device_resident = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_target (symbol_attribute *attr, locus *where)
+{
+
+ if (check_used (attr, NULL, where))
+ return false;
+
+ if (attr->target)
+ {
+ duplicate_attr ("TARGET", where);
+ return false;
+ }
+
+ attr->target = 1;
+ return gfc_check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ /* Duplicate dummy arguments are allowed due to ENTRY statements. */
+ attr->dummy = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ /* Duplicate attribute already checked for. */
+ attr->in_common = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ /* Duplicate attribute already checked for. */
+ attr->in_equivalence = 1;
+ if (!gfc_check_conflict (attr, name, where))
+ return false;
+
+ if (attr->flavor == FL_VARIABLE)
+ return true;
+
+ return gfc_add_flavor (attr, FL_VARIABLE, name, where);
+}
+
+
+bool
+gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ attr->data = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ attr->in_namelist = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ attr->sequence = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_elemental (symbol_attribute *attr, locus *where)
+{
+
+ if (check_used (attr, NULL, where))
+ return false;
+
+ if (attr->elemental)
+ {
+ duplicate_attr ("ELEMENTAL", where);
+ return false;
+ }
+
+ attr->elemental = 1;
+ return gfc_check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_pure (symbol_attribute *attr, locus *where)
+{
+
+ if (check_used (attr, NULL, where))
+ return false;
+
+ if (attr->pure)
+ {
+ duplicate_attr ("PURE", where);
+ return false;
+ }
+
+ attr->pure = 1;
+ return gfc_check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_recursive (symbol_attribute *attr, locus *where)
+{
+
+ if (check_used (attr, NULL, where))
+ return false;
+
+ if (attr->recursive)
+ {
+ duplicate_attr ("RECURSIVE", where);
+ return false;
+ }
+
+ attr->recursive = 1;
+ return gfc_check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ if (attr->entry)
+ {
+ duplicate_attr ("ENTRY", where);
+ return false;
+ }
+
+ attr->entry = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (attr->flavor != FL_PROCEDURE
+ && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
+ return false;
+
+ attr->function = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (attr->flavor != FL_PROCEDURE
+ && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
+ return false;
+
+ attr->subroutine = 1;
+
+ /* If we are looking at a BLOCK DATA statement and we encounter a
+ name with a leading underscore (which must be
+ compiler-generated), do not check. See PR 84394. */
+
+ if (name && *name != '_' && gfc_current_state () != COMP_BLOCK_DATA)
+ return gfc_check_conflict (attr, name, where);
+ else
+ return true;
+}
+
+
+bool
+gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (attr->flavor != FL_PROCEDURE
+ && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
+ return false;
+
+ attr->generic = 1;
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, NULL, where))
+ return false;
+
+ if (attr->flavor != FL_PROCEDURE
+ && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
+ return false;
+
+ if (attr->procedure)
+ {
+ duplicate_attr ("PROCEDURE", where);
+ return false;
+ }
+
+ attr->procedure = 1;
+
+ return gfc_check_conflict (attr, NULL, where);
+}
+
+
+bool
+gfc_add_abstract (symbol_attribute* attr, locus* where)
+{
+ if (attr->abstract)
+ {
+ duplicate_attr ("ABSTRACT", where);
+ return false;
+ }
+
+ attr->abstract = 1;
+
+ return gfc_check_conflict (attr, NULL, where);
+}
+
+
+/* Flavors are special because some flavors are not what Fortran
+ considers attributes and can be reaffirmed multiple times. */
+
+bool
+gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
+ locus *where)
+{
+
+ if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
+ || f == FL_PARAMETER || f == FL_LABEL || gfc_fl_struct(f)
+ || f == FL_NAMELIST) && check_used (attr, name, where))
+ return false;
+
+ if (attr->flavor == f && f == FL_VARIABLE)
+ return true;
+
+ /* Copying a procedure dummy argument for a module procedure in a
+ submodule results in the flavor being copied and would result in
+ an error without this. */
+ if (attr->flavor == f && f == FL_PROCEDURE
+ && gfc_new_block && gfc_new_block->abr_modproc_decl)
+ return true;
+
+ if (attr->flavor != FL_UNKNOWN)
+ {
+ if (where == NULL)
+ where = &gfc_current_locus;
+
+ if (name)
+ gfc_error ("%s attribute of %qs conflicts with %s attribute at %L",
+ gfc_code2string (flavors, attr->flavor), name,
+ gfc_code2string (flavors, f), where);
+ else
+ gfc_error ("%s attribute conflicts with %s attribute at %L",
+ gfc_code2string (flavors, attr->flavor),
+ gfc_code2string (flavors, f), where);
+
+ return false;
+ }
+
+ attr->flavor = f;
+
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_procedure (symbol_attribute *attr, procedure_type t,
+ const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ if (attr->flavor != FL_PROCEDURE
+ && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
+ return false;
+
+ if (where == NULL)
+ where = &gfc_current_locus;
+
+ if (attr->proc != PROC_UNKNOWN && !attr->module_procedure
+ && attr->access == ACCESS_UNKNOWN)
+ {
+ if (attr->proc == PROC_ST_FUNCTION && t == PROC_INTERNAL
+ && !gfc_notification_std (GFC_STD_F2008))
+ gfc_error ("%s procedure at %L is already declared as %s "
+ "procedure. \nF2008: A pointer function assignment "
+ "is ambiguous if it is the first executable statement "
+ "after the specification block. Please add any other "
+ "kind of executable statement before it. FIXME",
+ gfc_code2string (procedures, t), where,
+ gfc_code2string (procedures, attr->proc));
+ else
+ gfc_error ("%s procedure at %L is already declared as %s "
+ "procedure", gfc_code2string (procedures, t), where,
+ gfc_code2string (procedures, attr->proc));
+
+ return false;
+ }
+
+ attr->proc = t;
+
+ /* Statement functions are always scalar and functions. */
+ if (t == PROC_ST_FUNCTION
+ && ((!attr->function && !gfc_add_function (attr, name, where))
+ || attr->dimension))
+ return false;
+
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
+{
+
+ if (check_used (attr, NULL, where))
+ return false;
+
+ if (attr->intent == INTENT_UNKNOWN)
+ {
+ attr->intent = intent;
+ return gfc_check_conflict (attr, NULL, where);
+ }
+
+ if (where == NULL)
+ where = &gfc_current_locus;
+
+ gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
+ gfc_intent_string (attr->intent),
+ gfc_intent_string (intent), where);
+
+ return false;
+}
+
+
+/* No checks for use-association in public and private statements. */
+
+bool
+gfc_add_access (symbol_attribute *attr, gfc_access access,
+ const char *name, locus *where)
+{
+
+ if (attr->access == ACCESS_UNKNOWN
+ || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
+ {
+ attr->access = access;
+ return gfc_check_conflict (attr, name, where);
+ }
+
+ if (where == NULL)
+ where = &gfc_current_locus;
+ gfc_error ("ACCESS specification at %L was already specified", where);
+
+ return false;
+}
+
+
+/* Set the is_bind_c field for the given symbol_attribute. */
+
+bool
+gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
+ int is_proc_lang_bind_spec)
+{
+
+ if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
+ gfc_error_now ("BIND(C) attribute at %L can only be used for "
+ "variables or common blocks", where);
+ else if (attr->is_bind_c)
+ gfc_error_now ("Duplicate BIND attribute specified at %L", where);
+ else
+ attr->is_bind_c = 1;
+
+ if (where == NULL)
+ where = &gfc_current_locus;
+
+ if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where))
+ return false;
+
+ return gfc_check_conflict (attr, name, where);
+}
+
+
+/* Set the extension field for the given symbol_attribute. */
+
+bool
+gfc_add_extension (symbol_attribute *attr, locus *where)
+{
+ if (where == NULL)
+ where = &gfc_current_locus;
+
+ if (attr->extension)
+ gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
+ else
+ attr->extension = 1;
+
+ if (!gfc_notify_std (GFC_STD_F2003, "EXTENDS at %L", where))
+ return false;
+
+ return true;
+}
+
+
+bool
+gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
+ gfc_formal_arglist * formal, locus *where)
+{
+ if (check_used (&sym->attr, sym->name, where))
+ return false;
+
+ /* Skip the following checks in the case of a module_procedures in a
+ submodule since they will manifestly fail. */
+ if (sym->attr.module_procedure == 1
+ && source == IFSRC_DECL)
+ goto finish;
+
+ if (where == NULL)
+ where = &gfc_current_locus;
+
+ if (sym->attr.if_source != IFSRC_UNKNOWN
+ && sym->attr.if_source != IFSRC_DECL)
+ {
+ gfc_error ("Symbol %qs at %L already has an explicit interface",
+ sym->name, where);
+ return false;
+ }
+
+ if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
+ {
+ gfc_error ("%qs at %L has attributes specified outside its INTERFACE "
+ "body", sym->name, where);
+ return false;
+ }
+
+finish:
+ sym->formal = formal;
+ sym->attr.if_source = source;
+
+ return true;
+}
+
+
+/* Add a type to a symbol. */
+
+bool
+gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
+{
+ sym_flavor flavor;
+ bt type;
+
+ if (where == NULL)
+ where = &gfc_current_locus;
+
+ if (sym->result)
+ type = sym->result->ts.type;
+ else
+ type = sym->ts.type;
+
+ if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
+ type = sym->ns->proc_name->ts.type;
+
+ if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type)
+ && !(gfc_state_stack->previous && gfc_state_stack->previous->previous
+ && gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
+ && !sym->attr.module_procedure)
+ {
+ if (sym->attr.use_assoc)
+ gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
+ "use-associated at %L", sym->name, where, sym->module,
+ &sym->declared_at);
+ else if (sym->attr.function && sym->attr.result)
+ gfc_error ("Symbol %qs at %L already has basic type of %s",
+ sym->ns->proc_name->name, where, gfc_basic_typename (type));
+ else
+ gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name,
+ where, gfc_basic_typename (type));
+ return false;
+ }
+
+ if (sym->attr.procedure && sym->ts.interface)
+ {
+ gfc_error ("Procedure %qs at %L may not have basic type of %s",
+ sym->name, where, gfc_basic_typename (ts->type));
+ return false;
+ }
+
+ flavor = sym->attr.flavor;
+
+ if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
+ || flavor == FL_LABEL
+ || (flavor == FL_PROCEDURE && sym->attr.subroutine)
+ || flavor == FL_DERIVED || flavor == FL_NAMELIST)
+ {
+ gfc_error ("Symbol %qs at %L cannot have a type",
+ sym->ns->proc_name ? sym->ns->proc_name->name : sym->name,
+ where);
+ return false;
+ }
+
+ sym->ts = *ts;
+ return true;
+}
+
+
+/* Clears all attributes. */
+
+void
+gfc_clear_attr (symbol_attribute *attr)
+{
+ memset (attr, 0, sizeof (symbol_attribute));
+}
+
+
+/* Check for missing attributes in the new symbol. Currently does
+ nothing, but it's not clear that it is unnecessary yet. */
+
+bool
+gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
+ locus *where ATTRIBUTE_UNUSED)
+{
+
+ return true;
+}
+
+
+/* Copy an attribute to a symbol attribute, bit by bit. Some
+ attributes have a lot of side-effects but cannot be present given
+ where we are called from, so we ignore some bits. */
+
+bool
+gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
+{
+ int is_proc_lang_bind_spec;
+
+ /* In line with the other attributes, we only add bits but do not remove
+ them; cf. also PR 41034. */
+ dest->ext_attr |= src->ext_attr;
+
+ if (src->allocatable && !gfc_add_allocatable (dest, where))
+ goto fail;
+
+ if (src->automatic && !gfc_add_automatic (dest, NULL, where))
+ goto fail;
+ if (src->dimension && !gfc_add_dimension (dest, NULL, where))
+ goto fail;
+ if (src->codimension && !gfc_add_codimension (dest, NULL, where))
+ goto fail;
+ if (src->contiguous && !gfc_add_contiguous (dest, NULL, where))
+ goto fail;
+ if (src->optional && !gfc_add_optional (dest, where))
+ goto fail;
+ if (src->pointer && !gfc_add_pointer (dest, where))
+ goto fail;
+ if (src->is_protected && !gfc_add_protected (dest, NULL, where))
+ goto fail;
+ if (src->save && !gfc_add_save (dest, src->save, NULL, where))
+ goto fail;
+ if (src->value && !gfc_add_value (dest, NULL, where))
+ goto fail;
+ if (src->volatile_ && !gfc_add_volatile (dest, NULL, where))
+ goto fail;
+ if (src->asynchronous && !gfc_add_asynchronous (dest, NULL, where))
+ goto fail;
+ if (src->threadprivate
+ && !gfc_add_threadprivate (dest, NULL, where))
+ goto fail;
+ if (src->omp_declare_target
+ && !gfc_add_omp_declare_target (dest, NULL, where))
+ goto fail;
+ if (src->omp_declare_target_link
+ && !gfc_add_omp_declare_target_link (dest, NULL, where))
+ goto fail;
+ if (src->oacc_declare_create
+ && !gfc_add_oacc_declare_create (dest, NULL, where))
+ goto fail;
+ if (src->oacc_declare_copyin
+ && !gfc_add_oacc_declare_copyin (dest, NULL, where))
+ goto fail;
+ if (src->oacc_declare_deviceptr
+ && !gfc_add_oacc_declare_deviceptr (dest, NULL, where))
+ goto fail;
+ if (src->oacc_declare_device_resident
+ && !gfc_add_oacc_declare_device_resident (dest, NULL, where))
+ goto fail;
+ if (src->target && !gfc_add_target (dest, where))
+ goto fail;
+ if (src->dummy && !gfc_add_dummy (dest, NULL, where))
+ goto fail;
+ if (src->result && !gfc_add_result (dest, NULL, where))
+ goto fail;
+ if (src->entry)
+ dest->entry = 1;
+
+ if (src->in_namelist && !gfc_add_in_namelist (dest, NULL, where))
+ goto fail;
+
+ if (src->in_common && !gfc_add_in_common (dest, NULL, where))
+ goto fail;
+
+ if (src->generic && !gfc_add_generic (dest, NULL, where))
+ goto fail;
+ if (src->function && !gfc_add_function (dest, NULL, where))
+ goto fail;
+ if (src->subroutine && !gfc_add_subroutine (dest, NULL, where))
+ goto fail;
+
+ if (src->sequence && !gfc_add_sequence (dest, NULL, where))
+ goto fail;
+ if (src->elemental && !gfc_add_elemental (dest, where))
+ goto fail;
+ if (src->pure && !gfc_add_pure (dest, where))
+ goto fail;
+ if (src->recursive && !gfc_add_recursive (dest, where))
+ goto fail;
+
+ if (src->flavor != FL_UNKNOWN
+ && !gfc_add_flavor (dest, src->flavor, NULL, where))
+ goto fail;
+
+ if (src->intent != INTENT_UNKNOWN
+ && !gfc_add_intent (dest, src->intent, where))
+ goto fail;
+
+ if (src->access != ACCESS_UNKNOWN
+ && !gfc_add_access (dest, src->access, NULL, where))
+ goto fail;
+
+ if (!gfc_missing_attr (dest, where))
+ goto fail;
+
+ if (src->cray_pointer && !gfc_add_cray_pointer (dest, where))
+ goto fail;
+ if (src->cray_pointee && !gfc_add_cray_pointee (dest, where))
+ goto fail;
+
+ is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
+ if (src->is_bind_c
+ && !gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec))
+ return false;
+
+ if (src->is_c_interop)
+ dest->is_c_interop = 1;
+ if (src->is_iso_c)
+ dest->is_iso_c = 1;
+
+ if (src->external && !gfc_add_external (dest, where))
+ goto fail;
+ if (src->intrinsic && !gfc_add_intrinsic (dest, where))
+ goto fail;
+ if (src->proc_pointer)
+ dest->proc_pointer = 1;
+
+ return true;
+
+fail:
+ return false;
+}
+
+
+/* A function to generate a dummy argument symbol using that from the
+ interface declaration. Can be used for the result symbol as well if
+ the flag is set. */
+
+int
+gfc_copy_dummy_sym (gfc_symbol **dsym, gfc_symbol *sym, int result)
+{
+ int rc;
+
+ rc = gfc_get_symbol (sym->name, NULL, dsym);
+ if (rc)
+ return rc;
+
+ if (!gfc_add_type (*dsym, &(sym->ts), &gfc_current_locus))
+ return 1;
+
+ if (!gfc_copy_attr (&(*dsym)->attr, &(sym->attr),
+ &gfc_current_locus))
+ return 1;
+
+ if ((*dsym)->attr.dimension)
+ (*dsym)->as = gfc_copy_array_spec (sym->as);
+
+ (*dsym)->attr.class_ok = sym->attr.class_ok;
+
+ if ((*dsym) != NULL && !result
+ && (!gfc_add_dummy(&(*dsym)->attr, (*dsym)->name, NULL)
+ || !gfc_missing_attr (&(*dsym)->attr, NULL)))
+ return 1;
+ else if ((*dsym) != NULL && result
+ && (!gfc_add_result(&(*dsym)->attr, (*dsym)->name, NULL)
+ || !gfc_missing_attr (&(*dsym)->attr, NULL)))
+ return 1;
+
+ return 0;
+}
+
+
+/************** Component name management ************/
+
+/* Component names of a derived type form their own little namespaces
+ that are separate from all other spaces. The space is composed of
+ a singly linked list of gfc_component structures whose head is
+ located in the parent symbol. */
+
+
+/* Add a component name to a symbol. The call fails if the name is
+ already present. On success, the component pointer is modified to
+ point to the additional component structure. */
+
+bool
+gfc_add_component (gfc_symbol *sym, const char *name,
+ gfc_component **component)
+{
+ gfc_component *p, *tail;
+
+ /* Check for existing components with the same name, but not for union
+ components or containers. Unions and maps are anonymous so they have
+ unique internal names which will never conflict.
+ Don't use gfc_find_component here because it calls gfc_use_derived,
+ but the derived type may not be fully defined yet. */
+ tail = NULL;
+
+ for (p = sym->components; p; p = p->next)
+ {
+ if (strcmp (p->name, name) == 0)
+ {
+ gfc_error ("Component %qs at %C already declared at %L",
+ name, &p->loc);
+ return false;
+ }
+
+ tail = p;
+ }
+
+ if (sym->attr.extension
+ && gfc_find_component (sym->components->ts.u.derived,
+ name, true, true, NULL))
+ {
+ gfc_error ("Component %qs at %C already in the parent type "
+ "at %L", name, &sym->components->ts.u.derived->declared_at);
+ return false;
+ }
+
+ /* Allocate a new component. */
+ p = gfc_get_component ();
+
+ if (tail == NULL)
+ sym->components = p;
+ else
+ tail->next = p;
+
+ p->name = gfc_get_string ("%s", name);
+ p->loc = gfc_current_locus;
+ p->ts.type = BT_UNKNOWN;
+
+ *component = p;
+ return true;
+}
+
+
+/* Recursive function to switch derived types of all symbol in a
+ namespace. */
+
+static void
+switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
+{
+ gfc_symbol *sym;
+
+ if (st == NULL)
+ return;
+
+ sym = st->n.sym;
+ if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
+ sym->ts.u.derived = to;
+
+ switch_types (st->left, from, to);
+ switch_types (st->right, from, to);
+}
+
+
+/* This subroutine is called when a derived type is used in order to
+ make the final determination about which version to use. The
+ standard requires that a type be defined before it is 'used', but
+ such types can appear in IMPLICIT statements before the actual
+ definition. 'Using' in this context means declaring a variable to
+ be that type or using the type constructor.
+
+ If a type is used and the components haven't been defined, then we
+ have to have a derived type in a parent unit. We find the node in
+ the other namespace and point the symtree node in this namespace to
+ that node. Further reference to this name point to the correct
+ node. If we can't find the node in a parent namespace, then we have
+ an error.
+
+ This subroutine takes a pointer to a symbol node and returns a
+ pointer to the translated node or NULL for an error. Usually there
+ is no translation and we return the node we were passed. */
+
+gfc_symbol *
+gfc_use_derived (gfc_symbol *sym)
+{
+ gfc_symbol *s;
+ gfc_typespec *t;
+ gfc_symtree *st;
+ int i;
+
+ if (!sym)
+ return NULL;
+
+ if (sym->attr.unlimited_polymorphic)
+ return sym;
+
+ if (sym->attr.generic)
+ sym = gfc_find_dt_in_generic (sym);
+
+ if (sym->components != NULL || sym->attr.zero_comp)
+ return sym; /* Already defined. */
+
+ if (sym->ns->parent == NULL)
+ goto bad;
+
+ if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
+ {
+ gfc_error ("Symbol %qs at %C is ambiguous", sym->name);
+ return NULL;
+ }
+
+ if (s == NULL || !gfc_fl_struct (s->attr.flavor))
+ goto bad;
+
+ /* Get rid of symbol sym, translating all references to s. */
+ for (i = 0; i < GFC_LETTERS; i++)
+ {
+ t = &sym->ns->default_type[i];
+ if (t->u.derived == sym)
+ t->u.derived = s;
+ }
+
+ st = gfc_find_symtree (sym->ns->sym_root, sym->name);
+ st->n.sym = s;
+
+ s->refs++;
+
+ /* Unlink from list of modified symbols. */
+ gfc_commit_symbol (sym);
+
+ switch_types (sym->ns->sym_root, sym, s);
+
+ /* TODO: Also have to replace sym -> s in other lists like
+ namelists, common lists and interface lists. */
+ gfc_free_symbol (sym);
+
+ return s;
+
+bad:
+ gfc_error ("Derived type %qs at %C is being used before it is defined",
+ sym->name);
+ return NULL;
+}
+
+
+/* Find the component with the given name in the union type symbol.
+ If ref is not NULL it will be set to the chain of components through which
+ the component can actually be accessed. This is necessary for unions because
+ intermediate structures may be maps, nested structures, or other unions,
+ all of which may (or must) be 'anonymous' to user code. */
+
+static gfc_component *
+find_union_component (gfc_symbol *un, const char *name,
+ bool noaccess, gfc_ref **ref)
+{
+ gfc_component *m, *check;
+ gfc_ref *sref, *tmp;
+
+ for (m = un->components; m; m = m->next)
+ {
+ check = gfc_find_component (m->ts.u.derived, name, noaccess, true, &tmp);
+ if (check == NULL)
+ continue;
+
+ /* Found component somewhere in m; chain the refs together. */
+ if (ref)
+ {
+ /* Map ref. */
+ sref = gfc_get_ref ();
+ sref->type = REF_COMPONENT;
+ sref->u.c.component = m;
+ sref->u.c.sym = m->ts.u.derived;
+ sref->next = tmp;
+
+ *ref = sref;
+ }
+ /* Other checks (such as access) were done in the recursive calls. */
+ return check;
+ }
+ return NULL;
+}
+
+
+/* Recursively append candidate COMPONENT structures to CANDIDATES. Store
+ the number of total candidates in CANDIDATES_LEN. */
+
+static void
+lookup_component_fuzzy_find_candidates (gfc_component *component,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ for (gfc_component *p = component; p; p = p->next)
+ vec_push (candidates, candidates_len, p->name);
+}
+
+
+/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
+
+static const char*
+lookup_component_fuzzy (const char *member, gfc_component *component)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_component_fuzzy_find_candidates (component, candidates,
+ candidates_len);
+ return gfc_closest_fuzzy_match (member, candidates);
+}
+
+
+/* Given a derived type node and a component name, try to locate the
+ component structure. Returns the NULL pointer if the component is
+ not found or the components are private. If noaccess is set, no access
+ checks are done. If silent is set, an error will not be generated if
+ the component cannot be found or accessed.
+
+ If ref is not NULL, *ref is set to represent the chain of components
+ required to get to the ultimate component.
+
+ If the component is simply a direct subcomponent, or is inherited from a
+ parent derived type in the given derived type, this is a single ref with its
+ component set to the returned component.
+
+ Otherwise, *ref is constructed as a chain of subcomponents. This occurs
+ when the component is found through an implicit chain of nested union and
+ map components. Unions and maps are "anonymous" substructures in FORTRAN
+ which cannot be explicitly referenced, but the reference chain must be
+ considered as in C for backend translation to correctly compute layouts.
+ (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */
+
+gfc_component *
+gfc_find_component (gfc_symbol *sym, const char *name,
+ bool noaccess, bool silent, gfc_ref **ref)
+{
+ gfc_component *p, *check;
+ gfc_ref *sref = NULL, *tmp = NULL;
+
+ if (name == NULL || sym == NULL)
+ return NULL;
+
+ if (sym->attr.flavor == FL_DERIVED)
+ sym = gfc_use_derived (sym);
+ else
+ gcc_assert (gfc_fl_struct (sym->attr.flavor));
+
+ if (sym == NULL)
+ return NULL;
+
+ /* Handle UNIONs specially - mutually recursive with gfc_find_component. */
+ if (sym->attr.flavor == FL_UNION)
+ return find_union_component (sym, name, noaccess, ref);
+
+ if (ref) *ref = NULL;
+ for (p = sym->components; p; p = p->next)
+ {
+ /* Nest search into union's maps. */
+ if (p->ts.type == BT_UNION)
+ {
+ check = find_union_component (p->ts.u.derived, name, noaccess, &tmp);
+ if (check != NULL)
+ {
+ /* Union ref. */
+ if (ref)
+ {
+ sref = gfc_get_ref ();
+ sref->type = REF_COMPONENT;
+ sref->u.c.component = p;
+ sref->u.c.sym = p->ts.u.derived;
+ sref->next = tmp;
+ *ref = sref;
+ }
+ return check;
+ }
+ }
+ else if (strcmp (p->name, name) == 0)
+ break;
+
+ continue;
+ }
+
+ if (p && sym->attr.use_assoc && !noaccess)
+ {
+ bool is_parent_comp = sym->attr.extension && (p == sym->components);
+ if (p->attr.access == ACCESS_PRIVATE ||
+ (p->attr.access != ACCESS_PUBLIC
+ && sym->component_access == ACCESS_PRIVATE
+ && !is_parent_comp))
+ {
+ if (!silent)
+ gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
+ name, sym->name);
+ return NULL;
+ }
+ }
+
+ if (p == NULL
+ && sym->attr.extension
+ && sym->components->ts.type == BT_DERIVED)
+ {
+ p = gfc_find_component (sym->components->ts.u.derived, name,
+ noaccess, silent, ref);
+ /* Do not overwrite the error. */
+ if (p == NULL)
+ return p;
+ }
+
+ if (p == NULL && !silent)
+ {
+ const char *guessed = lookup_component_fuzzy (name, sym->components);
+ if (guessed)
+ gfc_error ("%qs at %C is not a member of the %qs structure"
+ "; did you mean %qs?",
+ name, sym->name, guessed);
+ else
+ gfc_error ("%qs at %C is not a member of the %qs structure",
+ name, sym->name);
+ }
+
+ /* Component was found; build the ultimate component reference. */
+ if (p != NULL && ref)
+ {
+ tmp = gfc_get_ref ();
+ tmp->type = REF_COMPONENT;
+ tmp->u.c.component = p;
+ tmp->u.c.sym = sym;
+ /* Link the final component ref to the end of the chain of subrefs. */
+ if (sref)
+ {
+ *ref = sref;
+ for (; sref->next; sref = sref->next)
+ ;
+ sref->next = tmp;
+ }
+ else
+ *ref = tmp;
+ }
+
+ return p;
+}
+
+
+/* Given a symbol, free all of the component structures and everything
+ they point to. */
+
+static void
+free_components (gfc_component *p)
+{
+ gfc_component *q;
+
+ for (; p; p = q)
+ {
+ q = p->next;
+
+ gfc_free_array_spec (p->as);
+ gfc_free_expr (p->initializer);
+ if (p->kind_expr)
+ gfc_free_expr (p->kind_expr);
+ if (p->param_list)
+ gfc_free_actual_arglist (p->param_list);
+ free (p->tb);
+ p->tb = NULL;
+ free (p);
+ }
+}
+
+
+/******************** Statement label management ********************/
+
+/* Comparison function for statement labels, used for managing the
+ binary tree. */
+
+static int
+compare_st_labels (void *a1, void *b1)
+{
+ int a = ((gfc_st_label *) a1)->value;
+ int b = ((gfc_st_label *) b1)->value;
+
+ return (b - a);
+}
+
+
+/* Free a single gfc_st_label structure, making sure the tree is not
+ messed up. This function is called only when some parse error
+ occurs. */
+
+void
+gfc_free_st_label (gfc_st_label *label)
+{
+
+ if (label == NULL)
+ return;
+
+ gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels);
+
+ if (label->format != NULL)
+ gfc_free_expr (label->format);
+
+ free (label);
+}
+
+
+/* Free a whole tree of gfc_st_label structures. */
+
+static void
+free_st_labels (gfc_st_label *label)
+{
+
+ if (label == NULL)
+ return;
+
+ free_st_labels (label->left);
+ free_st_labels (label->right);
+
+ if (label->format != NULL)
+ gfc_free_expr (label->format);
+ free (label);
+}
+
+
+/* Given a label number, search for and return a pointer to the label
+ structure, creating it if it does not exist. */
+
+gfc_st_label *
+gfc_get_st_label (int labelno)
+{
+ gfc_st_label *lp;
+ gfc_namespace *ns;
+
+ if (gfc_current_state () == COMP_DERIVED)
+ ns = gfc_current_block ()->f2k_derived;
+ else
+ {
+ /* Find the namespace of the scoping unit:
+ If we're in a BLOCK construct, jump to the parent namespace. */
+ ns = gfc_current_ns;
+ while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
+ ns = ns->parent;
+ }
+
+ /* First see if the label is already in this namespace. */
+ lp = ns->st_labels;
+ while (lp)
+ {
+ if (lp->value == labelno)
+ return lp;
+
+ if (lp->value < labelno)
+ lp = lp->left;
+ else
+ lp = lp->right;
+ }
+
+ lp = XCNEW (gfc_st_label);
+
+ lp->value = labelno;
+ lp->defined = ST_LABEL_UNKNOWN;
+ lp->referenced = ST_LABEL_UNKNOWN;
+ lp->ns = ns;
+
+ gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
+
+ return lp;
+}
+
+
+/* Called when a statement with a statement label is about to be
+ accepted. We add the label to the list of the current namespace,
+ making sure it hasn't been defined previously and referenced
+ correctly. */
+
+void
+gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
+{
+ int labelno;
+
+ labelno = lp->value;
+
+ if (lp->defined != ST_LABEL_UNKNOWN)
+ gfc_error ("Duplicate statement label %d at %L and %L", labelno,
+ &lp->where, label_locus);
+ else
+ {
+ lp->where = *label_locus;
+
+ switch (type)
+ {
+ case ST_LABEL_FORMAT:
+ if (lp->referenced == ST_LABEL_TARGET
+ || lp->referenced == ST_LABEL_DO_TARGET)
+ gfc_error ("Label %d at %C already referenced as branch target",
+ labelno);
+ else
+ lp->defined = ST_LABEL_FORMAT;
+
+ break;
+
+ case ST_LABEL_TARGET:
+ case ST_LABEL_DO_TARGET:
+ if (lp->referenced == ST_LABEL_FORMAT)
+ gfc_error ("Label %d at %C already referenced as a format label",
+ labelno);
+ else
+ lp->defined = type;
+
+ if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET
+ && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
+ "DO termination statement which is not END DO"
+ " or CONTINUE with label %d at %C", labelno))
+ return;
+ break;
+
+ default:
+ lp->defined = ST_LABEL_BAD_TARGET;
+ lp->referenced = ST_LABEL_BAD_TARGET;
+ }
+ }
+}
+
+
+/* Reference a label. Given a label and its type, see if that
+ reference is consistent with what is known about that label,
+ updating the unknown state. Returns false if something goes
+ wrong. */
+
+bool
+gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
+{
+ gfc_sl_type label_type;
+ int labelno;
+ bool rc;
+
+ if (lp == NULL)
+ return true;
+
+ labelno = lp->value;
+
+ if (lp->defined != ST_LABEL_UNKNOWN)
+ label_type = lp->defined;
+ else
+ {
+ label_type = lp->referenced;
+ lp->where = gfc_current_locus;
+ }
+
+ if (label_type == ST_LABEL_FORMAT
+ && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET))
+ {
+ gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
+ rc = false;
+ goto done;
+ }
+
+ if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET
+ || label_type == ST_LABEL_BAD_TARGET)
+ && type == ST_LABEL_FORMAT)
+ {
+ gfc_error ("Label %d at %C previously used as branch target", labelno);
+ rc = false;
+ goto done;
+ }
+
+ if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
+ && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
+ "Shared DO termination label %d at %C", labelno))
+ return false;
+
+ if (type == ST_LABEL_DO_TARGET
+ && !gfc_notify_std (GFC_STD_F2018_OBS, "Labeled DO statement "
+ "at %L", &gfc_current_locus))
+ return false;
+
+ if (lp->referenced != ST_LABEL_DO_TARGET)
+ lp->referenced = type;
+ rc = true;
+
+done:
+ return rc;
+}
+
+
+/************** Symbol table management subroutines ****************/
+
+/* Basic details: Fortran 95 requires a potentially unlimited number
+ of distinct namespaces when compiling a program unit. This case
+ occurs during a compilation of internal subprograms because all of
+ the internal subprograms must be read before we can start
+ generating code for the host.
+
+ Given the tricky nature of the Fortran grammar, we must be able to
+ undo changes made to a symbol table if the current interpretation
+ of a statement is found to be incorrect. Whenever a symbol is
+ looked up, we make a copy of it and link to it. All of these
+ symbols are kept in a vector so that we can commit or
+ undo the changes at a later time.
+
+ A symtree may point to a symbol node outside of its namespace. In
+ this case, that symbol has been used as a host associated variable
+ at some previous time. */
+
+/* Allocate a new namespace structure. Copies the implicit types from
+ PARENT if PARENT_TYPES is set. */
+
+gfc_namespace *
+gfc_get_namespace (gfc_namespace *parent, int parent_types)
+{
+ gfc_namespace *ns;
+ gfc_typespec *ts;
+ int in;
+ int i;
+
+ ns = XCNEW (gfc_namespace);
+ ns->sym_root = NULL;
+ ns->uop_root = NULL;
+ ns->tb_sym_root = NULL;
+ ns->finalizers = NULL;
+ ns->default_access = ACCESS_UNKNOWN;
+ ns->parent = parent;
+
+ for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
+ {
+ ns->operator_access[in] = ACCESS_UNKNOWN;
+ ns->tb_op[in] = NULL;
+ }
+
+ /* Initialize default implicit types. */
+ for (i = 'a'; i <= 'z'; i++)
+ {
+ ns->set_flag[i - 'a'] = 0;
+ ts = &ns->default_type[i - 'a'];
+
+ if (parent_types && ns->parent != NULL)
+ {
+ /* Copy parent settings. */
+ *ts = ns->parent->default_type[i - 'a'];
+ continue;
+ }
+
+ if (flag_implicit_none != 0)
+ {
+ gfc_clear_ts (ts);
+ continue;
+ }
+
+ if ('i' <= i && i <= 'n')
+ {
+ ts->type = BT_INTEGER;
+ ts->kind = gfc_default_integer_kind;
+ }
+ else
+ {
+ ts->type = BT_REAL;
+ ts->kind = gfc_default_real_kind;
+ }
+ }
+
+ ns->refs = 1;
+
+ return ns;
+}
+
+
+/* Comparison function for symtree nodes. */
+
+static int
+compare_symtree (void *_st1, void *_st2)
+{
+ gfc_symtree *st1, *st2;
+
+ st1 = (gfc_symtree *) _st1;
+ st2 = (gfc_symtree *) _st2;
+
+ return strcmp (st1->name, st2->name);
+}
+
+
+/* Allocate a new symtree node and associate it with the new symbol. */
+
+gfc_symtree *
+gfc_new_symtree (gfc_symtree **root, const char *name)
+{
+ gfc_symtree *st;
+
+ st = XCNEW (gfc_symtree);
+ st->name = gfc_get_string ("%s", name);
+
+ gfc_insert_bbt (root, st, compare_symtree);
+ return st;
+}
+
+
+/* Delete a symbol from the tree. Does not free the symbol itself! */
+
+void
+gfc_delete_symtree (gfc_symtree **root, const char *name)
+{
+ gfc_symtree st, *st0;
+ const char *p;
+
+ /* Submodules are marked as mod.submod. When freeing a submodule
+ symbol, the symtree only has "submod", so adjust that here. */
+
+ p = strrchr(name, '.');
+ if (p)
+ p++;
+ else
+ p = name;
+
+ st0 = gfc_find_symtree (*root, p);
+
+ st.name = gfc_get_string ("%s", p);
+ gfc_delete_bbt (root, &st, compare_symtree);
+
+ free (st0);
+}
+
+
+/* Given a root symtree node and a name, try to find the symbol within
+ the namespace. Returns NULL if the symbol is not found. */
+
+gfc_symtree *
+gfc_find_symtree (gfc_symtree *st, const char *name)
+{
+ int c;
+
+ while (st != NULL)
+ {
+ c = strcmp (name, st->name);
+ if (c == 0)
+ return st;
+
+ st = (c < 0) ? st->left : st->right;
+ }
+
+ return NULL;
+}
+
+
+/* Return a symtree node with a name that is guaranteed to be unique
+ within the namespace and corresponds to an illegal fortran name. */
+
+gfc_symtree *
+gfc_get_unique_symtree (gfc_namespace *ns)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ static int serial = 0;
+
+ sprintf (name, "@%d", serial++);
+ return gfc_new_symtree (&ns->sym_root, name);
+}
+
+
+/* Given a name find a user operator node, creating it if it doesn't
+ exist. These are much simpler than symbols because they can't be
+ ambiguous with one another. */
+
+gfc_user_op *
+gfc_get_uop (const char *name)
+{
+ gfc_user_op *uop;
+ gfc_symtree *st;
+ gfc_namespace *ns = gfc_current_ns;
+
+ if (ns->omp_udr_ns)
+ ns = ns->parent;
+ st = gfc_find_symtree (ns->uop_root, name);
+ if (st != NULL)
+ return st->n.uop;
+
+ st = gfc_new_symtree (&ns->uop_root, name);
+
+ uop = st->n.uop = XCNEW (gfc_user_op);
+ uop->name = gfc_get_string ("%s", name);
+ uop->access = ACCESS_UNKNOWN;
+ uop->ns = ns;
+
+ return uop;
+}
+
+
+/* Given a name find the user operator node. Returns NULL if it does
+ not exist. */
+
+gfc_user_op *
+gfc_find_uop (const char *name, gfc_namespace *ns)
+{
+ gfc_symtree *st;
+
+ if (ns == NULL)
+ ns = gfc_current_ns;
+
+ st = gfc_find_symtree (ns->uop_root, name);
+ return (st == NULL) ? NULL : st->n.uop;
+}
+
+
+/* Update a symbol's common_block field, and take care of the associated
+ memory management. */
+
+static void
+set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block)
+{
+ if (sym->common_block == common_block)
+ return;
+
+ if (sym->common_block && sym->common_block->name[0] != '\0')
+ {
+ sym->common_block->refs--;
+ if (sym->common_block->refs == 0)
+ free (sym->common_block);
+ }
+ sym->common_block = common_block;
+}
+
+
+/* Remove a gfc_symbol structure and everything it points to. */
+
+void
+gfc_free_symbol (gfc_symbol *&sym)
+{
+
+ if (sym == NULL)
+ return;
+
+ gfc_free_array_spec (sym->as);
+
+ free_components (sym->components);
+
+ gfc_free_expr (sym->value);
+
+ gfc_free_namelist (sym->namelist);
+
+ if (sym->ns != sym->formal_ns)
+ gfc_free_namespace (sym->formal_ns);
+
+ if (!sym->attr.generic_copy)
+ gfc_free_interface (sym->generic);
+
+ gfc_free_formal_arglist (sym->formal);
+
+ gfc_free_namespace (sym->f2k_derived);
+
+ set_symbol_common_block (sym, NULL);
+
+ if (sym->param_list)
+ gfc_free_actual_arglist (sym->param_list);
+
+ free (sym);
+ sym = NULL;
+}
+
+
+/* Decrease the reference counter and free memory when we reach zero. */
+
+void
+gfc_release_symbol (gfc_symbol *&sym)
+{
+ if (sym == NULL)
+ return;
+
+ if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns
+ && (!sym->attr.entry || !sym->module))
+ {
+ /* As formal_ns contains a reference to sym, delete formal_ns just
+ before the deletion of sym. */
+ gfc_namespace *ns = sym->formal_ns;
+ sym->formal_ns = NULL;
+ gfc_free_namespace (ns);
+ }
+
+ sym->refs--;
+ if (sym->refs > 0)
+ return;
+
+ gcc_assert (sym->refs == 0);
+ gfc_free_symbol (sym);
+}
+
+
+/* Allocate and initialize a new symbol node. */
+
+gfc_symbol *
+gfc_new_symbol (const char *name, gfc_namespace *ns)
+{
+ gfc_symbol *p;
+
+ p = XCNEW (gfc_symbol);
+
+ gfc_clear_ts (&p->ts);
+ gfc_clear_attr (&p->attr);
+ p->ns = ns;
+ p->declared_at = gfc_current_locus;
+ p->name = gfc_get_string ("%s", name);
+
+ return p;
+}
+
+
+/* Generate an error if a symbol is ambiguous, and set the error flag
+ on it. */
+
+static void
+ambiguous_symbol (const char *name, gfc_symtree *st)
+{
+
+ if (st->n.sym->error)
+ return;
+
+ if (st->n.sym->module)
+ gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
+ "from module %qs", name, st->n.sym->name, st->n.sym->module);
+ else
+ gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
+ "from current program unit", name, st->n.sym->name);
+
+ st->n.sym->error = 1;
+}
+
+
+/* If we're in a SELECT TYPE block, check if the variable 'st' matches any
+ selector on the stack. If yes, replace it by the corresponding temporary. */
+
+static void
+select_type_insert_tmp (gfc_symtree **st)
+{
+ gfc_select_type_stack *stack = select_type_stack;
+ for (; stack; stack = stack->prev)
+ if ((*st)->n.sym == stack->selector && stack->tmp)
+ {
+ *st = stack->tmp;
+ select_type_insert_tmp (st);
+ return;
+ }
+}
+
+
+/* Look for a symtree in the current procedure -- that is, go up to
+ parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
+
+gfc_symtree*
+gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
+{
+ while (ns)
+ {
+ gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
+ if (st)
+ return st;
+
+ if (!ns->construct_entities)
+ break;
+ ns = ns->parent;
+ }
+
+ return NULL;
+}
+
+
+/* Search for a symtree starting in the current namespace, resorting to
+ any parent namespaces if requested by a nonzero parent_flag.
+ Returns nonzero if the name is ambiguous. */
+
+int
+gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
+ gfc_symtree **result)
+{
+ gfc_symtree *st;
+
+ if (ns == NULL)
+ ns = gfc_current_ns;
+
+ do
+ {
+ st = gfc_find_symtree (ns->sym_root, name);
+ if (st != NULL)
+ {
+ select_type_insert_tmp (&st);
+
+ *result = st;
+ /* Ambiguous generic interfaces are permitted, as long
+ as the specific interfaces are different. */
+ if (st->ambiguous && !st->n.sym->attr.generic)
+ {
+ ambiguous_symbol (name, st);
+ return 1;
+ }
+
+ return 0;
+ }
+
+ if (!parent_flag)
+ break;
+
+ /* Don't escape an interface block. */
+ if (ns && !ns->has_import_set
+ && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
+ break;
+
+ ns = ns->parent;
+ }
+ while (ns != NULL);
+
+ if (gfc_current_state() == COMP_DERIVED
+ && gfc_current_block ()->attr.pdt_template)
+ {
+ gfc_symbol *der = gfc_current_block ();
+ for (; der; der = gfc_get_derived_super_type (der))
+ {
+ if (der->f2k_derived && der->f2k_derived->sym_root)
+ {
+ st = gfc_find_symtree (der->f2k_derived->sym_root, name);
+ if (st)
+ break;
+ }
+ }
+ *result = st;
+ return 0;
+ }
+
+ *result = NULL;
+
+ return 0;
+}
+
+
+/* Same, but returns the symbol instead. */
+
+int
+gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
+ gfc_symbol **result)
+{
+ gfc_symtree *st;
+ int i;
+
+ i = gfc_find_sym_tree (name, ns, parent_flag, &st);
+
+ if (st == NULL)
+ *result = NULL;
+ else
+ *result = st->n.sym;
+
+ return i;
+}
+
+
+/* Tells whether there is only one set of changes in the stack. */
+
+static bool
+single_undo_checkpoint_p (void)
+{
+ if (latest_undo_chgset == &default_undo_chgset_var)
+ {
+ gcc_assert (latest_undo_chgset->previous == NULL);
+ return true;
+ }
+ else
+ {
+ gcc_assert (latest_undo_chgset->previous != NULL);
+ return false;
+ }
+}
+
+/* Save symbol with the information necessary to back it out. */
+
+void
+gfc_save_symbol_data (gfc_symbol *sym)
+{
+ gfc_symbol *s;
+ unsigned i;
+
+ if (!single_undo_checkpoint_p ())
+ {
+ /* If there is more than one change set, look for the symbol in the
+ current one. If it is found there, we can reuse it. */
+ FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
+ if (s == sym)
+ {
+ gcc_assert (sym->gfc_new || sym->old_symbol != NULL);
+ return;
+ }
+ }
+ else if (sym->gfc_new || sym->old_symbol != NULL)
+ return;
+
+ s = XCNEW (gfc_symbol);
+ *s = *sym;
+ sym->old_symbol = s;
+ sym->gfc_new = 0;
+
+ latest_undo_chgset->syms.safe_push (sym);
+}
+
+
+/* Given a name, find a symbol, or create it if it does not exist yet
+ in the current namespace. If the symbol is found we make sure that
+ it's OK.
+
+ The integer return code indicates
+ 0 All OK
+ 1 The symbol name was ambiguous
+ 2 The name meant to be established was already host associated.
+
+ So if the return value is nonzero, then an error was issued. */
+
+int
+gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
+ bool allow_subroutine)
+{
+ gfc_symtree *st;
+ gfc_symbol *p;
+
+ /* This doesn't usually happen during resolution. */
+ if (ns == NULL)
+ ns = gfc_current_ns;
+
+ /* Try to find the symbol in ns. */
+ st = gfc_find_symtree (ns->sym_root, name);
+
+ if (st == NULL && ns->omp_udr_ns)
+ {
+ ns = ns->parent;
+ st = gfc_find_symtree (ns->sym_root, name);
+ }
+
+ if (st == NULL)
+ {
+ /* If not there, create a new symbol. */
+ p = gfc_new_symbol (name, ns);
+
+ /* Add to the list of tentative symbols. */
+ p->old_symbol = NULL;
+ p->mark = 1;
+ p->gfc_new = 1;
+ latest_undo_chgset->syms.safe_push (p);
+
+ st = gfc_new_symtree (&ns->sym_root, name);
+ st->n.sym = p;
+ p->refs++;
+
+ }
+ else
+ {
+ /* Make sure the existing symbol is OK. Ambiguous
+ generic interfaces are permitted, as long as the
+ specific interfaces are different. */
+ if (st->ambiguous && !st->n.sym->attr.generic)
+ {
+ ambiguous_symbol (name, st);
+ return 1;
+ }
+
+ p = st->n.sym;
+ if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
+ && !(allow_subroutine && p->attr.subroutine)
+ && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
+ && (ns->has_import_set || p->attr.imported)))
+ {
+ /* Symbol is from another namespace. */
+ gfc_error ("Symbol %qs at %C has already been host associated",
+ name);
+ return 2;
+ }
+
+ p->mark = 1;
+
+ /* Copy in case this symbol is changed. */
+ gfc_save_symbol_data (p);
+ }
+
+ *result = st;
+ return 0;
+}
+
+
+int
+gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
+{
+ gfc_symtree *st;
+ int i;
+
+ i = gfc_get_sym_tree (name, ns, &st, false);
+ if (i != 0)
+ return i;
+
+ if (st)
+ *result = st->n.sym;
+ else
+ *result = NULL;
+ return i;
+}
+
+
+/* Subroutine that searches for a symbol, creating it if it doesn't
+ exist, but tries to host-associate the symbol if possible. */
+
+int
+gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
+{
+ gfc_symtree *st;
+ int i;
+
+ i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
+
+ if (st != NULL)
+ {
+ gfc_save_symbol_data (st->n.sym);
+ *result = st;
+ return i;
+ }
+
+ i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st);
+ if (i)
+ return i;
+
+ if (st != NULL)
+ {
+ *result = st;
+ return 0;
+ }
+
+ return gfc_get_sym_tree (name, gfc_current_ns, result, false);
+}
+
+
+int
+gfc_get_ha_symbol (const char *name, gfc_symbol **result)
+{
+ int i;
+ gfc_symtree *st;
+
+ i = gfc_get_ha_sym_tree (name, &st);
+
+ if (st)
+ *result = st->n.sym;
+ else
+ *result = NULL;
+
+ return i;
+}
+
+
+/* Search for the symtree belonging to a gfc_common_head; we cannot use
+ head->name as the common_root symtree's name might be mangled. */
+
+static gfc_symtree *
+find_common_symtree (gfc_symtree *st, gfc_common_head *head)
+{
+
+ gfc_symtree *result;
+
+ if (st == NULL)
+ return NULL;
+
+ if (st->n.common == head)
+ return st;
+
+ result = find_common_symtree (st->left, head);
+ if (!result)
+ result = find_common_symtree (st->right, head);
+
+ return result;
+}
+
+
+/* Restore previous state of symbol. Just copy simple stuff. */
+
+static void
+restore_old_symbol (gfc_symbol *p)
+{
+ gfc_symbol *old;
+
+ p->mark = 0;
+ old = p->old_symbol;
+
+ p->ts.type = old->ts.type;
+ p->ts.kind = old->ts.kind;
+
+ p->attr = old->attr;
+
+ if (p->value != old->value)
+ {
+ gcc_checking_assert (old->value == NULL);
+ gfc_free_expr (p->value);
+ p->value = NULL;
+ }
+
+ if (p->as != old->as)
+ {
+ if (p->as)
+ gfc_free_array_spec (p->as);
+ p->as = old->as;
+ }
+
+ p->generic = old->generic;
+ p->component_access = old->component_access;
+
+ if (p->namelist != NULL && old->namelist == NULL)
+ {
+ gfc_free_namelist (p->namelist);
+ p->namelist = NULL;
+ }
+ else
+ {
+ if (p->namelist_tail != old->namelist_tail)
+ {
+ gfc_free_namelist (old->namelist_tail->next);
+ old->namelist_tail->next = NULL;
+ }
+ }
+
+ p->namelist_tail = old->namelist_tail;
+
+ if (p->formal != old->formal)
+ {
+ gfc_free_formal_arglist (p->formal);
+ p->formal = old->formal;
+ }
+
+ set_symbol_common_block (p, old->common_block);
+ p->common_head = old->common_head;
+
+ p->old_symbol = old->old_symbol;
+ free (old);
+}
+
+
+/* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
+ the structure itself. */
+
+static void
+free_undo_change_set_data (gfc_undo_change_set &cs)
+{
+ cs.syms.release ();
+ cs.tbps.release ();
+}
+
+
+/* Given a change set pointer, free its target's contents and update it with
+ the address of the previous change set. Note that only the contents are
+ freed, not the target itself (the contents' container). It is not a problem
+ as the latter will be a local variable usually. */
+
+static void
+pop_undo_change_set (gfc_undo_change_set *&cs)
+{
+ free_undo_change_set_data (*cs);
+ cs = cs->previous;
+}
+
+
+static void free_old_symbol (gfc_symbol *sym);
+
+
+/* Merges the current change set into the previous one. The changes themselves
+ are left untouched; only one checkpoint is forgotten. */
+
+void
+gfc_drop_last_undo_checkpoint (void)
+{
+ gfc_symbol *s, *t;
+ unsigned i, j;
+
+ FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
+ {
+ /* No need to loop in this case. */
+ if (s->old_symbol == NULL)
+ continue;
+
+ /* Remove the duplicate symbols. */
+ FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t)
+ if (t == s)
+ {
+ latest_undo_chgset->previous->syms.unordered_remove (j);
+
+ /* S->OLD_SYMBOL is the backup symbol for S as it was at the
+ last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
+ shall contain from now on the backup symbol for S as it was
+ at the checkpoint before. */
+ if (s->old_symbol->gfc_new)
+ {
+ gcc_assert (s->old_symbol->old_symbol == NULL);
+ s->gfc_new = s->old_symbol->gfc_new;
+ free_old_symbol (s);
+ }
+ else
+ restore_old_symbol (s->old_symbol);
+ break;
+ }
+ }
+
+ latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms);
+ latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps);
+
+ pop_undo_change_set (latest_undo_chgset);
+}
+
+
+/* Undoes all the changes made to symbols since the previous checkpoint.
+ This subroutine is made simpler due to the fact that attributes are
+ never removed once added. */
+
+void
+gfc_restore_last_undo_checkpoint (void)
+{
+ gfc_symbol *p;
+ unsigned i;
+
+ FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
+ {
+ /* Symbol in a common block was new. Or was old and just put in common */
+ if (p->common_block
+ && (p->gfc_new || !p->old_symbol->common_block))
+ {
+ /* If the symbol was added to any common block, it
+ needs to be removed to stop the resolver looking
+ for a (possibly) dead symbol. */
+ if (p->common_block->head == p && !p->common_next)
+ {
+ gfc_symtree st, *st0;
+ st0 = find_common_symtree (p->ns->common_root,
+ p->common_block);
+ if (st0)
+ {
+ st.name = st0->name;
+ gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree);
+ free (st0);
+ }
+ }
+
+ if (p->common_block->head == p)
+ p->common_block->head = p->common_next;
+ else
+ {
+ gfc_symbol *cparent, *csym;
+
+ cparent = p->common_block->head;
+ csym = cparent->common_next;
+
+ while (csym != p)
+ {
+ cparent = csym;
+ csym = csym->common_next;
+ }
+
+ gcc_assert(cparent->common_next == p);
+ cparent->common_next = csym->common_next;
+ }
+ p->common_next = NULL;
+ }
+ if (p->gfc_new)
+ {
+ /* The derived type is saved in the symtree with the first
+ letter capitalized; the all lower-case version to the
+ derived type contains its associated generic function. */
+ if (gfc_fl_struct (p->attr.flavor))
+ gfc_delete_symtree (&p->ns->sym_root,gfc_dt_upper_string (p->name));
+ else
+ gfc_delete_symtree (&p->ns->sym_root, p->name);
+
+ gfc_release_symbol (p);
+ }
+ else
+ restore_old_symbol (p);
+ }
+
+ latest_undo_chgset->syms.truncate (0);
+ latest_undo_chgset->tbps.truncate (0);
+
+ if (!single_undo_checkpoint_p ())
+ pop_undo_change_set (latest_undo_chgset);
+}
+
+
+/* Makes sure that there is only one set of changes; in other words we haven't
+ forgotten to pair a call to gfc_new_checkpoint with a call to either
+ gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
+
+static void
+enforce_single_undo_checkpoint (void)
+{
+ gcc_checking_assert (single_undo_checkpoint_p ());
+}
+
+
+/* Undoes all the changes made to symbols in the current statement. */
+
+void
+gfc_undo_symbols (void)
+{
+ enforce_single_undo_checkpoint ();
+ gfc_restore_last_undo_checkpoint ();
+}
+
+
+/* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
+ components of old_symbol that might need deallocation are the "allocatables"
+ that are restored in gfc_undo_symbols(), with two exceptions: namelist and
+ namelist_tail. In case these differ between old_symbol and sym, it's just
+ because sym->namelist has gotten a few more items. */
+
+static void
+free_old_symbol (gfc_symbol *sym)
+{
+
+ if (sym->old_symbol == NULL)
+ return;
+
+ if (sym->old_symbol->as != sym->as)
+ gfc_free_array_spec (sym->old_symbol->as);
+
+ if (sym->old_symbol->value != sym->value)
+ gfc_free_expr (sym->old_symbol->value);
+
+ if (sym->old_symbol->formal != sym->formal)
+ gfc_free_formal_arglist (sym->old_symbol->formal);
+
+ free (sym->old_symbol);
+ sym->old_symbol = NULL;
+}
+
+
+/* Makes the changes made in the current statement permanent-- gets
+ rid of undo information. */
+
+void
+gfc_commit_symbols (void)
+{
+ gfc_symbol *p;
+ gfc_typebound_proc *tbp;
+ unsigned i;
+
+ enforce_single_undo_checkpoint ();
+
+ FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
+ {
+ p->mark = 0;
+ p->gfc_new = 0;
+ free_old_symbol (p);
+ }
+ latest_undo_chgset->syms.truncate (0);
+
+ FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp)
+ tbp->error = 0;
+ latest_undo_chgset->tbps.truncate (0);
+}
+
+
+/* Makes the changes made in one symbol permanent -- gets rid of undo
+ information. */
+
+void
+gfc_commit_symbol (gfc_symbol *sym)
+{
+ gfc_symbol *p;
+ unsigned i;
+
+ enforce_single_undo_checkpoint ();
+
+ FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
+ if (p == sym)
+ {
+ latest_undo_chgset->syms.unordered_remove (i);
+ break;
+ }
+
+ sym->mark = 0;
+ sym->gfc_new = 0;
+
+ free_old_symbol (sym);
+}
+
+
+/* Recursively free trees containing type-bound procedures. */
+
+static void
+free_tb_tree (gfc_symtree *t)
+{
+ if (t == NULL)
+ return;
+
+ free_tb_tree (t->left);
+ free_tb_tree (t->right);
+
+ /* TODO: Free type-bound procedure u.generic */
+ free (t->n.tb);
+ t->n.tb = NULL;
+ free (t);
+}
+
+
+/* Recursive function that deletes an entire tree and all the common
+ head structures it points to. */
+
+static void
+free_common_tree (gfc_symtree * common_tree)
+{
+ if (common_tree == NULL)
+ return;
+
+ free_common_tree (common_tree->left);
+ free_common_tree (common_tree->right);
+
+ free (common_tree);
+}
+
+
+/* Recursive function that deletes an entire tree and all the common
+ head structures it points to. */
+
+static void
+free_omp_udr_tree (gfc_symtree * omp_udr_tree)
+{
+ if (omp_udr_tree == NULL)
+ return;
+
+ free_omp_udr_tree (omp_udr_tree->left);
+ free_omp_udr_tree (omp_udr_tree->right);
+
+ gfc_free_omp_udr (omp_udr_tree->n.omp_udr);
+ free (omp_udr_tree);
+}
+
+
+/* Recursive function that deletes an entire tree and all the user
+ operator nodes that it contains. */
+
+static void
+free_uop_tree (gfc_symtree *uop_tree)
+{
+ if (uop_tree == NULL)
+ return;
+
+ free_uop_tree (uop_tree->left);
+ free_uop_tree (uop_tree->right);
+
+ gfc_free_interface (uop_tree->n.uop->op);
+ free (uop_tree->n.uop);
+ free (uop_tree);
+}
+
+
+/* Recursive function that deletes an entire tree and all the symbols
+ that it contains. */
+
+static void
+free_sym_tree (gfc_symtree *sym_tree)
+{
+ if (sym_tree == NULL)
+ return;
+
+ free_sym_tree (sym_tree->left);
+ free_sym_tree (sym_tree->right);
+
+ gfc_release_symbol (sym_tree->n.sym);
+ free (sym_tree);
+}
+
+
+/* Free the gfc_equiv_info's. */
+
+static void
+gfc_free_equiv_infos (gfc_equiv_info *s)
+{
+ if (s == NULL)
+ return;
+ gfc_free_equiv_infos (s->next);
+ free (s);
+}
+
+
+/* Free the gfc_equiv_lists. */
+
+static void
+gfc_free_equiv_lists (gfc_equiv_list *l)
+{
+ if (l == NULL)
+ return;
+ gfc_free_equiv_lists (l->next);
+ gfc_free_equiv_infos (l->equiv);
+ free (l);
+}
+
+
+/* Free a finalizer procedure list. */
+
+void
+gfc_free_finalizer (gfc_finalizer* el)
+{
+ if (el)
+ {
+ gfc_release_symbol (el->proc_sym);
+ free (el);
+ }
+}
+
+static void
+gfc_free_finalizer_list (gfc_finalizer* list)
+{
+ while (list)
+ {
+ gfc_finalizer* current = list;
+ list = list->next;
+ gfc_free_finalizer (current);
+ }
+}
+
+
+/* Create a new gfc_charlen structure and add it to a namespace.
+ If 'old_cl' is given, the newly created charlen will be a copy of it. */
+
+gfc_charlen*
+gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
+{
+ gfc_charlen *cl;
+
+ cl = gfc_get_charlen ();
+
+ /* Copy old_cl. */
+ if (old_cl)
+ {
+ cl->length = gfc_copy_expr (old_cl->length);
+ cl->length_from_typespec = old_cl->length_from_typespec;
+ cl->backend_decl = old_cl->backend_decl;
+ cl->passed_length = old_cl->passed_length;
+ cl->resolved = old_cl->resolved;
+ }
+
+ /* Put into namespace. */
+ cl->next = ns->cl_list;
+ ns->cl_list = cl;
+
+ return cl;
+}
+
+
+/* Free the charlen list from cl to end (end is not freed).
+ Free the whole list if end is NULL. */
+
+static void
+gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
+{
+ gfc_charlen *cl2;
+
+ for (; cl != end; cl = cl2)
+ {
+ gcc_assert (cl);
+
+ cl2 = cl->next;
+ gfc_free_expr (cl->length);
+ free (cl);
+ }
+}
+
+
+/* Free entry list structs. */
+
+static void
+free_entry_list (gfc_entry_list *el)
+{
+ gfc_entry_list *next;
+
+ if (el == NULL)
+ return;
+
+ next = el->next;
+ free (el);
+ free_entry_list (next);
+}
+
+
+/* Free a namespace structure and everything below it. Interface
+ lists associated with intrinsic operators are not freed. These are
+ taken care of when a specific name is freed. */
+
+void
+gfc_free_namespace (gfc_namespace *&ns)
+{
+ gfc_namespace *p, *q;
+ int i;
+ gfc_was_finalized *f;
+
+ if (ns == NULL)
+ return;
+
+ ns->refs--;
+ if (ns->refs > 0)
+ return;
+
+ gcc_assert (ns->refs == 0);
+
+ gfc_free_statements (ns->code);
+
+ free_sym_tree (ns->sym_root);
+ free_uop_tree (ns->uop_root);
+ free_common_tree (ns->common_root);
+ free_omp_udr_tree (ns->omp_udr_root);
+ free_tb_tree (ns->tb_sym_root);
+ free_tb_tree (ns->tb_uop_root);
+ gfc_free_finalizer_list (ns->finalizers);
+ gfc_free_omp_declare_simd_list (ns->omp_declare_simd);
+ gfc_free_omp_declare_variant_list (ns->omp_declare_variant);
+ gfc_free_charlen (ns->cl_list, NULL);
+ free_st_labels (ns->st_labels);
+
+ free_entry_list (ns->entries);
+ gfc_free_equiv (ns->equiv);
+ gfc_free_equiv_lists (ns->equiv_lists);
+ gfc_free_use_stmts (ns->use_stmts);
+
+ for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
+ gfc_free_interface (ns->op[i]);
+
+ gfc_free_data (ns->data);
+
+ /* Free all the expr + component combinations that have been
+ finalized. */
+ f = ns->was_finalized;
+ while (f)
+ {
+ gfc_was_finalized* current = f;
+ f = f->next;
+ free (current);
+ }
+
+ p = ns->contained;
+ free (ns);
+ ns = NULL;
+
+ /* Recursively free any contained namespaces. */
+ while (p != NULL)
+ {
+ q = p;
+ p = p->sibling;
+ gfc_free_namespace (q);
+ }
+}
+
+
+void
+gfc_symbol_init_2 (void)
+{
+
+ gfc_current_ns = gfc_get_namespace (NULL, 0);
+}
+
+
+void
+gfc_symbol_done_2 (void)
+{
+ if (gfc_current_ns != NULL)
+ {
+ /* free everything from the root. */
+ while (gfc_current_ns->parent != NULL)
+ gfc_current_ns = gfc_current_ns->parent;
+ gfc_free_namespace (gfc_current_ns);
+ gfc_current_ns = NULL;
+ }
+ gfc_derived_types = NULL;
+
+ enforce_single_undo_checkpoint ();
+ free_undo_change_set_data (*latest_undo_chgset);
+}
+
+
+/* Count how many nodes a symtree has. */
+
+static unsigned
+count_st_nodes (const gfc_symtree *st)
+{
+ unsigned nodes;
+ if (!st)
+ return 0;
+
+ nodes = count_st_nodes (st->left);
+ nodes++;
+ nodes += count_st_nodes (st->right);
+
+ return nodes;
+}
+
+
+/* Convert symtree tree into symtree vector. */
+
+static unsigned
+fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
+{
+ if (!st)
+ return node_cntr;
+
+ node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
+ st_vec[node_cntr++] = st;
+ node_cntr = fill_st_vector (st->right, st_vec, node_cntr);
+
+ return node_cntr;
+}
+
+
+/* Traverse namespace. As the functions might modify the symtree, we store the
+ symtree as a vector and operate on this vector. Note: We assume that
+ sym_func or st_func never deletes nodes from the symtree - only adding is
+ allowed. Additionally, newly added nodes are not traversed. */
+
+static void
+do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
+ void (*sym_func) (gfc_symbol *))
+{
+ gfc_symtree **st_vec;
+ unsigned nodes, i, node_cntr;
+
+ gcc_assert ((st_func && !sym_func) || (!st_func && sym_func));
+ nodes = count_st_nodes (st);
+ st_vec = XALLOCAVEC (gfc_symtree *, nodes);
+ node_cntr = 0;
+ fill_st_vector (st, st_vec, node_cntr);
+
+ if (sym_func)
+ {
+ /* Clear marks. */
+ for (i = 0; i < nodes; i++)
+ st_vec[i]->n.sym->mark = 0;
+ for (i = 0; i < nodes; i++)
+ if (!st_vec[i]->n.sym->mark)
+ {
+ (*sym_func) (st_vec[i]->n.sym);
+ st_vec[i]->n.sym->mark = 1;
+ }
+ }
+ else
+ for (i = 0; i < nodes; i++)
+ (*st_func) (st_vec[i]);
+}
+
+
+/* Recursively traverse the symtree nodes. */
+
+void
+gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
+{
+ do_traverse_symtree (st, st_func, NULL);
+}
+
+
+/* Call a given function for all symbols in the namespace. We take
+ care that each gfc_symbol node is called exactly once. */
+
+void
+gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
+{
+ do_traverse_symtree (ns->sym_root, NULL, sym_func);
+}
+
+
+/* Return TRUE when name is the name of an intrinsic type. */
+
+bool
+gfc_is_intrinsic_typename (const char *name)
+{
+ if (strcmp (name, "integer") == 0
+ || strcmp (name, "real") == 0
+ || strcmp (name, "character") == 0
+ || strcmp (name, "logical") == 0
+ || strcmp (name, "complex") == 0
+ || strcmp (name, "doubleprecision") == 0
+ || strcmp (name, "doublecomplex") == 0)
+ return true;
+ else
+ return false;
+}
+
+
+/* Return TRUE if the symbol is an automatic variable. */
+
+static bool
+gfc_is_var_automatic (gfc_symbol *sym)
+{
+ /* Pointer and allocatable variables are never automatic. */
+ if (sym->attr.pointer || sym->attr.allocatable)
+ return false;
+ /* Check for arrays with non-constant size. */
+ if (sym->attr.dimension && sym->as
+ && !gfc_is_compile_time_shape (sym->as))
+ return true;
+ /* Check for non-constant length character variables. */
+ if (sym->ts.type == BT_CHARACTER
+ && sym->ts.u.cl
+ && !gfc_is_constant_expr (sym->ts.u.cl->length))
+ return true;
+ /* Variables with explicit AUTOMATIC attribute. */
+ if (sym->attr.automatic)
+ return true;
+
+ return false;
+}
+
+/* Given a symbol, mark it as SAVEd if it is allowed. */
+
+static void
+save_symbol (gfc_symbol *sym)
+{
+
+ if (sym->attr.use_assoc)
+ return;
+
+ if (sym->attr.in_common
+ || sym->attr.in_equivalence
+ || sym->attr.dummy
+ || sym->attr.result
+ || sym->attr.flavor != FL_VARIABLE)
+ return;
+ /* Automatic objects are not saved. */
+ if (gfc_is_var_automatic (sym))
+ return;
+ gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
+}
+
+
+/* Mark those symbols which can be SAVEd as such. */
+
+void
+gfc_save_all (gfc_namespace *ns)
+{
+ gfc_traverse_ns (ns, save_symbol);
+}
+
+
+/* Make sure that no changes to symbols are pending. */
+
+void
+gfc_enforce_clean_symbol_state(void)
+{
+ enforce_single_undo_checkpoint ();
+ gcc_assert (latest_undo_chgset->syms.is_empty ());
+}
+
+
+/************** Global symbol handling ************/
+
+
+/* Search a tree for the global symbol. */
+
+gfc_gsymbol *
+gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
+{
+ int c;
+
+ if (symbol == NULL)
+ return NULL;
+
+ while (symbol)
+ {
+ c = strcmp (name, symbol->name);
+ if (!c)
+ return symbol;
+
+ symbol = (c < 0) ? symbol->left : symbol->right;
+ }
+
+ return NULL;
+}
+
+
+/* Case insensitive search a tree for the global symbol. */
+
+gfc_gsymbol *
+gfc_find_case_gsymbol (gfc_gsymbol *symbol, const char *name)
+{
+ int c;
+
+ if (symbol == NULL)
+ return NULL;
+
+ while (symbol)
+ {
+ c = strcasecmp (name, symbol->name);
+ if (!c)
+ return symbol;
+
+ symbol = (c < 0) ? symbol->left : symbol->right;
+ }
+
+ return NULL;
+}
+
+
+/* Compare two global symbols. Used for managing the BB tree. */
+
+static int
+gsym_compare (void *_s1, void *_s2)
+{
+ gfc_gsymbol *s1, *s2;
+
+ s1 = (gfc_gsymbol *) _s1;
+ s2 = (gfc_gsymbol *) _s2;
+ return strcmp (s1->name, s2->name);
+}
+
+
+/* Get a global symbol, creating it if it doesn't exist. */
+
+gfc_gsymbol *
+gfc_get_gsymbol (const char *name, bool bind_c)
+{
+ gfc_gsymbol *s;
+
+ s = gfc_find_gsymbol (gfc_gsym_root, name);
+ if (s != NULL)
+ return s;
+
+ s = XCNEW (gfc_gsymbol);
+ s->type = GSYM_UNKNOWN;
+ s->name = gfc_get_string ("%s", name);
+ s->bind_c = bind_c;
+
+ gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
+
+ return s;
+}
+
+void
+gfc_traverse_gsymbol (gfc_gsymbol *gsym,
+ void (*do_something) (gfc_gsymbol *, void *),
+ void *data)
+{
+ if (gsym->left)
+ gfc_traverse_gsymbol (gsym->left, do_something, data);
+
+ (*do_something) (gsym, data);
+
+ if (gsym->right)
+ gfc_traverse_gsymbol (gsym->right, do_something, data);
+}
+
+static gfc_symbol *
+get_iso_c_binding_dt (int sym_id)
+{
+ gfc_symbol *dt_list = gfc_derived_types;
+
+ /* Loop through the derived types in the name list, searching for
+ the desired symbol from iso_c_binding. Search the parent namespaces
+ if necessary and requested to (parent_flag). */
+ if (dt_list)
+ {
+ while (dt_list->dt_next != gfc_derived_types)
+ {
+ if (dt_list->from_intmod != INTMOD_NONE
+ && dt_list->intmod_sym_id == sym_id)
+ return dt_list;
+
+ dt_list = dt_list->dt_next;
+ }
+ }
+
+ return NULL;
+}
+
+
+/* Verifies that the given derived type symbol, derived_sym, is interoperable
+ with C. This is necessary for any derived type that is BIND(C) and for
+ derived types that are parameters to functions that are BIND(C). All
+ fields of the derived type are required to be interoperable, and are tested
+ for such. If an error occurs, the errors are reported here, allowing for
+ multiple errors to be handled for a single derived type. */
+
+bool
+verify_bind_c_derived_type (gfc_symbol *derived_sym)
+{
+ gfc_component *curr_comp = NULL;
+ bool is_c_interop = false;
+ bool retval = true;
+
+ if (derived_sym == NULL)
+ gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
+ "unexpectedly NULL");
+
+ /* If we've already looked at this derived symbol, do not look at it again
+ so we don't repeat warnings/errors. */
+ if (derived_sym->ts.is_c_interop)
+ return true;
+
+ /* The derived type must have the BIND attribute to be interoperable
+ J3/04-007, Section 15.2.3. */
+ if (derived_sym->attr.is_bind_c != 1)
+ {
+ derived_sym->ts.is_c_interop = 0;
+ gfc_error_now ("Derived type %qs declared at %L must have the BIND "
+ "attribute to be C interoperable", derived_sym->name,
+ &(derived_sym->declared_at));
+ retval = false;
+ }
+
+ curr_comp = derived_sym->components;
+
+ /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
+ empty struct. Section 15.2 in Fortran 2003 states: "The following
+ subclauses define the conditions under which a Fortran entity is
+ interoperable. If a Fortran entity is interoperable, an equivalent
+ entity may be defined by means of C and the Fortran entity is said
+ to be interoperable with the C entity. There does not have to be such
+ an interoperating C entity."
+ */
+ if (curr_comp == NULL)
+ {
+ gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, "
+ "and may be inaccessible by the C companion processor",
+ derived_sym->name, &(derived_sym->declared_at));
+ derived_sym->ts.is_c_interop = 1;
+ derived_sym->attr.is_bind_c = 1;
+ return true;
+ }
+
+
+ /* Initialize the derived type as being C interoperable.
+ If we find an error in the components, this will be set false. */
+ derived_sym->ts.is_c_interop = 1;
+
+ /* Loop through the list of components to verify that the kind of
+ each is a C interoperable type. */
+ do
+ {
+ /* The components cannot be pointers (fortran sense).
+ J3/04-007, Section 15.2.3, C1505. */
+ if (curr_comp->attr.pointer != 0)
+ {
+ gfc_error ("Component %qs at %L cannot have the "
+ "POINTER attribute because it is a member "
+ "of the BIND(C) derived type %qs at %L",
+ curr_comp->name, &(curr_comp->loc),
+ derived_sym->name, &(derived_sym->declared_at));
+ retval = false;
+ }
+
+ if (curr_comp->attr.proc_pointer != 0)
+ {
+ gfc_error ("Procedure pointer component %qs at %L cannot be a member"
+ " of the BIND(C) derived type %qs at %L", curr_comp->name,
+ &curr_comp->loc, derived_sym->name,
+ &derived_sym->declared_at);
+ retval = false;
+ }
+
+ /* The components cannot be allocatable.
+ J3/04-007, Section 15.2.3, C1505. */
+ if (curr_comp->attr.allocatable != 0)
+ {
+ gfc_error ("Component %qs at %L cannot have the "
+ "ALLOCATABLE attribute because it is a member "
+ "of the BIND(C) derived type %qs at %L",
+ curr_comp->name, &(curr_comp->loc),
+ derived_sym->name, &(derived_sym->declared_at));
+ retval = false;
+ }
+
+ /* BIND(C) derived types must have interoperable components. */
+ if (curr_comp->ts.type == BT_DERIVED
+ && curr_comp->ts.u.derived->ts.is_iso_c != 1
+ && curr_comp->ts.u.derived != derived_sym)
+ {
+ /* This should be allowed; the draft says a derived-type cannot
+ have type parameters if it is has the BIND attribute. Type
+ parameters seem to be for making parameterized derived types.
+ There's no need to verify the type if it is c_ptr/c_funptr. */
+ retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
+ }
+ else
+ {
+ /* Grab the typespec for the given component and test the kind. */
+ is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
+
+ if (!is_c_interop)
+ {
+ /* Report warning and continue since not fatal. The
+ draft does specify a constraint that requires all fields
+ to interoperate, but if the user says real(4), etc., it
+ may interoperate with *something* in C, but the compiler
+ most likely won't know exactly what. Further, it may not
+ interoperate with the same data type(s) in C if the user
+ recompiles with different flags (e.g., -m32 and -m64 on
+ x86_64 and using integer(4) to claim interop with a
+ C_LONG). */
+ if (derived_sym->attr.is_bind_c == 1 && warn_c_binding_type)
+ /* If the derived type is bind(c), all fields must be
+ interop. */
+ gfc_warning (OPT_Wc_binding_type,
+ "Component %qs in derived type %qs at %L "
+ "may not be C interoperable, even though "
+ "derived type %qs is BIND(C)",
+ curr_comp->name, derived_sym->name,
+ &(curr_comp->loc), derived_sym->name);
+ else if (warn_c_binding_type)
+ /* If derived type is param to bind(c) routine, or to one
+ of the iso_c_binding procs, it must be interoperable, so
+ all fields must interop too. */
+ gfc_warning (OPT_Wc_binding_type,
+ "Component %qs in derived type %qs at %L "
+ "may not be C interoperable",
+ curr_comp->name, derived_sym->name,
+ &(curr_comp->loc));
+ }
+ }
+
+ curr_comp = curr_comp->next;
+ } while (curr_comp != NULL);
+
+ if (derived_sym->attr.sequence != 0)
+ {
+ gfc_error ("Derived type %qs at %L cannot have the SEQUENCE "
+ "attribute because it is BIND(C)", derived_sym->name,
+ &(derived_sym->declared_at));
+ retval = false;
+ }
+
+ /* Mark the derived type as not being C interoperable if we found an
+ error. If there were only warnings, proceed with the assumption
+ it's interoperable. */
+ if (!retval)
+ derived_sym->ts.is_c_interop = 0;
+
+ return retval;
+}
+
+
+/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
+
+static bool
+gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree)
+{
+ gfc_constructor *c;
+
+ gcc_assert (tmp_sym && dt_symtree && dt_symtree->n.sym);
+ dt_symtree->n.sym->attr.referenced = 1;
+
+ tmp_sym->attr.is_c_interop = 1;
+ tmp_sym->attr.is_bind_c = 1;
+ tmp_sym->ts.is_c_interop = 1;
+ tmp_sym->ts.is_iso_c = 1;
+ tmp_sym->ts.type = BT_DERIVED;
+ tmp_sym->ts.f90_type = BT_VOID;
+ tmp_sym->attr.flavor = FL_PARAMETER;
+ tmp_sym->ts.u.derived = dt_symtree->n.sym;
+
+ /* Set the c_address field of c_null_ptr and c_null_funptr to
+ the value of NULL. */
+ tmp_sym->value = gfc_get_expr ();
+ tmp_sym->value->expr_type = EXPR_STRUCTURE;
+ tmp_sym->value->ts.type = BT_DERIVED;
+ tmp_sym->value->ts.f90_type = BT_VOID;
+ tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
+ gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
+ c = gfc_constructor_first (tmp_sym->value->value.constructor);
+ c->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ c->expr->ts.is_iso_c = 1;
+
+ return true;
+}
+
+
+/* Add a formal argument, gfc_formal_arglist, to the
+ end of the given list of arguments. Set the reference to the
+ provided symbol, param_sym, in the argument. */
+
+static void
+add_formal_arg (gfc_formal_arglist **head,
+ gfc_formal_arglist **tail,
+ gfc_formal_arglist *formal_arg,
+ gfc_symbol *param_sym)
+{
+ /* Put in list, either as first arg or at the tail (curr arg). */
+ if (*head == NULL)
+ *head = *tail = formal_arg;
+ else
+ {
+ (*tail)->next = formal_arg;
+ (*tail) = formal_arg;
+ }
+
+ (*tail)->sym = param_sym;
+ (*tail)->next = NULL;
+
+ return;
+}
+
+
+/* Add a procedure interface to the given symbol (i.e., store a
+ reference to the list of formal arguments). */
+
+static void
+add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
+{
+
+ sym->formal = formal;
+ sym->attr.if_source = source;
+}
+
+
+/* Copy the formal args from an existing symbol, src, into a new
+ symbol, dest. New formal args are created, and the description of
+ each arg is set according to the existing ones. This function is
+ used when creating procedure declaration variables from a procedure
+ declaration statement (see match_proc_decl()) to create the formal
+ args based on the args of a given named interface.
+
+ When an actual argument list is provided, skip the absent arguments
+ unless copy_type is true.
+ To be used together with gfc_se->ignore_optional. */
+
+void
+gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
+ gfc_actual_arglist *actual, bool copy_type)
+{
+ gfc_formal_arglist *head = NULL;
+ gfc_formal_arglist *tail = NULL;
+ gfc_formal_arglist *formal_arg = NULL;
+ gfc_intrinsic_arg *curr_arg = NULL;
+ gfc_formal_arglist *formal_prev = NULL;
+ gfc_actual_arglist *act_arg = actual;
+ /* Save current namespace so we can change it for formal args. */
+ gfc_namespace *parent_ns = gfc_current_ns;
+
+ /* Create a new namespace, which will be the formal ns (namespace
+ of the formal args). */
+ gfc_current_ns = gfc_get_namespace (parent_ns, 0);
+ gfc_current_ns->proc_name = dest;
+
+ for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+ {
+ /* Skip absent arguments. */
+ if (actual)
+ {
+ gcc_assert (act_arg != NULL);
+ if (act_arg->expr == NULL)
+ {
+ act_arg = act_arg->next;
+ continue;
+ }
+ }
+ formal_arg = gfc_get_formal_arglist ();
+ gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
+
+ /* May need to copy more info for the symbol. */
+ if (copy_type && act_arg->expr != NULL)
+ {
+ formal_arg->sym->ts = act_arg->expr->ts;
+ if (act_arg->expr->rank > 0)
+ {
+ formal_arg->sym->attr.dimension = 1;
+ formal_arg->sym->as = gfc_get_array_spec();
+ formal_arg->sym->as->rank = -1;
+ formal_arg->sym->as->type = AS_ASSUMED_RANK;
+ }
+ if (act_arg->name && strcmp (act_arg->name, "%VAL") == 0)
+ formal_arg->sym->pass_as_value = 1;
+ }
+ else
+ formal_arg->sym->ts = curr_arg->ts;
+
+ formal_arg->sym->attr.optional = curr_arg->optional;
+ formal_arg->sym->attr.value = curr_arg->value;
+ formal_arg->sym->attr.intent = curr_arg->intent;
+ formal_arg->sym->attr.flavor = FL_VARIABLE;
+ formal_arg->sym->attr.dummy = 1;
+
+ if (formal_arg->sym->ts.type == BT_CHARACTER)
+ formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+
+ /* If this isn't the first arg, set up the next ptr. For the
+ last arg built, the formal_arg->next will never get set to
+ anything other than NULL. */
+ if (formal_prev != NULL)
+ formal_prev->next = formal_arg;
+ else
+ formal_arg->next = NULL;
+
+ formal_prev = formal_arg;
+
+ /* Add arg to list of formal args. */
+ add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+
+ /* Validate changes. */
+ gfc_commit_symbol (formal_arg->sym);
+ if (actual)
+ act_arg = act_arg->next;
+ }
+
+ /* Add the interface to the symbol. */
+ add_proc_interface (dest, IFSRC_DECL, head);
+
+ /* Store the formal namespace information. */
+ if (dest->formal != NULL)
+ /* The current ns should be that for the dest proc. */
+ dest->formal_ns = gfc_current_ns;
+ /* Restore the current namespace to what it was on entry. */
+ gfc_current_ns = parent_ns;
+}
+
+
+static int
+std_for_isocbinding_symbol (int id)
+{
+ switch (id)
+ {
+#define NAMED_INTCST(a,b,c,d) \
+ case a:\
+ return d;
+#include "iso-c-binding.def"
+#undef NAMED_INTCST
+
+#define NAMED_FUNCTION(a,b,c,d) \
+ case a:\
+ return d;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+ case a:\
+ return d;
+#include "iso-c-binding.def"
+#undef NAMED_FUNCTION
+#undef NAMED_SUBROUTINE
+
+ default:
+ return GFC_STD_F2003;
+ }
+}
+
+/* Generate the given set of C interoperable kind objects, or all
+ interoperable kinds. This function will only be given kind objects
+ for valid iso_c_binding defined types because this is verified when
+ the 'use' statement is parsed. If the user gives an 'only' clause,
+ the specific kinds are looked up; if they don't exist, an error is
+ reported. If the user does not give an 'only' clause, all
+ iso_c_binding symbols are generated. If a list of specific kinds
+ is given, it must have a NULL in the first empty spot to mark the
+ end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
+ point to the symtree for c_(fun)ptr. */
+
+gfc_symtree *
+generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
+ const char *local_name, gfc_symtree *dt_symtree,
+ bool hidden)
+{
+ const char *const name = (local_name && local_name[0])
+ ? local_name : c_interop_kinds_table[s].name;
+ gfc_symtree *tmp_symtree;
+ gfc_symbol *tmp_sym = NULL;
+ int index;
+
+ if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
+ return NULL;
+
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ if (hidden
+ && (!tmp_symtree || !tmp_symtree->n.sym
+ || tmp_symtree->n.sym->from_intmod != INTMOD_ISO_C_BINDING
+ || tmp_symtree->n.sym->intmod_sym_id != s))
+ tmp_symtree = NULL;
+
+ /* Already exists in this scope so don't re-add it. */
+ if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
+ && (!tmp_sym->attr.generic
+ || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
+ && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
+ {
+ if (tmp_sym->attr.flavor == FL_DERIVED
+ && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
+ {
+ if (gfc_derived_types)
+ {
+ tmp_sym->dt_next = gfc_derived_types->dt_next;
+ gfc_derived_types->dt_next = tmp_sym;
+ }
+ else
+ {
+ tmp_sym->dt_next = tmp_sym;
+ }
+ gfc_derived_types = tmp_sym;
+ }
+
+ return tmp_symtree;
+ }
+
+ /* Create the sym tree in the current ns. */
+ if (hidden)
+ {
+ tmp_symtree = gfc_get_unique_symtree (gfc_current_ns);
+ tmp_sym = gfc_new_symbol (name, gfc_current_ns);
+
+ /* Add to the list of tentative symbols. */
+ latest_undo_chgset->syms.safe_push (tmp_sym);
+ tmp_sym->old_symbol = NULL;
+ tmp_sym->mark = 1;
+ tmp_sym->gfc_new = 1;
+
+ tmp_symtree->n.sym = tmp_sym;
+ tmp_sym->refs++;
+ }
+ else
+ {
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
+ gcc_assert (tmp_symtree);
+ tmp_sym = tmp_symtree->n.sym;
+ }
+
+ /* Say what module this symbol belongs to. */
+ tmp_sym->module = gfc_get_string ("%s", mod_name);
+ tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
+ tmp_sym->intmod_sym_id = s;
+ tmp_sym->attr.is_iso_c = 1;
+ tmp_sym->attr.use_assoc = 1;
+
+ gcc_assert (dt_symtree == NULL || s == ISOCBINDING_NULL_FUNPTR
+ || s == ISOCBINDING_NULL_PTR);
+
+ switch (s)
+ {
+
+#define NAMED_INTCST(a,b,c,d) case a :
+#define NAMED_REALCST(a,b,c,d) case a :
+#define NAMED_CMPXCST(a,b,c,d) case a :
+#define NAMED_LOGCST(a,b,c) case a :
+#define NAMED_CHARKNDCST(a,b,c) case a :
+#include "iso-c-binding.def"
+
+ tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ c_interop_kinds_table[s].value);
+
+ /* Initialize an integer constant expression node. */
+ tmp_sym->attr.flavor = FL_PARAMETER;
+ tmp_sym->ts.type = BT_INTEGER;
+ tmp_sym->ts.kind = gfc_default_integer_kind;
+
+ /* Mark this type as a C interoperable one. */
+ tmp_sym->ts.is_c_interop = 1;
+ tmp_sym->ts.is_iso_c = 1;
+ tmp_sym->value->ts.is_c_interop = 1;
+ tmp_sym->value->ts.is_iso_c = 1;
+ tmp_sym->attr.is_c_interop = 1;
+
+ /* Tell what f90 type this c interop kind is valid. */
+ tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
+
+ break;
+
+
+#define NAMED_CHARCST(a,b,c) case a :
+#include "iso-c-binding.def"
+
+ /* Initialize an integer constant expression node for the
+ length of the character. */
+ tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
+ &gfc_current_locus, NULL, 1);
+ tmp_sym->value->ts.is_c_interop = 1;
+ tmp_sym->value->ts.is_iso_c = 1;
+ tmp_sym->value->value.character.length = 1;
+ tmp_sym->value->value.character.string[0]
+ = (gfc_char_t) c_interop_kinds_table[s].value;
+ tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+ tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
+ NULL, 1);
+
+ /* May not need this in both attr and ts, but do need in
+ attr for writing module file. */
+ tmp_sym->attr.is_c_interop = 1;
+
+ tmp_sym->attr.flavor = FL_PARAMETER;
+ tmp_sym->ts.type = BT_CHARACTER;
+
+ /* Need to set it to the C_CHAR kind. */
+ tmp_sym->ts.kind = gfc_default_character_kind;
+
+ /* Mark this type as a C interoperable one. */
+ tmp_sym->ts.is_c_interop = 1;
+ tmp_sym->ts.is_iso_c = 1;
+
+ /* Tell what f90 type this c interop kind is valid. */
+ tmp_sym->ts.f90_type = BT_CHARACTER;
+
+ break;
+
+ case ISOCBINDING_PTR:
+ case ISOCBINDING_FUNPTR:
+ {
+ gfc_symbol *dt_sym;
+ gfc_component *tmp_comp = NULL;
+
+ /* Generate real derived type. */
+ if (hidden)
+ dt_sym = tmp_sym;
+ else
+ {
+ const char *hidden_name;
+ gfc_interface *intr, *head;
+
+ hidden_name = gfc_dt_upper_string (tmp_sym->name);
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
+ hidden_name);
+ gcc_assert (tmp_symtree == NULL);
+ gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
+ dt_sym = tmp_symtree->n.sym;
+ dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR
+ ? "c_ptr" : "c_funptr");
+
+ /* Generate an artificial generic function. */
+ head = tmp_sym->generic;
+ intr = gfc_get_interface ();
+ intr->sym = dt_sym;
+ intr->where = gfc_current_locus;
+ intr->next = head;
+ tmp_sym->generic = intr;
+
+ if (!tmp_sym->attr.generic
+ && !gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL))
+ return NULL;
+
+ if (!tmp_sym->attr.function
+ && !gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL))
+ return NULL;
+ }
+
+ /* Say what module this symbol belongs to. */
+ dt_sym->module = gfc_get_string ("%s", mod_name);
+ dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
+ dt_sym->intmod_sym_id = s;
+ dt_sym->attr.use_assoc = 1;
+
+ /* Initialize an integer constant expression node. */
+ dt_sym->attr.flavor = FL_DERIVED;
+ dt_sym->ts.is_c_interop = 1;
+ dt_sym->attr.is_c_interop = 1;
+ dt_sym->attr.private_comp = 1;
+ dt_sym->component_access = ACCESS_PRIVATE;
+ dt_sym->ts.is_iso_c = 1;
+ dt_sym->ts.type = BT_DERIVED;
+ dt_sym->ts.f90_type = BT_VOID;
+
+ /* A derived type must have the bind attribute to be
+ interoperable (J3/04-007, Section 15.2.3), even though
+ the binding label is not used. */
+ dt_sym->attr.is_bind_c = 1;
+
+ dt_sym->attr.referenced = 1;
+ dt_sym->ts.u.derived = dt_sym;
+
+ /* Add the symbol created for the derived type to the current ns. */
+ if (gfc_derived_types)
+ {
+ dt_sym->dt_next = gfc_derived_types->dt_next;
+ gfc_derived_types->dt_next = dt_sym;
+ }
+ else
+ {
+ dt_sym->dt_next = dt_sym;
+ }
+ gfc_derived_types = dt_sym;
+
+ gfc_add_component (dt_sym, "c_address", &tmp_comp);
+ if (tmp_comp == NULL)
+ gcc_unreachable ();
+
+ tmp_comp->ts.type = BT_INTEGER;
+
+ /* Set this because the module will need to read/write this field. */
+ tmp_comp->ts.f90_type = BT_INTEGER;
+
+ /* The kinds for c_ptr and c_funptr are the same. */
+ index = get_c_kind ("c_ptr", c_interop_kinds_table);
+ tmp_comp->ts.kind = c_interop_kinds_table[index].value;
+ tmp_comp->attr.access = ACCESS_PRIVATE;
+
+ /* Mark the component as C interoperable. */
+ tmp_comp->ts.is_c_interop = 1;
+ }
+
+ break;
+
+ case ISOCBINDING_NULL_PTR:
+ case ISOCBINDING_NULL_FUNPTR:
+ gen_special_c_interop_ptr (tmp_sym, dt_symtree);
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+ gfc_commit_symbol (tmp_sym);
+ return tmp_symtree;
+}
+
+
+/* Check that a symbol is already typed. If strict is not set, an untyped
+ symbol is acceptable for non-standard-conforming mode. */
+
+bool
+gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
+ bool strict, locus where)
+{
+ gcc_assert (sym);
+
+ if (gfc_matching_prefix)
+ return true;
+
+ /* Check for the type and try to give it an implicit one. */
+ if (sym->ts.type == BT_UNKNOWN
+ && !gfc_set_default_type (sym, 0, ns))
+ {
+ if (strict)
+ {
+ gfc_error ("Symbol %qs is used before it is typed at %L",
+ sym->name, &where);
+ return false;
+ }
+
+ if (!gfc_notify_std (GFC_STD_GNU, "Symbol %qs is used before"
+ " it is typed at %L", sym->name, &where))
+ return false;
+ }
+
+ /* Everything is ok. */
+ return true;
+}
+
+
+/* Construct a typebound-procedure structure. Those are stored in a tentative
+ list and marked `error' until symbols are committed. */
+
+gfc_typebound_proc*
+gfc_get_typebound_proc (gfc_typebound_proc *tb0)
+{
+ gfc_typebound_proc *result;
+
+ result = XCNEW (gfc_typebound_proc);
+ if (tb0)
+ *result = *tb0;
+ result->error = 1;
+
+ latest_undo_chgset->tbps.safe_push (result);
+
+ return result;
+}
+
+
+/* Get the super-type of a given derived type. */
+
+gfc_symbol*
+gfc_get_derived_super_type (gfc_symbol* derived)
+{
+ gcc_assert (derived);
+
+ if (derived->attr.generic)
+ derived = gfc_find_dt_in_generic (derived);
+
+ if (!derived->attr.extension)
+ return NULL;
+
+ gcc_assert (derived->components);
+ gcc_assert (derived->components->ts.type == BT_DERIVED);
+ gcc_assert (derived->components->ts.u.derived);
+
+ if (derived->components->ts.u.derived->attr.generic)
+ return gfc_find_dt_in_generic (derived->components->ts.u.derived);
+
+ return derived->components->ts.u.derived;
+}
+
+
+/* Check if a derived type t2 is an extension of (or equal to) a type t1. */
+
+bool
+gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
+{
+ while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
+ t2 = gfc_get_derived_super_type (t2);
+ return gfc_compare_derived_types (t1, t2);
+}
+
+
+/* Check if two typespecs are type compatible (F03:5.1.1.2):
+ If ts1 is nonpolymorphic, ts2 must be the same type.
+ If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
+
+bool
+gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
+{
+ bool is_class1 = (ts1->type == BT_CLASS);
+ bool is_class2 = (ts2->type == BT_CLASS);
+ bool is_derived1 = (ts1->type == BT_DERIVED);
+ bool is_derived2 = (ts2->type == BT_DERIVED);
+ bool is_union1 = (ts1->type == BT_UNION);
+ bool is_union2 = (ts2->type == BT_UNION);
+
+ if (is_class1
+ && ts1->u.derived->components
+ && ((ts1->u.derived->attr.is_class
+ && ts1->u.derived->components->ts.u.derived->attr
+ .unlimited_polymorphic)
+ || ts1->u.derived->attr.unlimited_polymorphic))
+ return 1;
+
+ if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2
+ && !is_union1 && !is_union2)
+ return (ts1->type == ts2->type);
+
+ if ((is_derived1 && is_derived2) || (is_union1 && is_union2))
+ return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
+
+ if (is_derived1 && is_class2)
+ return gfc_compare_derived_types (ts1->u.derived,
+ ts2->u.derived->attr.is_class ?
+ ts2->u.derived->components->ts.u.derived
+ : ts2->u.derived);
+ if (is_class1 && is_derived2)
+ return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ?
+ ts1->u.derived->components->ts.u.derived
+ : ts1->u.derived,
+ ts2->u.derived);
+ else if (is_class1 && is_class2)
+ return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ?
+ ts1->u.derived->components->ts.u.derived
+ : ts1->u.derived,
+ ts2->u.derived->attr.is_class ?
+ ts2->u.derived->components->ts.u.derived
+ : ts2->u.derived);
+ else
+ return 0;
+}
+
+
+/* Find the parent-namespace of the current function. If we're inside
+ BLOCK constructs, it may not be the current one. */
+
+gfc_namespace*
+gfc_find_proc_namespace (gfc_namespace* ns)
+{
+ while (ns->construct_entities)
+ {
+ ns = ns->parent;
+ gcc_assert (ns);
+ }
+
+ return ns;
+}
+
+
+/* Check if an associate-variable should be translated as an `implicit' pointer
+ internally (if it is associated to a variable and not an array with
+ descriptor). */
+
+bool
+gfc_is_associate_pointer (gfc_symbol* sym)
+{
+ if (!sym->assoc)
+ return false;
+
+ if (sym->ts.type == BT_CLASS)
+ return true;
+
+ if (sym->ts.type == BT_CHARACTER
+ && sym->ts.deferred
+ && sym->assoc->target
+ && sym->assoc->target->expr_type == EXPR_FUNCTION)
+ return true;
+
+ if (!sym->assoc->variable)
+ return false;
+
+ if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
+ return false;
+
+ return true;
+}
+
+
+gfc_symbol *
+gfc_find_dt_in_generic (gfc_symbol *sym)
+{
+ gfc_interface *intr = NULL;
+
+ if (!sym || gfc_fl_struct (sym->attr.flavor))
+ return sym;
+
+ if (sym->attr.generic)
+ for (intr = sym->generic; intr; intr = intr->next)
+ if (gfc_fl_struct (intr->sym->attr.flavor))
+ break;
+ return intr ? intr->sym : NULL;
+}
+
+
+/* Get the dummy arguments from a procedure symbol. If it has been declared
+ via a PROCEDURE statement with a named interface, ts.interface will be set
+ and the arguments need to be taken from there. */
+
+gfc_formal_arglist *
+gfc_sym_get_dummy_args (gfc_symbol *sym)
+{
+ gfc_formal_arglist *dummies;
+
+ if (sym == NULL)
+ return NULL;
+
+ dummies = sym->formal;
+ if (dummies == NULL && sym->ts.interface != NULL)
+ dummies = sym->ts.interface->formal;
+
+ return dummies;
+}
generated by cgit v1.1 at 2024-11-10 12:09:49 +0000