aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/check.c
diff options
context:
space:
mode:
authorMartin Liska <mliska@suse.cz>2022-01-14 16:56:44 +0100
committerMartin Liska <mliska@suse.cz>2022-01-17 22:12:04 +0100
commit5c69acb32329d49e58c26fa41ae74229a52b9106 (patch)
treeddb05f9d73afb6f998457d2ac4b720e3b3b60483 /gcc/fortran/check.c
parent490e23032baaece71f2ec09fa1805064b150fbc2 (diff)
downloadgcc-5c69acb32329d49e58c26fa41ae74229a52b9106.zip
gcc-5c69acb32329d49e58c26fa41ae74229a52b9106.tar.gz
gcc-5c69acb32329d49e58c26fa41ae74229a52b9106.tar.bz2
Rename .c files to .cc files.
gcc/ada/ChangeLog: * adadecode.c: Moved to... * adadecode.cc: ...here. * affinity.c: Moved to... * affinity.cc: ...here. * argv-lynxos178-raven-cert.c: Moved to... * argv-lynxos178-raven-cert.cc: ...here. * argv.c: Moved to... * argv.cc: ...here. * aux-io.c: Moved to... * aux-io.cc: ...here. * cio.c: Moved to... * cio.cc: ...here. * cstreams.c: Moved to... * cstreams.cc: ...here. * env.c: Moved to... * env.cc: ...here. * exit.c: Moved to... * exit.cc: ...here. * expect.c: Moved to... * expect.cc: ...here. * final.c: Moved to... * final.cc: ...here. * gcc-interface/cuintp.c: Moved to... * gcc-interface/cuintp.cc: ...here. * gcc-interface/decl.c: Moved to... * gcc-interface/decl.cc: ...here. * gcc-interface/misc.c: Moved to... * gcc-interface/misc.cc: ...here. * gcc-interface/targtyps.c: Moved to... * gcc-interface/targtyps.cc: ...here. * gcc-interface/trans.c: Moved to... * gcc-interface/trans.cc: ...here. * gcc-interface/utils.c: Moved to... * gcc-interface/utils.cc: ...here. * gcc-interface/utils2.c: Moved to... * gcc-interface/utils2.cc: ...here. * init.c: Moved to... * init.cc: ...here. * initialize.c: Moved to... * initialize.cc: ...here. * libgnarl/thread.c: Moved to... * libgnarl/thread.cc: ...here. * link.c: Moved to... * link.cc: ...here. * locales.c: Moved to... * locales.cc: ...here. * mkdir.c: Moved to... * mkdir.cc: ...here. * raise.c: Moved to... * raise.cc: ...here. * rtfinal.c: Moved to... * rtfinal.cc: ...here. * rtinit.c: Moved to... * rtinit.cc: ...here. * seh_init.c: Moved to... * seh_init.cc: ...here. * sigtramp-armdroid.c: Moved to... * sigtramp-armdroid.cc: ...here. * sigtramp-ios.c: Moved to... * sigtramp-ios.cc: ...here. * sigtramp-qnx.c: Moved to... * sigtramp-qnx.cc: ...here. * sigtramp-vxworks.c: Moved to... * sigtramp-vxworks.cc: ...here. * socket.c: Moved to... * socket.cc: ...here. * tracebak.c: Moved to... * tracebak.cc: ...here. * version.c: Moved to... * version.cc: ...here. * vx_stack_info.c: Moved to... * vx_stack_info.cc: ...here. gcc/ChangeLog: * adjust-alignment.c: Moved to... * adjust-alignment.cc: ...here. * alias.c: Moved to... * alias.cc: ...here. * alloc-pool.c: Moved to... * alloc-pool.cc: ...here. * asan.c: Moved to... * asan.cc: ...here. * attribs.c: Moved to... * attribs.cc: ...here. * auto-inc-dec.c: Moved to... * auto-inc-dec.cc: ...here. * auto-profile.c: Moved to... * auto-profile.cc: ...here. * bb-reorder.c: Moved to... * bb-reorder.cc: ...here. * bitmap.c: Moved to... * bitmap.cc: ...here. * btfout.c: Moved to... * btfout.cc: ...here. * builtins.c: Moved to... * builtins.cc: ...here. * caller-save.c: Moved to... * caller-save.cc: ...here. * calls.c: Moved to... * calls.cc: ...here. * ccmp.c: Moved to... * ccmp.cc: ...here. * cfg.c: Moved to... * cfg.cc: ...here. * cfganal.c: Moved to... * cfganal.cc: ...here. * cfgbuild.c: Moved to... * cfgbuild.cc: ...here. * cfgcleanup.c: Moved to... * cfgcleanup.cc: ...here. * cfgexpand.c: Moved to... * cfgexpand.cc: ...here. * cfghooks.c: Moved to... * cfghooks.cc: ...here. * cfgloop.c: Moved to... * cfgloop.cc: ...here. * cfgloopanal.c: Moved to... * cfgloopanal.cc: ...here. * cfgloopmanip.c: Moved to... * cfgloopmanip.cc: ...here. * cfgrtl.c: Moved to... * cfgrtl.cc: ...here. * cgraph.c: Moved to... * cgraph.cc: ...here. * cgraphbuild.c: Moved to... * cgraphbuild.cc: ...here. * cgraphclones.c: Moved to... * cgraphclones.cc: ...here. * cgraphunit.c: Moved to... * cgraphunit.cc: ...here. * collect-utils.c: Moved to... * collect-utils.cc: ...here. * collect2-aix.c: Moved to... * collect2-aix.cc: ...here. * collect2.c: Moved to... * collect2.cc: ...here. * combine-stack-adj.c: Moved to... * combine-stack-adj.cc: ...here. * combine.c: Moved to... * combine.cc: ...here. * common/common-targhooks.c: Moved to... * common/common-targhooks.cc: ...here. * common/config/aarch64/aarch64-common.c: Moved to... * common/config/aarch64/aarch64-common.cc: ...here. * common/config/alpha/alpha-common.c: Moved to... * common/config/alpha/alpha-common.cc: ...here. * common/config/arc/arc-common.c: Moved to... * common/config/arc/arc-common.cc: ...here. * common/config/arm/arm-common.c: Moved to... * common/config/arm/arm-common.cc: ...here. * common/config/avr/avr-common.c: Moved to... * common/config/avr/avr-common.cc: ...here. * common/config/bfin/bfin-common.c: Moved to... * common/config/bfin/bfin-common.cc: ...here. * common/config/bpf/bpf-common.c: Moved to... * common/config/bpf/bpf-common.cc: ...here. * common/config/c6x/c6x-common.c: Moved to... * common/config/c6x/c6x-common.cc: ...here. * common/config/cr16/cr16-common.c: Moved to... * common/config/cr16/cr16-common.cc: ...here. * common/config/cris/cris-common.c: Moved to... * common/config/cris/cris-common.cc: ...here. * common/config/csky/csky-common.c: Moved to... * common/config/csky/csky-common.cc: ...here. * common/config/default-common.c: Moved to... * common/config/default-common.cc: ...here. * common/config/epiphany/epiphany-common.c: Moved to... * common/config/epiphany/epiphany-common.cc: ...here. * common/config/fr30/fr30-common.c: Moved to... * common/config/fr30/fr30-common.cc: ...here. * common/config/frv/frv-common.c: Moved to... * common/config/frv/frv-common.cc: ...here. * common/config/gcn/gcn-common.c: Moved to... * common/config/gcn/gcn-common.cc: ...here. * common/config/h8300/h8300-common.c: Moved to... * common/config/h8300/h8300-common.cc: ...here. * common/config/i386/i386-common.c: Moved to... * common/config/i386/i386-common.cc: ...here. * common/config/ia64/ia64-common.c: Moved to... * common/config/ia64/ia64-common.cc: ...here. * common/config/iq2000/iq2000-common.c: Moved to... * common/config/iq2000/iq2000-common.cc: ...here. * common/config/lm32/lm32-common.c: Moved to... * common/config/lm32/lm32-common.cc: ...here. * common/config/m32r/m32r-common.c: Moved to... * common/config/m32r/m32r-common.cc: ...here. * common/config/m68k/m68k-common.c: Moved to... * common/config/m68k/m68k-common.cc: ...here. * common/config/mcore/mcore-common.c: Moved to... * common/config/mcore/mcore-common.cc: ...here. * common/config/microblaze/microblaze-common.c: Moved to... * common/config/microblaze/microblaze-common.cc: ...here. * common/config/mips/mips-common.c: Moved to... * common/config/mips/mips-common.cc: ...here. * common/config/mmix/mmix-common.c: Moved to... * common/config/mmix/mmix-common.cc: ...here. * common/config/mn10300/mn10300-common.c: Moved to... * common/config/mn10300/mn10300-common.cc: ...here. * common/config/msp430/msp430-common.c: Moved to... * common/config/msp430/msp430-common.cc: ...here. * common/config/nds32/nds32-common.c: Moved to... * common/config/nds32/nds32-common.cc: ...here. * common/config/nios2/nios2-common.c: Moved to... * common/config/nios2/nios2-common.cc: ...here. * common/config/nvptx/nvptx-common.c: Moved to... * common/config/nvptx/nvptx-common.cc: ...here. * common/config/or1k/or1k-common.c: Moved to... * common/config/or1k/or1k-common.cc: ...here. * common/config/pa/pa-common.c: Moved to... * common/config/pa/pa-common.cc: ...here. * common/config/pdp11/pdp11-common.c: Moved to... * common/config/pdp11/pdp11-common.cc: ...here. * common/config/pru/pru-common.c: Moved to... * common/config/pru/pru-common.cc: ...here. * common/config/riscv/riscv-common.c: Moved to... * common/config/riscv/riscv-common.cc: ...here. * common/config/rs6000/rs6000-common.c: Moved to... * common/config/rs6000/rs6000-common.cc: ...here. * common/config/rx/rx-common.c: Moved to... * common/config/rx/rx-common.cc: ...here. * common/config/s390/s390-common.c: Moved to... * common/config/s390/s390-common.cc: ...here. * common/config/sh/sh-common.c: Moved to... * common/config/sh/sh-common.cc: ...here. * common/config/sparc/sparc-common.c: Moved to... * common/config/sparc/sparc-common.cc: ...here. * common/config/tilegx/tilegx-common.c: Moved to... * common/config/tilegx/tilegx-common.cc: ...here. * common/config/tilepro/tilepro-common.c: Moved to... * common/config/tilepro/tilepro-common.cc: ...here. * common/config/v850/v850-common.c: Moved to... * common/config/v850/v850-common.cc: ...here. * common/config/vax/vax-common.c: Moved to... * common/config/vax/vax-common.cc: ...here. * common/config/visium/visium-common.c: Moved to... * common/config/visium/visium-common.cc: ...here. * common/config/xstormy16/xstormy16-common.c: Moved to... * common/config/xstormy16/xstormy16-common.cc: ...here. * common/config/xtensa/xtensa-common.c: Moved to... * common/config/xtensa/xtensa-common.cc: ...here. * compare-elim.c: Moved to... * compare-elim.cc: ...here. * config/aarch64/aarch64-bti-insert.c: Moved to... * config/aarch64/aarch64-bti-insert.cc: ...here. * config/aarch64/aarch64-builtins.c: Moved to... * config/aarch64/aarch64-builtins.cc: ...here. * config/aarch64/aarch64-c.c: Moved to... * config/aarch64/aarch64-c.cc: ...here. * config/aarch64/aarch64-d.c: Moved to... * config/aarch64/aarch64-d.cc: ...here. * config/aarch64/aarch64.c: Moved to... * config/aarch64/aarch64.cc: ...here. * config/aarch64/cortex-a57-fma-steering.c: Moved to... * config/aarch64/cortex-a57-fma-steering.cc: ...here. * config/aarch64/driver-aarch64.c: Moved to... * config/aarch64/driver-aarch64.cc: ...here. * config/aarch64/falkor-tag-collision-avoidance.c: Moved to... * config/aarch64/falkor-tag-collision-avoidance.cc: ...here. * config/aarch64/host-aarch64-darwin.c: Moved to... * config/aarch64/host-aarch64-darwin.cc: ...here. * config/alpha/alpha.c: Moved to... * config/alpha/alpha.cc: ...here. * config/alpha/driver-alpha.c: Moved to... * config/alpha/driver-alpha.cc: ...here. * config/arc/arc-c.c: Moved to... * config/arc/arc-c.cc: ...here. * config/arc/arc.c: Moved to... * config/arc/arc.cc: ...here. * config/arc/driver-arc.c: Moved to... * config/arc/driver-arc.cc: ...here. * config/arm/aarch-common.c: Moved to... * config/arm/aarch-common.cc: ...here. * config/arm/arm-builtins.c: Moved to... * config/arm/arm-builtins.cc: ...here. * config/arm/arm-c.c: Moved to... * config/arm/arm-c.cc: ...here. * config/arm/arm-d.c: Moved to... * config/arm/arm-d.cc: ...here. * config/arm/arm.c: Moved to... * config/arm/arm.cc: ...here. * config/arm/driver-arm.c: Moved to... * config/arm/driver-arm.cc: ...here. * config/avr/avr-c.c: Moved to... * config/avr/avr-c.cc: ...here. * config/avr/avr-devices.c: Moved to... * config/avr/avr-devices.cc: ...here. * config/avr/avr-log.c: Moved to... * config/avr/avr-log.cc: ...here. * config/avr/avr.c: Moved to... * config/avr/avr.cc: ...here. * config/avr/driver-avr.c: Moved to... * config/avr/driver-avr.cc: ...here. * config/avr/gen-avr-mmcu-specs.c: Moved to... * config/avr/gen-avr-mmcu-specs.cc: ...here. * config/avr/gen-avr-mmcu-texi.c: Moved to... * config/avr/gen-avr-mmcu-texi.cc: ...here. * config/bfin/bfin.c: Moved to... * config/bfin/bfin.cc: ...here. * config/bpf/bpf.c: Moved to... * config/bpf/bpf.cc: ...here. * config/bpf/coreout.c: Moved to... * config/bpf/coreout.cc: ...here. * config/c6x/c6x.c: Moved to... * config/c6x/c6x.cc: ...here. * config/cr16/cr16.c: Moved to... * config/cr16/cr16.cc: ...here. * config/cris/cris.c: Moved to... * config/cris/cris.cc: ...here. * config/csky/csky.c: Moved to... * config/csky/csky.cc: ...here. * config/darwin-c.c: Moved to... * config/darwin-c.cc: ...here. * config/darwin-d.c: Moved to... * config/darwin-d.cc: ...here. * config/darwin-driver.c: Moved to... * config/darwin-driver.cc: ...here. * config/darwin-f.c: Moved to... * config/darwin-f.cc: ...here. * config/darwin.c: Moved to... * config/darwin.cc: ...here. * config/default-c.c: Moved to... * config/default-c.cc: ...here. * config/default-d.c: Moved to... * config/default-d.cc: ...here. * config/dragonfly-d.c: Moved to... * config/dragonfly-d.cc: ...here. * config/epiphany/epiphany.c: Moved to... * config/epiphany/epiphany.cc: ...here. * config/epiphany/mode-switch-use.c: Moved to... * config/epiphany/mode-switch-use.cc: ...here. * config/epiphany/resolve-sw-modes.c: Moved to... * config/epiphany/resolve-sw-modes.cc: ...here. * config/fr30/fr30.c: Moved to... * config/fr30/fr30.cc: ...here. * config/freebsd-d.c: Moved to... * config/freebsd-d.cc: ...here. * config/frv/frv.c: Moved to... * config/frv/frv.cc: ...here. * config/ft32/ft32.c: Moved to... * config/ft32/ft32.cc: ...here. * config/gcn/driver-gcn.c: Moved to... * config/gcn/driver-gcn.cc: ...here. * config/gcn/gcn-run.c: Moved to... * config/gcn/gcn-run.cc: ...here. * config/gcn/gcn-tree.c: Moved to... * config/gcn/gcn-tree.cc: ...here. * config/gcn/gcn.c: Moved to... * config/gcn/gcn.cc: ...here. * config/gcn/mkoffload.c: Moved to... * config/gcn/mkoffload.cc: ...here. * config/glibc-c.c: Moved to... * config/glibc-c.cc: ...here. * config/glibc-d.c: Moved to... * config/glibc-d.cc: ...here. * config/h8300/h8300.c: Moved to... * config/h8300/h8300.cc: ...here. * config/host-darwin.c: Moved to... * config/host-darwin.cc: ...here. * config/host-hpux.c: Moved to... * config/host-hpux.cc: ...here. * config/host-linux.c: Moved to... * config/host-linux.cc: ...here. * config/host-netbsd.c: Moved to... * config/host-netbsd.cc: ...here. * config/host-openbsd.c: Moved to... * config/host-openbsd.cc: ...here. * config/host-solaris.c: Moved to... * config/host-solaris.cc: ...here. * config/i386/djgpp.c: Moved to... * config/i386/djgpp.cc: ...here. * config/i386/driver-i386.c: Moved to... * config/i386/driver-i386.cc: ...here. * config/i386/driver-mingw32.c: Moved to... * config/i386/driver-mingw32.cc: ...here. * config/i386/gnu-property.c: Moved to... * config/i386/gnu-property.cc: ...here. * config/i386/host-cygwin.c: Moved to... * config/i386/host-cygwin.cc: ...here. * config/i386/host-i386-darwin.c: Moved to... * config/i386/host-i386-darwin.cc: ...here. * config/i386/host-mingw32.c: Moved to... * config/i386/host-mingw32.cc: ...here. * config/i386/i386-builtins.c: Moved to... * config/i386/i386-builtins.cc: ...here. * config/i386/i386-c.c: Moved to... * config/i386/i386-c.cc: ...here. * config/i386/i386-d.c: Moved to... * config/i386/i386-d.cc: ...here. * config/i386/i386-expand.c: Moved to... * config/i386/i386-expand.cc: ...here. * config/i386/i386-features.c: Moved to... * config/i386/i386-features.cc: ...here. * config/i386/i386-options.c: Moved to... * config/i386/i386-options.cc: ...here. * config/i386/i386.c: Moved to... * config/i386/i386.cc: ...here. * config/i386/intelmic-mkoffload.c: Moved to... * config/i386/intelmic-mkoffload.cc: ...here. * config/i386/msformat-c.c: Moved to... * config/i386/msformat-c.cc: ...here. * config/i386/winnt-cxx.c: Moved to... * config/i386/winnt-cxx.cc: ...here. * config/i386/winnt-d.c: Moved to... * config/i386/winnt-d.cc: ...here. * config/i386/winnt-stubs.c: Moved to... * config/i386/winnt-stubs.cc: ...here. * config/i386/winnt.c: Moved to... * config/i386/winnt.cc: ...here. * config/i386/x86-tune-sched-atom.c: Moved to... * config/i386/x86-tune-sched-atom.cc: ...here. * config/i386/x86-tune-sched-bd.c: Moved to... * config/i386/x86-tune-sched-bd.cc: ...here. * config/i386/x86-tune-sched-core.c: Moved to... * config/i386/x86-tune-sched-core.cc: ...here. * config/i386/x86-tune-sched.c: Moved to... * config/i386/x86-tune-sched.cc: ...here. * config/ia64/ia64-c.c: Moved to... * config/ia64/ia64-c.cc: ...here. * config/ia64/ia64.c: Moved to... * config/ia64/ia64.cc: ...here. * config/iq2000/iq2000.c: Moved to... * config/iq2000/iq2000.cc: ...here. * config/linux.c: Moved to... * config/linux.cc: ...here. * config/lm32/lm32.c: Moved to... * config/lm32/lm32.cc: ...here. * config/m32c/m32c-pragma.c: Moved to... * config/m32c/m32c-pragma.cc: ...here. * config/m32c/m32c.c: Moved to... * config/m32c/m32c.cc: ...here. * config/m32r/m32r.c: Moved to... * config/m32r/m32r.cc: ...here. * config/m68k/m68k.c: Moved to... * config/m68k/m68k.cc: ...here. * config/mcore/mcore.c: Moved to... * config/mcore/mcore.cc: ...here. * config/microblaze/microblaze-c.c: Moved to... * config/microblaze/microblaze-c.cc: ...here. * config/microblaze/microblaze.c: Moved to... * config/microblaze/microblaze.cc: ...here. * config/mips/driver-native.c: Moved to... * config/mips/driver-native.cc: ...here. * config/mips/frame-header-opt.c: Moved to... * config/mips/frame-header-opt.cc: ...here. * config/mips/mips-d.c: Moved to... * config/mips/mips-d.cc: ...here. * config/mips/mips.c: Moved to... * config/mips/mips.cc: ...here. * config/mmix/mmix.c: Moved to... * config/mmix/mmix.cc: ...here. * config/mn10300/mn10300.c: Moved to... * config/mn10300/mn10300.cc: ...here. * config/moxie/moxie.c: Moved to... * config/moxie/moxie.cc: ...here. * config/msp430/driver-msp430.c: Moved to... * config/msp430/driver-msp430.cc: ...here. * config/msp430/msp430-c.c: Moved to... * config/msp430/msp430-c.cc: ...here. * config/msp430/msp430-devices.c: Moved to... * config/msp430/msp430-devices.cc: ...here. * config/msp430/msp430.c: Moved to... * config/msp430/msp430.cc: ...here. * config/nds32/nds32-cost.c: Moved to... * config/nds32/nds32-cost.cc: ...here. * config/nds32/nds32-fp-as-gp.c: Moved to... * config/nds32/nds32-fp-as-gp.cc: ...here. * config/nds32/nds32-intrinsic.c: Moved to... * config/nds32/nds32-intrinsic.cc: ...here. * config/nds32/nds32-isr.c: Moved to... * config/nds32/nds32-isr.cc: ...here. * config/nds32/nds32-md-auxiliary.c: Moved to... * config/nds32/nds32-md-auxiliary.cc: ...here. * config/nds32/nds32-memory-manipulation.c: Moved to... * config/nds32/nds32-memory-manipulation.cc: ...here. * config/nds32/nds32-pipelines-auxiliary.c: Moved to... * config/nds32/nds32-pipelines-auxiliary.cc: ...here. * config/nds32/nds32-predicates.c: Moved to... * config/nds32/nds32-predicates.cc: ...here. * config/nds32/nds32-relax-opt.c: Moved to... * config/nds32/nds32-relax-opt.cc: ...here. * config/nds32/nds32-utils.c: Moved to... * config/nds32/nds32-utils.cc: ...here. * config/nds32/nds32.c: Moved to... * config/nds32/nds32.cc: ...here. * config/netbsd-d.c: Moved to... * config/netbsd-d.cc: ...here. * config/netbsd.c: Moved to... * config/netbsd.cc: ...here. * config/nios2/nios2.c: Moved to... * config/nios2/nios2.cc: ...here. * config/nvptx/mkoffload.c: Moved to... * config/nvptx/mkoffload.cc: ...here. * config/nvptx/nvptx-c.c: Moved to... * config/nvptx/nvptx-c.cc: ...here. * config/nvptx/nvptx.c: Moved to... * config/nvptx/nvptx.cc: ...here. * config/openbsd-d.c: Moved to... * config/openbsd-d.cc: ...here. * config/or1k/or1k.c: Moved to... * config/or1k/or1k.cc: ...here. * config/pa/pa-d.c: Moved to... * config/pa/pa-d.cc: ...here. * config/pa/pa.c: Moved to... * config/pa/pa.cc: ...here. * config/pdp11/pdp11.c: Moved to... * config/pdp11/pdp11.cc: ...here. * config/pru/pru-passes.c: Moved to... * config/pru/pru-passes.cc: ...here. * config/pru/pru-pragma.c: Moved to... * config/pru/pru-pragma.cc: ...here. * config/pru/pru.c: Moved to... * config/pru/pru.cc: ...here. * config/riscv/riscv-builtins.c: Moved to... * config/riscv/riscv-builtins.cc: ...here. * config/riscv/riscv-c.c: Moved to... * config/riscv/riscv-c.cc: ...here. * config/riscv/riscv-d.c: Moved to... * config/riscv/riscv-d.cc: ...here. * config/riscv/riscv-shorten-memrefs.c: Moved to... * config/riscv/riscv-shorten-memrefs.cc: ...here. * config/riscv/riscv-sr.c: Moved to... * config/riscv/riscv-sr.cc: ...here. * config/riscv/riscv.c: Moved to... * config/riscv/riscv.cc: ...here. * config/rl78/rl78-c.c: Moved to... * config/rl78/rl78-c.cc: ...here. * config/rl78/rl78.c: Moved to... * config/rl78/rl78.cc: ...here. * config/rs6000/driver-rs6000.c: Moved to... * config/rs6000/driver-rs6000.cc: ...here. * config/rs6000/host-darwin.c: Moved to... * config/rs6000/host-darwin.cc: ...here. * config/rs6000/host-ppc64-darwin.c: Moved to... * config/rs6000/host-ppc64-darwin.cc: ...here. * config/rs6000/rbtree.c: Moved to... * config/rs6000/rbtree.cc: ...here. * config/rs6000/rs6000-c.c: Moved to... * config/rs6000/rs6000-c.cc: ...here. * config/rs6000/rs6000-call.c: Moved to... * config/rs6000/rs6000-call.cc: ...here. * config/rs6000/rs6000-d.c: Moved to... * config/rs6000/rs6000-d.cc: ...here. * config/rs6000/rs6000-gen-builtins.c: Moved to... * config/rs6000/rs6000-gen-builtins.cc: ...here. * config/rs6000/rs6000-linux.c: Moved to... * config/rs6000/rs6000-linux.cc: ...here. * config/rs6000/rs6000-logue.c: Moved to... * config/rs6000/rs6000-logue.cc: ...here. * config/rs6000/rs6000-p8swap.c: Moved to... * config/rs6000/rs6000-p8swap.cc: ...here. * config/rs6000/rs6000-pcrel-opt.c: Moved to... * config/rs6000/rs6000-pcrel-opt.cc: ...here. * config/rs6000/rs6000-string.c: Moved to... * config/rs6000/rs6000-string.cc: ...here. * config/rs6000/rs6000.c: Moved to... * config/rs6000/rs6000.cc: ...here. * config/rx/rx.c: Moved to... * config/rx/rx.cc: ...here. * config/s390/driver-native.c: Moved to... * config/s390/driver-native.cc: ...here. * config/s390/s390-c.c: Moved to... * config/s390/s390-c.cc: ...here. * config/s390/s390-d.c: Moved to... * config/s390/s390-d.cc: ...here. * config/s390/s390.c: Moved to... * config/s390/s390.cc: ...here. * config/sh/divtab-sh4-300.c: Moved to... * config/sh/divtab-sh4-300.cc: ...here. * config/sh/divtab-sh4.c: Moved to... * config/sh/divtab-sh4.cc: ...here. * config/sh/divtab.c: Moved to... * config/sh/divtab.cc: ...here. * config/sh/sh-c.c: Moved to... * config/sh/sh-c.cc: ...here. * config/sh/sh.c: Moved to... * config/sh/sh.cc: ...here. * config/sol2-c.c: Moved to... * config/sol2-c.cc: ...here. * config/sol2-cxx.c: Moved to... * config/sol2-cxx.cc: ...here. * config/sol2-d.c: Moved to... * config/sol2-d.cc: ...here. * config/sol2-stubs.c: Moved to... * config/sol2-stubs.cc: ...here. * config/sol2.c: Moved to... * config/sol2.cc: ...here. * config/sparc/driver-sparc.c: Moved to... * config/sparc/driver-sparc.cc: ...here. * config/sparc/sparc-c.c: Moved to... * config/sparc/sparc-c.cc: ...here. * config/sparc/sparc-d.c: Moved to... * config/sparc/sparc-d.cc: ...here. * config/sparc/sparc.c: Moved to... * config/sparc/sparc.cc: ...here. * config/stormy16/stormy16.c: Moved to... * config/stormy16/stormy16.cc: ...here. * config/tilegx/mul-tables.c: Moved to... * config/tilegx/mul-tables.cc: ...here. * config/tilegx/tilegx-c.c: Moved to... * config/tilegx/tilegx-c.cc: ...here. * config/tilegx/tilegx.c: Moved to... * config/tilegx/tilegx.cc: ...here. * config/tilepro/mul-tables.c: Moved to... * config/tilepro/mul-tables.cc: ...here. * config/tilepro/tilepro-c.c: Moved to... * config/tilepro/tilepro-c.cc: ...here. * config/tilepro/tilepro.c: Moved to... * config/tilepro/tilepro.cc: ...here. * config/v850/v850-c.c: Moved to... * config/v850/v850-c.cc: ...here. * config/v850/v850.c: Moved to... * config/v850/v850.cc: ...here. * config/vax/vax.c: Moved to... * config/vax/vax.cc: ...here. * config/visium/visium.c: Moved to... * config/visium/visium.cc: ...here. * config/vms/vms-c.c: Moved to... * config/vms/vms-c.cc: ...here. * config/vms/vms-f.c: Moved to... * config/vms/vms-f.cc: ...here. * config/vms/vms.c: Moved to... * config/vms/vms.cc: ...here. * config/vxworks-c.c: Moved to... * config/vxworks-c.cc: ...here. * config/vxworks.c: Moved to... * config/vxworks.cc: ...here. * config/winnt-c.c: Moved to... * config/winnt-c.cc: ...here. * config/xtensa/xtensa.c: Moved to... * config/xtensa/xtensa.cc: ...here. * context.c: Moved to... * context.cc: ...here. * convert.c: Moved to... * convert.cc: ...here. * coverage.c: Moved to... * coverage.cc: ...here. * cppbuiltin.c: Moved to... * cppbuiltin.cc: ...here. * cppdefault.c: Moved to... * cppdefault.cc: ...here. * cprop.c: Moved to... * cprop.cc: ...here. * cse.c: Moved to... * cse.cc: ...here. * cselib.c: Moved to... * cselib.cc: ...here. * ctfc.c: Moved to... * ctfc.cc: ...here. * ctfout.c: Moved to... * ctfout.cc: ...here. * data-streamer-in.c: Moved to... * data-streamer-in.cc: ...here. * data-streamer-out.c: Moved to... * data-streamer-out.cc: ...here. * data-streamer.c: Moved to... * data-streamer.cc: ...here. * dbgcnt.c: Moved to... * dbgcnt.cc: ...here. * dbxout.c: Moved to... * dbxout.cc: ...here. * dce.c: Moved to... * dce.cc: ...here. * ddg.c: Moved to... * ddg.cc: ...here. * debug.c: Moved to... * debug.cc: ...here. * df-core.c: Moved to... * df-core.cc: ...here. * df-problems.c: Moved to... * df-problems.cc: ...here. * df-scan.c: Moved to... * df-scan.cc: ...here. * dfp.c: Moved to... * dfp.cc: ...here. * diagnostic-color.c: Moved to... * diagnostic-color.cc: ...here. * diagnostic-show-locus.c: Moved to... * diagnostic-show-locus.cc: ...here. * diagnostic-spec.c: Moved to... * diagnostic-spec.cc: ...here. * diagnostic.c: Moved to... * diagnostic.cc: ...here. * dojump.c: Moved to... * dojump.cc: ...here. * dominance.c: Moved to... * dominance.cc: ...here. * domwalk.c: Moved to... * domwalk.cc: ...here. * double-int.c: Moved to... * double-int.cc: ...here. * dse.c: Moved to... * dse.cc: ...here. * dumpfile.c: Moved to... * dumpfile.cc: ...here. * dwarf2asm.c: Moved to... * dwarf2asm.cc: ...here. * dwarf2cfi.c: Moved to... * dwarf2cfi.cc: ...here. * dwarf2ctf.c: Moved to... * dwarf2ctf.cc: ...here. * dwarf2out.c: Moved to... * dwarf2out.cc: ...here. * early-remat.c: Moved to... * early-remat.cc: ...here. * edit-context.c: Moved to... * edit-context.cc: ...here. * emit-rtl.c: Moved to... * emit-rtl.cc: ...here. * errors.c: Moved to... * errors.cc: ...here. * et-forest.c: Moved to... * et-forest.cc: ...here. * except.c: Moved to... * except.cc: ...here. * explow.c: Moved to... * explow.cc: ...here. * expmed.c: Moved to... * expmed.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * fibonacci_heap.c: Moved to... * fibonacci_heap.cc: ...here. * file-find.c: Moved to... * file-find.cc: ...here. * file-prefix-map.c: Moved to... * file-prefix-map.cc: ...here. * final.c: Moved to... * final.cc: ...here. * fixed-value.c: Moved to... * fixed-value.cc: ...here. * fold-const-call.c: Moved to... * fold-const-call.cc: ...here. * fold-const.c: Moved to... * fold-const.cc: ...here. * fp-test.c: Moved to... * fp-test.cc: ...here. * function-tests.c: Moved to... * function-tests.cc: ...here. * function.c: Moved to... * function.cc: ...here. * fwprop.c: Moved to... * fwprop.cc: ...here. * gcc-ar.c: Moved to... * gcc-ar.cc: ...here. * gcc-main.c: Moved to... * gcc-main.cc: ...here. * gcc-rich-location.c: Moved to... * gcc-rich-location.cc: ...here. * gcc.c: Moved to... * gcc.cc: ...here. * gcov-dump.c: Moved to... * gcov-dump.cc: ...here. * gcov-io.c: Moved to... * gcov-io.cc: ...here. * gcov-tool.c: Moved to... * gcov-tool.cc: ...here. * gcov.c: Moved to... * gcov.cc: ...here. * gcse-common.c: Moved to... * gcse-common.cc: ...here. * gcse.c: Moved to... * gcse.cc: ...here. * genattr-common.c: Moved to... * genattr-common.cc: ...here. * genattr.c: Moved to... * genattr.cc: ...here. * genattrtab.c: Moved to... * genattrtab.cc: ...here. * genautomata.c: Moved to... * genautomata.cc: ...here. * gencfn-macros.c: Moved to... * gencfn-macros.cc: ...here. * gencheck.c: Moved to... * gencheck.cc: ...here. * genchecksum.c: Moved to... * genchecksum.cc: ...here. * gencodes.c: Moved to... * gencodes.cc: ...here. * genconditions.c: Moved to... * genconditions.cc: ...here. * genconfig.c: Moved to... * genconfig.cc: ...here. * genconstants.c: Moved to... * genconstants.cc: ...here. * genemit.c: Moved to... * genemit.cc: ...here. * genenums.c: Moved to... * genenums.cc: ...here. * generic-match-head.c: Moved to... * generic-match-head.cc: ...here. * genextract.c: Moved to... * genextract.cc: ...here. * genflags.c: Moved to... * genflags.cc: ...here. * gengenrtl.c: Moved to... * gengenrtl.cc: ...here. * gengtype-parse.c: Moved to... * gengtype-parse.cc: ...here. * gengtype-state.c: Moved to... * gengtype-state.cc: ...here. * gengtype.c: Moved to... * gengtype.cc: ...here. * genhooks.c: Moved to... * genhooks.cc: ...here. * genmatch.c: Moved to... * genmatch.cc: ...here. * genmddeps.c: Moved to... * genmddeps.cc: ...here. * genmddump.c: Moved to... * genmddump.cc: ...here. * genmodes.c: Moved to... * genmodes.cc: ...here. * genopinit.c: Moved to... * genopinit.cc: ...here. * genoutput.c: Moved to... * genoutput.cc: ...here. * genpeep.c: Moved to... * genpeep.cc: ...here. * genpreds.c: Moved to... * genpreds.cc: ...here. * genrecog.c: Moved to... * genrecog.cc: ...here. * gensupport.c: Moved to... * gensupport.cc: ...here. * gentarget-def.c: Moved to... * gentarget-def.cc: ...here. * genversion.c: Moved to... * genversion.cc: ...here. * ggc-common.c: Moved to... * ggc-common.cc: ...here. * ggc-none.c: Moved to... * ggc-none.cc: ...here. * ggc-page.c: Moved to... * ggc-page.cc: ...here. * ggc-tests.c: Moved to... * ggc-tests.cc: ...here. * gimple-builder.c: Moved to... * gimple-builder.cc: ...here. * gimple-expr.c: Moved to... * gimple-expr.cc: ...here. * gimple-fold.c: Moved to... * gimple-fold.cc: ...here. * gimple-iterator.c: Moved to... * gimple-iterator.cc: ...here. * gimple-laddress.c: Moved to... * gimple-laddress.cc: ...here. * gimple-loop-jam.c: Moved to... * gimple-loop-jam.cc: ...here. * gimple-low.c: Moved to... * gimple-low.cc: ...here. * gimple-match-head.c: Moved to... * gimple-match-head.cc: ...here. * gimple-pretty-print.c: Moved to... * gimple-pretty-print.cc: ...here. * gimple-ssa-backprop.c: Moved to... * gimple-ssa-backprop.cc: ...here. * gimple-ssa-evrp-analyze.c: Moved to... * gimple-ssa-evrp-analyze.cc: ...here. * gimple-ssa-evrp.c: Moved to... * gimple-ssa-evrp.cc: ...here. * gimple-ssa-isolate-paths.c: Moved to... * gimple-ssa-isolate-paths.cc: ...here. * gimple-ssa-nonnull-compare.c: Moved to... * gimple-ssa-nonnull-compare.cc: ...here. * gimple-ssa-split-paths.c: Moved to... * gimple-ssa-split-paths.cc: ...here. * gimple-ssa-sprintf.c: Moved to... * gimple-ssa-sprintf.cc: ...here. * gimple-ssa-store-merging.c: Moved to... * gimple-ssa-store-merging.cc: ...here. * gimple-ssa-strength-reduction.c: Moved to... * gimple-ssa-strength-reduction.cc: ...here. * gimple-ssa-warn-alloca.c: Moved to... * gimple-ssa-warn-alloca.cc: ...here. * gimple-ssa-warn-restrict.c: Moved to... * gimple-ssa-warn-restrict.cc: ...here. * gimple-streamer-in.c: Moved to... * gimple-streamer-in.cc: ...here. * gimple-streamer-out.c: Moved to... * gimple-streamer-out.cc: ...here. * gimple-walk.c: Moved to... * gimple-walk.cc: ...here. * gimple-warn-recursion.c: Moved to... * gimple-warn-recursion.cc: ...here. * gimple.c: Moved to... * gimple.cc: ...here. * gimplify-me.c: Moved to... * gimplify-me.cc: ...here. * gimplify.c: Moved to... * gimplify.cc: ...here. * godump.c: Moved to... * godump.cc: ...here. * graph.c: Moved to... * graph.cc: ...here. * graphds.c: Moved to... * graphds.cc: ...here. * graphite-dependences.c: Moved to... * graphite-dependences.cc: ...here. * graphite-isl-ast-to-gimple.c: Moved to... * graphite-isl-ast-to-gimple.cc: ...here. * graphite-optimize-isl.c: Moved to... * graphite-optimize-isl.cc: ...here. * graphite-poly.c: Moved to... * graphite-poly.cc: ...here. * graphite-scop-detection.c: Moved to... * graphite-scop-detection.cc: ...here. * graphite-sese-to-poly.c: Moved to... * graphite-sese-to-poly.cc: ...here. * graphite.c: Moved to... * graphite.cc: ...here. * haifa-sched.c: Moved to... * haifa-sched.cc: ...here. * hash-map-tests.c: Moved to... * hash-map-tests.cc: ...here. * hash-set-tests.c: Moved to... * hash-set-tests.cc: ...here. * hash-table.c: Moved to... * hash-table.cc: ...here. * hooks.c: Moved to... * hooks.cc: ...here. * host-default.c: Moved to... * host-default.cc: ...here. * hw-doloop.c: Moved to... * hw-doloop.cc: ...here. * hwint.c: Moved to... * hwint.cc: ...here. * ifcvt.c: Moved to... * ifcvt.cc: ...here. * inchash.c: Moved to... * inchash.cc: ...here. * incpath.c: Moved to... * incpath.cc: ...here. * init-regs.c: Moved to... * init-regs.cc: ...here. * input.c: Moved to... * input.cc: ...here. * internal-fn.c: Moved to... * internal-fn.cc: ...here. * intl.c: Moved to... * intl.cc: ...here. * ipa-comdats.c: Moved to... * ipa-comdats.cc: ...here. * ipa-cp.c: Moved to... * ipa-cp.cc: ...here. * ipa-devirt.c: Moved to... * ipa-devirt.cc: ...here. * ipa-fnsummary.c: Moved to... * ipa-fnsummary.cc: ...here. * ipa-icf-gimple.c: Moved to... * ipa-icf-gimple.cc: ...here. * ipa-icf.c: Moved to... * ipa-icf.cc: ...here. * ipa-inline-analysis.c: Moved to... * ipa-inline-analysis.cc: ...here. * ipa-inline-transform.c: Moved to... * ipa-inline-transform.cc: ...here. * ipa-inline.c: Moved to... * ipa-inline.cc: ...here. * ipa-modref-tree.c: Moved to... * ipa-modref-tree.cc: ...here. * ipa-modref.c: Moved to... * ipa-modref.cc: ...here. * ipa-param-manipulation.c: Moved to... * ipa-param-manipulation.cc: ...here. * ipa-polymorphic-call.c: Moved to... * ipa-polymorphic-call.cc: ...here. * ipa-predicate.c: Moved to... * ipa-predicate.cc: ...here. * ipa-profile.c: Moved to... * ipa-profile.cc: ...here. * ipa-prop.c: Moved to... * ipa-prop.cc: ...here. * ipa-pure-const.c: Moved to... * ipa-pure-const.cc: ...here. * ipa-ref.c: Moved to... * ipa-ref.cc: ...here. * ipa-reference.c: Moved to... * ipa-reference.cc: ...here. * ipa-split.c: Moved to... * ipa-split.cc: ...here. * ipa-sra.c: Moved to... * ipa-sra.cc: ...here. * ipa-utils.c: Moved to... * ipa-utils.cc: ...here. * ipa-visibility.c: Moved to... * ipa-visibility.cc: ...here. * ipa.c: Moved to... * ipa.cc: ...here. * ira-build.c: Moved to... * ira-build.cc: ...here. * ira-color.c: Moved to... * ira-color.cc: ...here. * ira-conflicts.c: Moved to... * ira-conflicts.cc: ...here. * ira-costs.c: Moved to... * ira-costs.cc: ...here. * ira-emit.c: Moved to... * ira-emit.cc: ...here. * ira-lives.c: Moved to... * ira-lives.cc: ...here. * ira.c: Moved to... * ira.cc: ...here. * jump.c: Moved to... * jump.cc: ...here. * langhooks.c: Moved to... * langhooks.cc: ...here. * lcm.c: Moved to... * lcm.cc: ...here. * lists.c: Moved to... * lists.cc: ...here. * loop-doloop.c: Moved to... * loop-doloop.cc: ...here. * loop-init.c: Moved to... * loop-init.cc: ...here. * loop-invariant.c: Moved to... * loop-invariant.cc: ...here. * loop-iv.c: Moved to... * loop-iv.cc: ...here. * loop-unroll.c: Moved to... * loop-unroll.cc: ...here. * lower-subreg.c: Moved to... * lower-subreg.cc: ...here. * lra-assigns.c: Moved to... * lra-assigns.cc: ...here. * lra-coalesce.c: Moved to... * lra-coalesce.cc: ...here. * lra-constraints.c: Moved to... * lra-constraints.cc: ...here. * lra-eliminations.c: Moved to... * lra-eliminations.cc: ...here. * lra-lives.c: Moved to... * lra-lives.cc: ...here. * lra-remat.c: Moved to... * lra-remat.cc: ...here. * lra-spills.c: Moved to... * lra-spills.cc: ...here. * lra.c: Moved to... * lra.cc: ...here. * lto-cgraph.c: Moved to... * lto-cgraph.cc: ...here. * lto-compress.c: Moved to... * lto-compress.cc: ...here. * lto-opts.c: Moved to... * lto-opts.cc: ...here. * lto-section-in.c: Moved to... * lto-section-in.cc: ...here. * lto-section-out.c: Moved to... * lto-section-out.cc: ...here. * lto-streamer-in.c: Moved to... * lto-streamer-in.cc: ...here. * lto-streamer-out.c: Moved to... * lto-streamer-out.cc: ...here. * lto-streamer.c: Moved to... * lto-streamer.cc: ...here. * lto-wrapper.c: Moved to... * lto-wrapper.cc: ...here. * main.c: Moved to... * main.cc: ...here. * mcf.c: Moved to... * mcf.cc: ...here. * mode-switching.c: Moved to... * mode-switching.cc: ...here. * modulo-sched.c: Moved to... * modulo-sched.cc: ...here. * multiple_target.c: Moved to... * multiple_target.cc: ...here. * omp-expand.c: Moved to... * omp-expand.cc: ...here. * omp-general.c: Moved to... * omp-general.cc: ...here. * omp-low.c: Moved to... * omp-low.cc: ...here. * omp-offload.c: Moved to... * omp-offload.cc: ...here. * omp-simd-clone.c: Moved to... * omp-simd-clone.cc: ...here. * opt-suggestions.c: Moved to... * opt-suggestions.cc: ...here. * optabs-libfuncs.c: Moved to... * optabs-libfuncs.cc: ...here. * optabs-query.c: Moved to... * optabs-query.cc: ...here. * optabs-tree.c: Moved to... * optabs-tree.cc: ...here. * optabs.c: Moved to... * optabs.cc: ...here. * opts-common.c: Moved to... * opts-common.cc: ...here. * opts-global.c: Moved to... * opts-global.cc: ...here. * opts.c: Moved to... * opts.cc: ...here. * passes.c: Moved to... * passes.cc: ...here. * plugin.c: Moved to... * plugin.cc: ...here. * postreload-gcse.c: Moved to... * postreload-gcse.cc: ...here. * postreload.c: Moved to... * postreload.cc: ...here. * predict.c: Moved to... * predict.cc: ...here. * prefix.c: Moved to... * prefix.cc: ...here. * pretty-print.c: Moved to... * pretty-print.cc: ...here. * print-rtl-function.c: Moved to... * print-rtl-function.cc: ...here. * print-rtl.c: Moved to... * print-rtl.cc: ...here. * print-tree.c: Moved to... * print-tree.cc: ...here. * profile-count.c: Moved to... * profile-count.cc: ...here. * profile.c: Moved to... * profile.cc: ...here. * read-md.c: Moved to... * read-md.cc: ...here. * read-rtl-function.c: Moved to... * read-rtl-function.cc: ...here. * read-rtl.c: Moved to... * read-rtl.cc: ...here. * real.c: Moved to... * real.cc: ...here. * realmpfr.c: Moved to... * realmpfr.cc: ...here. * recog.c: Moved to... * recog.cc: ...here. * ree.c: Moved to... * ree.cc: ...here. * reg-stack.c: Moved to... * reg-stack.cc: ...here. * regcprop.c: Moved to... * regcprop.cc: ...here. * reginfo.c: Moved to... * reginfo.cc: ...here. * regrename.c: Moved to... * regrename.cc: ...here. * regstat.c: Moved to... * regstat.cc: ...here. * reload.c: Moved to... * reload.cc: ...here. * reload1.c: Moved to... * reload1.cc: ...here. * reorg.c: Moved to... * reorg.cc: ...here. * resource.c: Moved to... * resource.cc: ...here. * rtl-error.c: Moved to... * rtl-error.cc: ...here. * rtl-tests.c: Moved to... * rtl-tests.cc: ...here. * rtl.c: Moved to... * rtl.cc: ...here. * rtlanal.c: Moved to... * rtlanal.cc: ...here. * rtlhash.c: Moved to... * rtlhash.cc: ...here. * rtlhooks.c: Moved to... * rtlhooks.cc: ...here. * rtx-vector-builder.c: Moved to... * rtx-vector-builder.cc: ...here. * run-rtl-passes.c: Moved to... * run-rtl-passes.cc: ...here. * sancov.c: Moved to... * sancov.cc: ...here. * sanopt.c: Moved to... * sanopt.cc: ...here. * sbitmap.c: Moved to... * sbitmap.cc: ...here. * sched-deps.c: Moved to... * sched-deps.cc: ...here. * sched-ebb.c: Moved to... * sched-ebb.cc: ...here. * sched-rgn.c: Moved to... * sched-rgn.cc: ...here. * sel-sched-dump.c: Moved to... * sel-sched-dump.cc: ...here. * sel-sched-ir.c: Moved to... * sel-sched-ir.cc: ...here. * sel-sched.c: Moved to... * sel-sched.cc: ...here. * selftest-diagnostic.c: Moved to... * selftest-diagnostic.cc: ...here. * selftest-rtl.c: Moved to... * selftest-rtl.cc: ...here. * selftest-run-tests.c: Moved to... * selftest-run-tests.cc: ...here. * selftest.c: Moved to... * selftest.cc: ...here. * sese.c: Moved to... * sese.cc: ...here. * shrink-wrap.c: Moved to... * shrink-wrap.cc: ...here. * simplify-rtx.c: Moved to... * simplify-rtx.cc: ...here. * sparseset.c: Moved to... * sparseset.cc: ...here. * spellcheck-tree.c: Moved to... * spellcheck-tree.cc: ...here. * spellcheck.c: Moved to... * spellcheck.cc: ...here. * sreal.c: Moved to... * sreal.cc: ...here. * stack-ptr-mod.c: Moved to... * stack-ptr-mod.cc: ...here. * statistics.c: Moved to... * statistics.cc: ...here. * stmt.c: Moved to... * stmt.cc: ...here. * stor-layout.c: Moved to... * stor-layout.cc: ...here. * store-motion.c: Moved to... * store-motion.cc: ...here. * streamer-hooks.c: Moved to... * streamer-hooks.cc: ...here. * stringpool.c: Moved to... * stringpool.cc: ...here. * substring-locations.c: Moved to... * substring-locations.cc: ...here. * symtab.c: Moved to... * symtab.cc: ...here. * target-globals.c: Moved to... * target-globals.cc: ...here. * targhooks.c: Moved to... * targhooks.cc: ...here. * timevar.c: Moved to... * timevar.cc: ...here. * toplev.c: Moved to... * toplev.cc: ...here. * tracer.c: Moved to... * tracer.cc: ...here. * trans-mem.c: Moved to... * trans-mem.cc: ...here. * tree-affine.c: Moved to... * tree-affine.cc: ...here. * tree-call-cdce.c: Moved to... * tree-call-cdce.cc: ...here. * tree-cfg.c: Moved to... * tree-cfg.cc: ...here. * tree-cfgcleanup.c: Moved to... * tree-cfgcleanup.cc: ...here. * tree-chrec.c: Moved to... * tree-chrec.cc: ...here. * tree-complex.c: Moved to... * tree-complex.cc: ...here. * tree-data-ref.c: Moved to... * tree-data-ref.cc: ...here. * tree-dfa.c: Moved to... * tree-dfa.cc: ...here. * tree-diagnostic.c: Moved to... * tree-diagnostic.cc: ...here. * tree-dump.c: Moved to... * tree-dump.cc: ...here. * tree-eh.c: Moved to... * tree-eh.cc: ...here. * tree-emutls.c: Moved to... * tree-emutls.cc: ...here. * tree-if-conv.c: Moved to... * tree-if-conv.cc: ...here. * tree-inline.c: Moved to... * tree-inline.cc: ...here. * tree-into-ssa.c: Moved to... * tree-into-ssa.cc: ...here. * tree-iterator.c: Moved to... * tree-iterator.cc: ...here. * tree-loop-distribution.c: Moved to... * tree-loop-distribution.cc: ...here. * tree-nested.c: Moved to... * tree-nested.cc: ...here. * tree-nrv.c: Moved to... * tree-nrv.cc: ...here. * tree-object-size.c: Moved to... * tree-object-size.cc: ...here. * tree-outof-ssa.c: Moved to... * tree-outof-ssa.cc: ...here. * tree-parloops.c: Moved to... * tree-parloops.cc: ...here. * tree-phinodes.c: Moved to... * tree-phinodes.cc: ...here. * tree-predcom.c: Moved to... * tree-predcom.cc: ...here. * tree-pretty-print.c: Moved to... * tree-pretty-print.cc: ...here. * tree-profile.c: Moved to... * tree-profile.cc: ...here. * tree-scalar-evolution.c: Moved to... * tree-scalar-evolution.cc: ...here. * tree-sra.c: Moved to... * tree-sra.cc: ...here. * tree-ssa-address.c: Moved to... * tree-ssa-address.cc: ...here. * tree-ssa-alias.c: Moved to... * tree-ssa-alias.cc: ...here. * tree-ssa-ccp.c: Moved to... * tree-ssa-ccp.cc: ...here. * tree-ssa-coalesce.c: Moved to... * tree-ssa-coalesce.cc: ...here. * tree-ssa-copy.c: Moved to... * tree-ssa-copy.cc: ...here. * tree-ssa-dce.c: Moved to... * tree-ssa-dce.cc: ...here. * tree-ssa-dom.c: Moved to... * tree-ssa-dom.cc: ...here. * tree-ssa-dse.c: Moved to... * tree-ssa-dse.cc: ...here. * tree-ssa-forwprop.c: Moved to... * tree-ssa-forwprop.cc: ...here. * tree-ssa-ifcombine.c: Moved to... * tree-ssa-ifcombine.cc: ...here. * tree-ssa-live.c: Moved to... * tree-ssa-live.cc: ...here. * tree-ssa-loop-ch.c: Moved to... * tree-ssa-loop-ch.cc: ...here. * tree-ssa-loop-im.c: Moved to... * tree-ssa-loop-im.cc: ...here. * tree-ssa-loop-ivcanon.c: Moved to... * tree-ssa-loop-ivcanon.cc: ...here. * tree-ssa-loop-ivopts.c: Moved to... * tree-ssa-loop-ivopts.cc: ...here. * tree-ssa-loop-manip.c: Moved to... * tree-ssa-loop-manip.cc: ...here. * tree-ssa-loop-niter.c: Moved to... * tree-ssa-loop-niter.cc: ...here. * tree-ssa-loop-prefetch.c: Moved to... * tree-ssa-loop-prefetch.cc: ...here. * tree-ssa-loop-split.c: Moved to... * tree-ssa-loop-split.cc: ...here. * tree-ssa-loop-unswitch.c: Moved to... * tree-ssa-loop-unswitch.cc: ...here. * tree-ssa-loop.c: Moved to... * tree-ssa-loop.cc: ...here. * tree-ssa-math-opts.c: Moved to... * tree-ssa-math-opts.cc: ...here. * tree-ssa-operands.c: Moved to... * tree-ssa-operands.cc: ...here. * tree-ssa-phiopt.c: Moved to... * tree-ssa-phiopt.cc: ...here. * tree-ssa-phiprop.c: Moved to... * tree-ssa-phiprop.cc: ...here. * tree-ssa-pre.c: Moved to... * tree-ssa-pre.cc: ...here. * tree-ssa-propagate.c: Moved to... * tree-ssa-propagate.cc: ...here. * tree-ssa-reassoc.c: Moved to... * tree-ssa-reassoc.cc: ...here. * tree-ssa-sccvn.c: Moved to... * tree-ssa-sccvn.cc: ...here. * tree-ssa-scopedtables.c: Moved to... * tree-ssa-scopedtables.cc: ...here. * tree-ssa-sink.c: Moved to... * tree-ssa-sink.cc: ...here. * tree-ssa-strlen.c: Moved to... * tree-ssa-strlen.cc: ...here. * tree-ssa-structalias.c: Moved to... * tree-ssa-structalias.cc: ...here. * tree-ssa-tail-merge.c: Moved to... * tree-ssa-tail-merge.cc: ...here. * tree-ssa-ter.c: Moved to... * tree-ssa-ter.cc: ...here. * tree-ssa-threadbackward.c: Moved to... * tree-ssa-threadbackward.cc: ...here. * tree-ssa-threadedge.c: Moved to... * tree-ssa-threadedge.cc: ...here. * tree-ssa-threadupdate.c: Moved to... * tree-ssa-threadupdate.cc: ...here. * tree-ssa-uncprop.c: Moved to... * tree-ssa-uncprop.cc: ...here. * tree-ssa-uninit.c: Moved to... * tree-ssa-uninit.cc: ...here. * tree-ssa.c: Moved to... * tree-ssa.cc: ...here. * tree-ssanames.c: Moved to... * tree-ssanames.cc: ...here. * tree-stdarg.c: Moved to... * tree-stdarg.cc: ...here. * tree-streamer-in.c: Moved to... * tree-streamer-in.cc: ...here. * tree-streamer-out.c: Moved to... * tree-streamer-out.cc: ...here. * tree-streamer.c: Moved to... * tree-streamer.cc: ...here. * tree-switch-conversion.c: Moved to... * tree-switch-conversion.cc: ...here. * tree-tailcall.c: Moved to... * tree-tailcall.cc: ...here. * tree-vect-data-refs.c: Moved to... * tree-vect-data-refs.cc: ...here. * tree-vect-generic.c: Moved to... * tree-vect-generic.cc: ...here. * tree-vect-loop-manip.c: Moved to... * tree-vect-loop-manip.cc: ...here. * tree-vect-loop.c: Moved to... * tree-vect-loop.cc: ...here. * tree-vect-patterns.c: Moved to... * tree-vect-patterns.cc: ...here. * tree-vect-slp-patterns.c: Moved to... * tree-vect-slp-patterns.cc: ...here. * tree-vect-slp.c: Moved to... * tree-vect-slp.cc: ...here. * tree-vect-stmts.c: Moved to... * tree-vect-stmts.cc: ...here. * tree-vector-builder.c: Moved to... * tree-vector-builder.cc: ...here. * tree-vectorizer.c: Moved to... * tree-vectorizer.cc: ...here. * tree-vrp.c: Moved to... * tree-vrp.cc: ...here. * tree.c: Moved to... * tree.cc: ...here. * tsan.c: Moved to... * tsan.cc: ...here. * typed-splay-tree.c: Moved to... * typed-splay-tree.cc: ...here. * ubsan.c: Moved to... * ubsan.cc: ...here. * valtrack.c: Moved to... * valtrack.cc: ...here. * value-prof.c: Moved to... * value-prof.cc: ...here. * var-tracking.c: Moved to... * var-tracking.cc: ...here. * varasm.c: Moved to... * varasm.cc: ...here. * varpool.c: Moved to... * varpool.cc: ...here. * vec-perm-indices.c: Moved to... * vec-perm-indices.cc: ...here. * vec.c: Moved to... * vec.cc: ...here. * vmsdbgout.c: Moved to... * vmsdbgout.cc: ...here. * vr-values.c: Moved to... * vr-values.cc: ...here. * vtable-verify.c: Moved to... * vtable-verify.cc: ...here. * web.c: Moved to... * web.cc: ...here. * xcoffout.c: Moved to... * xcoffout.cc: ...here. gcc/c-family/ChangeLog: * c-ada-spec.c: Moved to... * c-ada-spec.cc: ...here. * c-attribs.c: Moved to... * c-attribs.cc: ...here. * c-common.c: Moved to... * c-common.cc: ...here. * c-cppbuiltin.c: Moved to... * c-cppbuiltin.cc: ...here. * c-dump.c: Moved to... * c-dump.cc: ...here. * c-format.c: Moved to... * c-format.cc: ...here. * c-gimplify.c: Moved to... * c-gimplify.cc: ...here. * c-indentation.c: Moved to... * c-indentation.cc: ...here. * c-lex.c: Moved to... * c-lex.cc: ...here. * c-omp.c: Moved to... * c-omp.cc: ...here. * c-opts.c: Moved to... * c-opts.cc: ...here. * c-pch.c: Moved to... * c-pch.cc: ...here. * c-ppoutput.c: Moved to... * c-ppoutput.cc: ...here. * c-pragma.c: Moved to... * c-pragma.cc: ...here. * c-pretty-print.c: Moved to... * c-pretty-print.cc: ...here. * c-semantics.c: Moved to... * c-semantics.cc: ...here. * c-ubsan.c: Moved to... * c-ubsan.cc: ...here. * c-warn.c: Moved to... * c-warn.cc: ...here. * cppspec.c: Moved to... * cppspec.cc: ...here. * stub-objc.c: Moved to... * stub-objc.cc: ...here. gcc/c/ChangeLog: * c-aux-info.c: Moved to... * c-aux-info.cc: ...here. * c-convert.c: Moved to... * c-convert.cc: ...here. * c-decl.c: Moved to... * c-decl.cc: ...here. * c-errors.c: Moved to... * c-errors.cc: ...here. * c-fold.c: Moved to... * c-fold.cc: ...here. * c-lang.c: Moved to... * c-lang.cc: ...here. * c-objc-common.c: Moved to... * c-objc-common.cc: ...here. * c-parser.c: Moved to... * c-parser.cc: ...here. * c-typeck.c: Moved to... * c-typeck.cc: ...here. * gccspec.c: Moved to... * gccspec.cc: ...here. * gimple-parser.c: Moved to... * gimple-parser.cc: ...here. gcc/cp/ChangeLog: * call.c: Moved to... * call.cc: ...here. * class.c: Moved to... * class.cc: ...here. * constexpr.c: Moved to... * constexpr.cc: ...here. * cp-gimplify.c: Moved to... * cp-gimplify.cc: ...here. * cp-lang.c: Moved to... * cp-lang.cc: ...here. * cp-objcp-common.c: Moved to... * cp-objcp-common.cc: ...here. * cp-ubsan.c: Moved to... * cp-ubsan.cc: ...here. * cvt.c: Moved to... * cvt.cc: ...here. * cxx-pretty-print.c: Moved to... * cxx-pretty-print.cc: ...here. * decl.c: Moved to... * decl.cc: ...here. * decl2.c: Moved to... * decl2.cc: ...here. * dump.c: Moved to... * dump.cc: ...here. * error.c: Moved to... * error.cc: ...here. * except.c: Moved to... * except.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * friend.c: Moved to... * friend.cc: ...here. * g++spec.c: Moved to... * g++spec.cc: ...here. * init.c: Moved to... * init.cc: ...here. * lambda.c: Moved to... * lambda.cc: ...here. * lex.c: Moved to... * lex.cc: ...here. * mangle.c: Moved to... * mangle.cc: ...here. * method.c: Moved to... * method.cc: ...here. * name-lookup.c: Moved to... * name-lookup.cc: ...here. * optimize.c: Moved to... * optimize.cc: ...here. * parser.c: Moved to... * parser.cc: ...here. * pt.c: Moved to... * pt.cc: ...here. * ptree.c: Moved to... * ptree.cc: ...here. * rtti.c: Moved to... * rtti.cc: ...here. * search.c: Moved to... * search.cc: ...here. * semantics.c: Moved to... * semantics.cc: ...here. * tree.c: Moved to... * tree.cc: ...here. * typeck.c: Moved to... * typeck.cc: ...here. * typeck2.c: Moved to... * typeck2.cc: ...here. * vtable-class-hierarchy.c: Moved to... * vtable-class-hierarchy.cc: ...here. gcc/fortran/ChangeLog: * arith.c: Moved to... * arith.cc: ...here. * array.c: Moved to... * array.cc: ...here. * bbt.c: Moved to... * bbt.cc: ...here. * check.c: Moved to... * check.cc: ...here. * class.c: Moved to... * class.cc: ...here. * constructor.c: Moved to... * constructor.cc: ...here. * convert.c: Moved to... * convert.cc: ...here. * cpp.c: Moved to... * cpp.cc: ...here. * data.c: Moved to... * data.cc: ...here. * decl.c: Moved to... * decl.cc: ...here. * dependency.c: Moved to... * dependency.cc: ...here. * dump-parse-tree.c: Moved to... * dump-parse-tree.cc: ...here. * error.c: Moved to... * error.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * f95-lang.c: Moved to... * f95-lang.cc: ...here. * frontend-passes.c: Moved to... * frontend-passes.cc: ...here. * gfortranspec.c: Moved to... * gfortranspec.cc: ...here. * interface.c: Moved to... * interface.cc: ...here. * intrinsic.c: Moved to... * intrinsic.cc: ...here. * io.c: Moved to... * io.cc: ...here. * iresolve.c: Moved to... * iresolve.cc: ...here. * match.c: Moved to... * match.cc: ...here. * matchexp.c: Moved to... * matchexp.cc: ...here. * misc.c: Moved to... * misc.cc: ...here. * module.c: Moved to... * module.cc: ...here. * openmp.c: Moved to... * openmp.cc: ...here. * options.c: Moved to... * options.cc: ...here. * parse.c: Moved to... * parse.cc: ...here. * primary.c: Moved to... * primary.cc: ...here. * resolve.c: Moved to... * resolve.cc: ...here. * scanner.c: Moved to... * scanner.cc: ...here. * simplify.c: Moved to... * simplify.cc: ...here. * st.c: Moved to... * st.cc: ...here. * symbol.c: Moved to... * symbol.cc: ...here. * target-memory.c: Moved to... * target-memory.cc: ...here. * trans-array.c: Moved to... * trans-array.cc: ...here. * trans-common.c: Moved to... * trans-common.cc: ...here. * trans-const.c: Moved to... * trans-const.cc: ...here. * trans-decl.c: Moved to... * trans-decl.cc: ...here. * trans-expr.c: Moved to... * trans-expr.cc: ...here. * trans-intrinsic.c: Moved to... * trans-intrinsic.cc: ...here. * trans-io.c: Moved to... * trans-io.cc: ...here. * trans-openmp.c: Moved to... * trans-openmp.cc: ...here. * trans-stmt.c: Moved to... * trans-stmt.cc: ...here. * trans-types.c: Moved to... * trans-types.cc: ...here. * trans.c: Moved to... * trans.cc: ...here. gcc/go/ChangeLog: * go-backend.c: Moved to... * go-backend.cc: ...here. * go-lang.c: Moved to... * go-lang.cc: ...here. * gospec.c: Moved to... * gospec.cc: ...here. gcc/jit/ChangeLog: * dummy-frontend.c: Moved to... * dummy-frontend.cc: ...here. * jit-builtins.c: Moved to... * jit-builtins.cc: ...here. * jit-logging.c: Moved to... * jit-logging.cc: ...here. * jit-playback.c: Moved to... * jit-playback.cc: ...here. * jit-recording.c: Moved to... * jit-recording.cc: ...here. * jit-result.c: Moved to... * jit-result.cc: ...here. * jit-spec.c: Moved to... * jit-spec.cc: ...here. * jit-tempdir.c: Moved to... * jit-tempdir.cc: ...here. * jit-w32.c: Moved to... * jit-w32.cc: ...here. * libgccjit.c: Moved to... * libgccjit.cc: ...here. gcc/lto/ChangeLog: * common.c: Moved to... * common.cc: ...here. * lto-common.c: Moved to... * lto-common.cc: ...here. * lto-dump.c: Moved to... * lto-dump.cc: ...here. * lto-lang.c: Moved to... * lto-lang.cc: ...here. * lto-object.c: Moved to... * lto-object.cc: ...here. * lto-partition.c: Moved to... * lto-partition.cc: ...here. * lto-symtab.c: Moved to... * lto-symtab.cc: ...here. * lto.c: Moved to... * lto.cc: ...here. gcc/objc/ChangeLog: * objc-act.c: Moved to... * objc-act.cc: ...here. * objc-encoding.c: Moved to... * objc-encoding.cc: ...here. * objc-gnu-runtime-abi-01.c: Moved to... * objc-gnu-runtime-abi-01.cc: ...here. * objc-lang.c: Moved to... * objc-lang.cc: ...here. * objc-map.c: Moved to... * objc-map.cc: ...here. * objc-next-runtime-abi-01.c: Moved to... * objc-next-runtime-abi-01.cc: ...here. * objc-next-runtime-abi-02.c: Moved to... * objc-next-runtime-abi-02.cc: ...here. * objc-runtime-shared-support.c: Moved to... * objc-runtime-shared-support.cc: ...here. gcc/objcp/ChangeLog: * objcp-decl.c: Moved to... * objcp-decl.cc: ...here. * objcp-lang.c: Moved to... * objcp-lang.cc: ...here. libcpp/ChangeLog: * charset.c: Moved to... * charset.cc: ...here. * directives.c: Moved to... * directives.cc: ...here. * errors.c: Moved to... * errors.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * files.c: Moved to... * files.cc: ...here. * identifiers.c: Moved to... * identifiers.cc: ...here. * init.c: Moved to... * init.cc: ...here. * lex.c: Moved to... * lex.cc: ...here. * line-map.c: Moved to... * line-map.cc: ...here. * macro.c: Moved to... * macro.cc: ...here. * makeucnid.c: Moved to... * makeucnid.cc: ...here. * mkdeps.c: Moved to... * mkdeps.cc: ...here. * pch.c: Moved to... * pch.cc: ...here. * symtab.c: Moved to... * symtab.cc: ...here. * traditional.c: Moved to... * traditional.cc: ...here.
Diffstat (limited to 'gcc/fortran/check.c')
-rw-r--r--gcc/fortran/check.c7523
1 files changed, 0 insertions, 7523 deletions
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
deleted file mode 100644
index 053f856..0000000
--- a/gcc/fortran/check.c
+++ /dev/null
@@ -1,7523 +0,0 @@
-/* Check functions
- Copyright (C) 2002-2022 Free Software Foundation, Inc.
- Contributed by Andy Vaught & Katherine Holcomb
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify it under
-the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 3, or (at your option) any later
-version.
-
-GCC is distributed in the hope that it will be useful, but WITHOUT ANY
-WARRANTY; without even the implied warranty of MERCHANTABILITY or
-FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING3. If not see
-<http://www.gnu.org/licenses/>. */
-
-
-/* These functions check to see if an argument list is compatible with
- a particular intrinsic function or subroutine. Presence of
- required arguments has already been established, the argument list
- has been sorted into the right order and has NULL arguments in the
- correct places for missing optional arguments. */
-
-#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-#include "options.h"
-#include "gfortran.h"
-#include "intrinsic.h"
-#include "constructor.h"
-#include "target-memory.h"
-
-
-/* Reset a BOZ to a zero value. This is used to prevent run-on errors
- from resolve.c(resolve_function). */
-
-static void
-reset_boz (gfc_expr *x)
-{
- /* Clear boz info. */
- x->boz.rdx = 0;
- x->boz.len = 0;
- free (x->boz.str);
-
- x->ts.type = BT_INTEGER;
- x->ts.kind = gfc_default_integer_kind;
- mpz_init (x->value.integer);
- mpz_set_ui (x->value.integer, 0);
-}
-
-/* A BOZ literal constant can appear in a limited number of contexts.
- gfc_invalid_boz() is a helper function to simplify error/warning
- generation. gfortran accepts the nonstandard 'X' for 'Z', and gfortran
- allows the BOZ indicator to appear as a suffix. If -fallow-invalid-boz
- is used, then issue a warning; otherwise issue an error. */
-
-bool
-gfc_invalid_boz (const char *msg, locus *loc)
-{
- if (flag_allow_invalid_boz)
- {
- gfc_warning (0, msg, loc);
- return false;
- }
-
- const char *hint = _(" [see %<-fno-allow-invalid-boz%>]");
- size_t len = strlen (msg) + strlen (hint) + 1;
- char *msg2 = (char *) alloca (len);
- strcpy (msg2, msg);
- strcat (msg2, hint);
- gfc_error (msg2, loc);
- return true;
-}
-
-
-/* Issue an error for an illegal BOZ argument. */
-
-static bool
-illegal_boz_arg (gfc_expr *x)
-{
- if (x->ts.type == BT_BOZ)
- {
- gfc_error ("BOZ literal constant at %L cannot be an actual argument "
- "to %qs", &x->where, gfc_current_intrinsic);
- reset_boz (x);
- return true;
- }
-
- return false;
-}
-
-/* Some precedures take two arguments such that both cannot be BOZ. */
-
-static bool
-boz_args_check(gfc_expr *i, gfc_expr *j)
-{
- if (i->ts.type == BT_BOZ && j->ts.type == BT_BOZ)
- {
- gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ "
- "literal constants", gfc_current_intrinsic, &i->where,
- &j->where);
- reset_boz (i);
- reset_boz (j);
- return false;
-
- }
-
- return true;
-}
-
-
-/* Check that a BOZ is a constant. */
-
-static bool
-is_boz_constant (gfc_expr *a)
-{
- if (a->expr_type != EXPR_CONSTANT)
- {
- gfc_error ("Invalid use of BOZ literal constant at %L", &a->where);
- return false;
- }
-
- return true;
-}
-
-
-/* Convert a octal string into a binary string. This is used in the
- fallback conversion of an octal string to a REAL. */
-
-static char *
-oct2bin(int nbits, char *oct)
-{
- const char bits[8][5] = {
- "000", "001", "010", "011", "100", "101", "110", "111"};
-
- char *buf, *bufp;
- int i, j, n;
-
- j = nbits + 1;
- if (nbits == 64) j++;
-
- bufp = buf = XCNEWVEC (char, j + 1);
- memset (bufp, 0, j + 1);
-
- n = strlen (oct);
- for (i = 0; i < n; i++, oct++)
- {
- j = *oct - 48;
- strcpy (bufp, &bits[j][0]);
- bufp += 3;
- }
-
- bufp = XCNEWVEC (char, nbits + 1);
- if (nbits == 64)
- strcpy (bufp, buf + 2);
- else
- strcpy (bufp, buf + 1);
-
- free (buf);
-
- return bufp;
-}
-
-
-/* Convert a hexidecimal string into a binary string. This is used in the
- fallback conversion of a hexidecimal string to a REAL. */
-
-static char *
-hex2bin(int nbits, char *hex)
-{
- const char bits[16][5] = {
- "0000", "0001", "0010", "0011", "0100", "0101", "0110", "0111",
- "1000", "1001", "1010", "1011", "1100", "1101", "1110", "1111"};
-
- char *buf, *bufp;
- int i, j, n;
-
- bufp = buf = XCNEWVEC (char, nbits + 1);
- memset (bufp, 0, nbits + 1);
-
- n = strlen (hex);
- for (i = 0; i < n; i++, hex++)
- {
- j = *hex;
- if (j > 47 && j < 58)
- j -= 48;
- else if (j > 64 && j < 71)
- j -= 55;
- else if (j > 96 && j < 103)
- j -= 87;
- else
- gcc_unreachable ();
-
- strcpy (bufp, &bits[j][0]);
- bufp += 4;
- }
-
- return buf;
-}
-
-
-/* Fallback conversion of a BOZ string to REAL. */
-
-static void
-bin2real (gfc_expr *x, int kind)
-{
- char buf[114], *sp;
- int b, i, ie, t, w;
- bool sgn;
- mpz_t em;
-
- i = gfc_validate_kind (BT_REAL, kind, false);
- t = gfc_real_kinds[i].digits - 1;
-
- /* Number of bits in the exponent. */
- if (gfc_real_kinds[i].max_exponent == 16384)
- w = 15;
- else if (gfc_real_kinds[i].max_exponent == 1024)
- w = 11;
- else
- w = 8;
-
- if (x->boz.rdx == 16)
- sp = hex2bin (gfc_real_kinds[i].mode_precision, x->boz.str);
- else if (x->boz.rdx == 8)
- sp = oct2bin (gfc_real_kinds[i].mode_precision, x->boz.str);
- else
- sp = x->boz.str;
-
- /* Extract sign bit. */
- sgn = *sp != '0';
-
- /* Extract biased exponent. */
- memset (buf, 0, 114);
- strncpy (buf, ++sp, w);
- mpz_init (em);
- mpz_set_str (em, buf, 2);
- ie = mpz_get_si (em);
-
- mpfr_init2 (x->value.real, t + 1);
- x->ts.type = BT_REAL;
- x->ts.kind = kind;
-
- sp += w; /* Set to first digit in significand. */
- b = (1 << w) - 1;
- if ((i == 0 && ie == b) || (i == 1 && ie == b)
- || ((i == 2 || i == 3) && ie == b))
- {
- bool zeros = true;
- if (i == 2) sp++;
- for (; *sp; sp++)
- {
- if (*sp != '0')
- {
- zeros = false;
- break;
- }
- }
-
- if (zeros)
- mpfr_set_inf (x->value.real, 1);
- else
- mpfr_set_nan (x->value.real);
- }
- else
- {
- if (i == 2)
- strncpy (buf, sp, t + 1);
- else
- {
- /* Significand with hidden bit. */
- buf[0] = '1';
- strncpy (&buf[1], sp, t);
- }
-
- /* Convert to significand to integer. */
- mpz_set_str (em, buf, 2);
- ie -= ((1 << (w - 1)) - 1); /* Unbiased exponent. */
- mpfr_set_z_2exp (x->value.real, em, ie - t, GFC_RND_MODE);
- }
-
- if (sgn) mpfr_neg (x->value.real, x->value.real, GFC_RND_MODE);
-
- mpz_clear (em);
-}
-
-
-/* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2real ()
- converts the string into a REAL of the appropriate kind. The treatment
- of the sign bit is processor dependent. */
-
-bool
-gfc_boz2real (gfc_expr *x, int kind)
-{
- extern int gfc_max_integer_kind;
- gfc_typespec ts;
- int len;
- char *buf, *str;
-
- if (!is_boz_constant (x))
- return false;
-
- /* Determine the length of the required string. */
- len = 8 * kind;
- if (x->boz.rdx == 16) len /= 4;
- if (x->boz.rdx == 8) len = len / 3 + 1;
- buf = (char *) alloca (len + 1); /* +1 for NULL terminator. */
-
- if (x->boz.len >= len) /* Truncate if necessary. */
- {
- str = x->boz.str + (x->boz.len - len);
- strcpy(buf, str);
- }
- else /* Copy and pad. */
- {
- memset (buf, 48, len);
- str = buf + (len - x->boz.len);
- strcpy (str, x->boz.str);
- }
-
- /* Need to adjust leading bits in an octal string. */
- if (x->boz.rdx == 8)
- {
- /* Clear first bit. */
- if (kind == 4 || kind == 10 || kind == 16)
- {
- if (buf[0] == '4')
- buf[0] = '0';
- else if (buf[0] == '5')
- buf[0] = '1';
- else if (buf[0] == '6')
- buf[0] = '2';
- else if (buf[0] == '7')
- buf[0] = '3';
- }
- /* Clear first two bits. */
- else
- {
- if (buf[0] == '2' || buf[0] == '4' || buf[0] == '6')
- buf[0] = '0';
- else if (buf[0] == '3' || buf[0] == '5' || buf[0] == '7')
- buf[0] = '1';
- }
- }
-
- /* Reset BOZ string to the truncated or padded version. */
- free (x->boz.str);
- x->boz.len = len;
- x->boz.str = XCNEWVEC (char, len + 1);
- strncpy (x->boz.str, buf, len);
-
- /* For some targets, the largest INTEGER in terms of bits is smaller than
- the bits needed to hold the REAL. Fortunately, the kind type parameter
- indicates the number of bytes required to an INTEGER and a REAL. */
- if (gfc_max_integer_kind < kind)
- {
- bin2real (x, kind);
- }
- else
- {
- /* Convert to widest possible integer. */
- gfc_boz2int (x, gfc_max_integer_kind);
- ts.type = BT_REAL;
- ts.kind = kind;
- if (!gfc_convert_boz (x, &ts))
- {
- gfc_error ("Failure in conversion of BOZ to REAL at %L", &x->where);
- return false;
- }
- }
-
- return true;
-}
-
-
-/* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2int ()
- converts the string into an INTEGER of the appropriate kind. The
- treatment of the sign bit is processor dependent. If the converted
- value exceeds the range of the type, then wrap-around semantics are
- applied. */
-
-bool
-gfc_boz2int (gfc_expr *x, int kind)
-{
- int i, len;
- char *buf, *str;
- mpz_t tmp1;
-
- if (!is_boz_constant (x))
- return false;
-
- i = gfc_validate_kind (BT_INTEGER, kind, false);
- len = gfc_integer_kinds[i].bit_size;
- if (x->boz.rdx == 16) len /= 4;
- if (x->boz.rdx == 8) len = len / 3 + 1;
- buf = (char *) alloca (len + 1); /* +1 for NULL terminator. */
-
- if (x->boz.len >= len) /* Truncate if necessary. */
- {
- str = x->boz.str + (x->boz.len - len);
- strcpy(buf, str);
- }
- else /* Copy and pad. */
- {
- memset (buf, 48, len);
- str = buf + (len - x->boz.len);
- strcpy (str, x->boz.str);
- }
-
- /* Need to adjust leading bits in an octal string. */
- if (x->boz.rdx == 8)
- {
- /* Clear first bit. */
- if (kind == 1 || kind == 4 || kind == 16)
- {
- if (buf[0] == '4')
- buf[0] = '0';
- else if (buf[0] == '5')
- buf[0] = '1';
- else if (buf[0] == '6')
- buf[0] = '2';
- else if (buf[0] == '7')
- buf[0] = '3';
- }
- /* Clear first two bits. */
- else
- {
- if (buf[0] == '2' || buf[0] == '4' || buf[0] == '6')
- buf[0] = '0';
- else if (buf[0] == '3' || buf[0] == '5' || buf[0] == '7')
- buf[0] = '1';
- }
- }
-
- /* Convert as-if unsigned integer. */
- mpz_init (tmp1);
- mpz_set_str (tmp1, buf, x->boz.rdx);
-
- /* Check for wrap-around. */
- if (mpz_cmp (tmp1, gfc_integer_kinds[i].huge) > 0)
- {
- mpz_t tmp2;
- mpz_init (tmp2);
- mpz_add_ui (tmp2, gfc_integer_kinds[i].huge, 1);
- mpz_mod (tmp1, tmp1, tmp2);
- mpz_sub (tmp1, tmp1, tmp2);
- mpz_clear (tmp2);
- }
-
- /* Clear boz info. */
- x->boz.rdx = 0;
- x->boz.len = 0;
- free (x->boz.str);
-
- mpz_init (x->value.integer);
- mpz_set (x->value.integer, tmp1);
- x->ts.type = BT_INTEGER;
- x->ts.kind = kind;
- mpz_clear (tmp1);
-
- return true;
-}
-
-
-/* Make sure an expression is a scalar. */
-
-static bool
-scalar_check (gfc_expr *e, int n)
-{
- if (e->rank == 0)
- return true;
-
- gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
- gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
- &e->where);
-
- return false;
-}
-
-
-/* Check the type of an expression. */
-
-static bool
-type_check (gfc_expr *e, int n, bt type)
-{
- if (e->ts.type == type)
- return true;
-
- gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
- gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
- &e->where, gfc_basic_typename (type));
-
- return false;
-}
-
-
-/* Check that the expression is a numeric type. */
-
-static bool
-numeric_check (gfc_expr *e, int n)
-{
- /* Users sometime use a subroutine designator as an actual argument to
- an intrinsic subprogram that expects an argument with a numeric type. */
- if (e->symtree && e->symtree->n.sym->attr.subroutine)
- goto error;
-
- if (gfc_numeric_ts (&e->ts))
- return true;
-
- /* If the expression has not got a type, check if its namespace can
- offer a default type. */
- if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
- && e->symtree->n.sym->ts.type == BT_UNKNOWN
- && gfc_set_default_type (e->symtree->n.sym, 0, e->symtree->n.sym->ns)
- && gfc_numeric_ts (&e->symtree->n.sym->ts))
- {
- e->ts = e->symtree->n.sym->ts;
- return true;
- }
-
-error:
-
- gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
- gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
- &e->where);
-
- return false;
-}
-
-
-/* Check that an expression is integer or real. */
-
-static bool
-int_or_real_check (gfc_expr *e, int n)
-{
- if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
- "or REAL", gfc_current_intrinsic_arg[n]->name,
- gfc_current_intrinsic, &e->where);
- return false;
- }
-
- return true;
-}
-
-/* Check that an expression is integer or real; allow character for
- F2003 or later. */
-
-static bool
-int_or_real_or_char_check_f2003 (gfc_expr *e, int n)
-{
- if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
- {
- if (e->ts.type == BT_CHARACTER)
- return gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Character for "
- "%qs argument of %qs intrinsic at %L",
- gfc_current_intrinsic_arg[n]->name,
- gfc_current_intrinsic, &e->where);
- else
- {
- if (gfc_option.allow_std & GFC_STD_F2003)
- gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
- "or REAL or CHARACTER",
- gfc_current_intrinsic_arg[n]->name,
- gfc_current_intrinsic, &e->where);
- else
- gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
- "or REAL", gfc_current_intrinsic_arg[n]->name,
- gfc_current_intrinsic, &e->where);
- }
- return false;
- }
-
- return true;
-}
-
-/* Check that an expression is an intrinsic type. */
-static bool
-intrinsic_type_check (gfc_expr *e, int n)
-{
- if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL
- && e->ts.type != BT_COMPLEX && e->ts.type != BT_CHARACTER
- && e->ts.type != BT_LOGICAL)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be of intrinsic type",
- gfc_current_intrinsic_arg[n]->name,
- gfc_current_intrinsic, &e->where);
- return false;
- }
- return true;
-}
-
-/* Check that an expression is real or complex. */
-
-static bool
-real_or_complex_check (gfc_expr *e, int n)
-{
- if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be REAL "
- "or COMPLEX", gfc_current_intrinsic_arg[n]->name,
- gfc_current_intrinsic, &e->where);
- return false;
- }
-
- return true;
-}
-
-
-/* Check that an expression is INTEGER or PROCEDURE. */
-
-static bool
-int_or_proc_check (gfc_expr *e, int n)
-{
- if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
- "or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
- gfc_current_intrinsic, &e->where);
- return false;
- }
-
- return true;
-}
-
-
-/* Check that the expression is an optional constant integer
- and that it specifies a valid kind for that type. */
-
-static bool
-kind_check (gfc_expr *k, int n, bt type)
-{
- int kind;
-
- if (k == NULL)
- return true;
-
- if (!type_check (k, n, BT_INTEGER))
- return false;
-
- if (!scalar_check (k, n))
- return false;
-
- if (!gfc_check_init_expr (k))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
- gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
- &k->where);
- return false;
- }
-
- if (gfc_extract_int (k, &kind)
- || gfc_validate_kind (type, kind, true) < 0)
- {
- gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
- &k->where);
- return false;
- }
-
- return true;
-}
-
-
-/* Make sure the expression is a double precision real. */
-
-static bool
-double_check (gfc_expr *d, int n)
-{
- if (!type_check (d, n, BT_REAL))
- return false;
-
- if (d->ts.kind != gfc_default_double_kind)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be double "
- "precision", gfc_current_intrinsic_arg[n]->name,
- gfc_current_intrinsic, &d->where);
- return false;
- }
-
- return true;
-}
-
-
-static bool
-coarray_check (gfc_expr *e, int n)
-{
- if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
- && CLASS_DATA (e)->attr.codimension
- && CLASS_DATA (e)->as->corank)
- {
- gfc_add_class_array_ref (e);
- return true;
- }
-
- if (!gfc_is_coarray (e))
- {
- gfc_error ("Expected coarray variable as %qs argument to the %s "
- "intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
- gfc_current_intrinsic, &e->where);
- return false;
- }
-
- return true;
-}
-
-
-/* Make sure the expression is a logical array. */
-
-static bool
-logical_array_check (gfc_expr *array, int n)
-{
- if (array->ts.type != BT_LOGICAL || array->rank == 0)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be a logical "
- "array", gfc_current_intrinsic_arg[n]->name,
- gfc_current_intrinsic, &array->where);
- return false;
- }
-
- return true;
-}
-
-
-/* Make sure an expression is an array. */
-
-static bool
-array_check (gfc_expr *e, int n)
-{
- if (e->rank != 0 && e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
- && CLASS_DATA (e)->attr.dimension
- && CLASS_DATA (e)->as->rank)
- {
- gfc_add_class_array_ref (e);
- }
-
- if (e->rank != 0 && e->ts.type != BT_PROCEDURE)
- return true;
-
- gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
- gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
- &e->where);
-
- return false;
-}
-
-
-/* If expr is a constant, then check to ensure that it is greater than
- of equal to zero. */
-
-static bool
-nonnegative_check (const char *arg, gfc_expr *expr)
-{
- int i;
-
- if (expr->expr_type == EXPR_CONSTANT)
- {
- gfc_extract_int (expr, &i);
- if (i < 0)
- {
- gfc_error ("%qs at %L must be nonnegative", arg, &expr->where);
- return false;
- }
- }
-
- return true;
-}
-
-
-/* If expr is a constant, then check to ensure that it is greater than zero. */
-
-static bool
-positive_check (int n, gfc_expr *expr)
-{
- int i;
-
- if (expr->expr_type == EXPR_CONSTANT)
- {
- gfc_extract_int (expr, &i);
- if (i <= 0)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be positive",
- gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
- &expr->where);
- return false;
- }
- }
-
- return true;
-}
-
-
-/* If expr2 is constant, then check that the value is less than
- (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
-
-static bool
-less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
- gfc_expr *expr2, bool or_equal)
-{
- int i2, i3;
-
- if (expr2->expr_type == EXPR_CONSTANT)
- {
- gfc_extract_int (expr2, &i2);
- i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
-
- /* For ISHFT[C], check that |shift| <= bit_size(i). */
- if (arg2 == NULL)
- {
- if (i2 < 0)
- i2 = -i2;
-
- if (i2 > gfc_integer_kinds[i3].bit_size)
- {
- gfc_error ("The absolute value of SHIFT at %L must be less "
- "than or equal to BIT_SIZE(%qs)",
- &expr2->where, arg1);
- return false;
- }
- }
-
- if (or_equal)
- {
- if (i2 > gfc_integer_kinds[i3].bit_size)
- {
- gfc_error ("%qs at %L must be less than "
- "or equal to BIT_SIZE(%qs)",
- arg2, &expr2->where, arg1);
- return false;
- }
- }
- else
- {
- if (i2 >= gfc_integer_kinds[i3].bit_size)
- {
- gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
- arg2, &expr2->where, arg1);
- return false;
- }
- }
- }
-
- return true;
-}
-
-
-/* If expr is constant, then check that the value is less than or equal
- to the bit_size of the kind k. */
-
-static bool
-less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
-{
- int i, val;
-
- if (expr->expr_type != EXPR_CONSTANT)
- return true;
-
- i = gfc_validate_kind (BT_INTEGER, k, false);
- gfc_extract_int (expr, &val);
-
- if (val > gfc_integer_kinds[i].bit_size)
- {
- gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
- "INTEGER(KIND=%d)", arg, &expr->where, k);
- return false;
- }
-
- return true;
-}
-
-
-/* If expr2 and expr3 are constants, then check that the value is less than
- or equal to bit_size(expr1). */
-
-static bool
-less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
- gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
-{
- int i2, i3;
-
- if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
- {
- gfc_extract_int (expr2, &i2);
- gfc_extract_int (expr3, &i3);
- i2 += i3;
- i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
- if (i2 > gfc_integer_kinds[i3].bit_size)
- {
- gfc_error ("%<%s + %s%> at %L must be less than or equal "
- "to BIT_SIZE(%qs)",
- arg2, arg3, &expr2->where, arg1);
- return false;
- }
- }
-
- return true;
-}
-
-/* Make sure two expressions have the same type. */
-
-static bool
-same_type_check (gfc_expr *e, int n, gfc_expr *f, int m, bool assoc = false)
-{
- gfc_typespec *ets = &e->ts;
- gfc_typespec *fts = &f->ts;
-
- if (assoc)
- {
- /* Procedure pointer component expressions have the type of the interface
- procedure. If they are being tested for association with a procedure
- pointer (ie. not a component), the type of the procedure must be
- determined. */
- if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym)
- ets = &e->symtree->n.sym->ts;
- if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym)
- fts = &f->symtree->n.sym->ts;
- }
-
- if (gfc_compare_types (ets, fts))
- return true;
-
- gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
- "and kind as %qs", gfc_current_intrinsic_arg[m]->name,
- gfc_current_intrinsic, &f->where,
- gfc_current_intrinsic_arg[n]->name);
-
- return false;
-}
-
-
-/* Make sure that an expression has a certain (nonzero) rank. */
-
-static bool
-rank_check (gfc_expr *e, int n, int rank)
-{
- if (e->rank == rank)
- return true;
-
- gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
- gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
- &e->where, rank);
-
- return false;
-}
-
-
-/* Make sure a variable expression is not an optional dummy argument. */
-
-static bool
-nonoptional_check (gfc_expr *e, int n)
-{
- if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
- gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
- &e->where);
- }
-
- /* TODO: Recursive check on nonoptional variables? */
-
- return true;
-}
-
-
-/* Check for ALLOCATABLE attribute. */
-
-static bool
-allocatable_check (gfc_expr *e, int n)
-{
- symbol_attribute attr;
-
- attr = gfc_variable_attr (e, NULL);
- if (!attr.allocatable
- || (attr.associate_var && !attr.select_rank_temporary))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE",
- gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
- &e->where);
- return false;
- }
-
- return true;
-}
-
-
-/* Check that an expression has a particular kind. */
-
-static bool
-kind_value_check (gfc_expr *e, int n, int k)
-{
- if (e->ts.kind == k)
- return true;
-
- gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d",
- gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
- &e->where, k);
-
- return false;
-}
-
-
-/* Make sure an expression is a variable. */
-
-static bool
-variable_check (gfc_expr *e, int n, bool allow_proc)
-{
- if (e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.intent == INTENT_IN
- && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
- || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT)
- && !gfc_check_vardef_context (e, false, true, false, NULL))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L cannot be INTENT(IN)",
- gfc_current_intrinsic_arg[n]->name,
- gfc_current_intrinsic, &e->where);
- return false;
- }
-
- if (e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.flavor != FL_PARAMETER
- && (allow_proc || !e->symtree->n.sym->attr.function))
- return true;
-
- if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function
- && e->symtree->n.sym == e->symtree->n.sym->result)
- {
- gfc_namespace *ns;
- for (ns = gfc_current_ns; ns; ns = ns->parent)
- if (ns->proc_name == e->symtree->n.sym)
- return true;
- }
-
- /* F2018:R902: function reference having a data pointer result. */
- if (e->expr_type == EXPR_FUNCTION
- && e->symtree->n.sym->attr.flavor == FL_PROCEDURE
- && e->symtree->n.sym->attr.function
- && e->symtree->n.sym->attr.pointer)
- return true;
-
- gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
- gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
-
- return false;
-}
-
-
-/* Check the common DIM parameter for correctness. */
-
-static bool
-dim_check (gfc_expr *dim, int n, bool optional)
-{
- if (dim == NULL)
- return true;
-
- if (!type_check (dim, n, BT_INTEGER))
- return false;
-
- if (!scalar_check (dim, n))
- return false;
-
- if (!optional && !nonoptional_check (dim, n))
- return false;
-
- return true;
-}
-
-
-/* If a coarray DIM parameter is a constant, make sure that it is greater than
- zero and less than or equal to the corank of the given array. */
-
-static bool
-dim_corank_check (gfc_expr *dim, gfc_expr *array)
-{
- int corank;
-
- gcc_assert (array->expr_type == EXPR_VARIABLE);
-
- if (dim->expr_type != EXPR_CONSTANT)
- return true;
-
- if (array->ts.type == BT_CLASS)
- return true;
-
- corank = gfc_get_corank (array);
-
- if (mpz_cmp_ui (dim->value.integer, 1) < 0
- || mpz_cmp_ui (dim->value.integer, corank) > 0)
- {
- gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
- "codimension index", gfc_current_intrinsic, &dim->where);
-
- return false;
- }
-
- return true;
-}
-
-
-/* If a DIM parameter is a constant, make sure that it is greater than
- zero and less than or equal to the rank of the given array. If
- allow_assumed is zero then dim must be less than the rank of the array
- for assumed size arrays. */
-
-static bool
-dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
-{
- gfc_array_ref *ar;
- int rank;
-
- if (dim == NULL)
- return true;
-
- if (dim->expr_type != EXPR_CONSTANT)
- return true;
-
- if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
- && array->value.function.isym->id == GFC_ISYM_SPREAD)
- rank = array->rank + 1;
- else
- rank = array->rank;
-
- /* Assumed-rank array. */
- if (rank == -1)
- rank = GFC_MAX_DIMENSIONS;
-
- if (array->expr_type == EXPR_VARIABLE)
- {
- ar = gfc_find_array_ref (array, true);
- if (!ar)
- return false;
- if (ar->as->type == AS_ASSUMED_SIZE
- && !allow_assumed
- && ar->type != AR_ELEMENT
- && ar->type != AR_SECTION)
- rank--;
- }
-
- if (mpz_cmp_ui (dim->value.integer, 1) < 0
- || mpz_cmp_ui (dim->value.integer, rank) > 0)
- {
- gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
- "dimension index", gfc_current_intrinsic, &dim->where);
-
- return false;
- }
-
- return true;
-}
-
-
-/* Compare the size of a along dimension ai with the size of b along
- dimension bi, returning 0 if they are known not to be identical,
- and 1 if they are identical, or if this cannot be determined. */
-
-static int
-identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
-{
- mpz_t a_size, b_size;
- int ret;
-
- gcc_assert (a->rank > ai);
- gcc_assert (b->rank > bi);
-
- ret = 1;
-
- if (gfc_array_dimen_size (a, ai, &a_size))
- {
- if (gfc_array_dimen_size (b, bi, &b_size))
- {
- if (mpz_cmp (a_size, b_size) != 0)
- ret = 0;
-
- mpz_clear (b_size);
- }
- mpz_clear (a_size);
- }
- return ret;
-}
-
-/* Calculate the length of a character variable, including substrings.
- Strip away parentheses if necessary. Return -1 if no length could
- be determined. */
-
-static long
-gfc_var_strlen (const gfc_expr *a)
-{
- gfc_ref *ra;
-
- while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES)
- a = a->value.op.op1;
-
- for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next)
- ;
-
- if (ra)
- {
- long start_a, end_a;
-
- if (!ra->u.ss.end)
- return -1;
-
- if ((!ra->u.ss.start || ra->u.ss.start->expr_type == EXPR_CONSTANT)
- && ra->u.ss.end->expr_type == EXPR_CONSTANT)
- {
- start_a = ra->u.ss.start ? mpz_get_si (ra->u.ss.start->value.integer)
- : 1;
- end_a = mpz_get_si (ra->u.ss.end->value.integer);
- return (end_a < start_a) ? 0 : end_a - start_a + 1;
- }
- else if (ra->u.ss.start
- && gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
- return 1;
- else
- return -1;
- }
-
- if (a->ts.u.cl && a->ts.u.cl->length
- && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
- return mpz_get_si (a->ts.u.cl->length->value.integer);
- else if (a->expr_type == EXPR_CONSTANT
- && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
- return a->value.character.length;
- else
- return -1;
-
-}
-
-/* Check whether two character expressions have the same length;
- returns true if they have or if the length cannot be determined,
- otherwise return false and raise a gfc_error. */
-
-bool
-gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
-{
- long len_a, len_b;
-
- len_a = gfc_var_strlen(a);
- len_b = gfc_var_strlen(b);
-
- if (len_a == -1 || len_b == -1 || len_a == len_b)
- return true;
- else
- {
- gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
- len_a, len_b, name, &a->where);
- return false;
- }
-}
-
-
-/***** Check functions *****/
-
-/* Check subroutine suitable for intrinsics taking a real argument and
- a kind argument for the result. */
-
-static bool
-check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
-{
- if (!type_check (a, 0, BT_REAL))
- return false;
- if (!kind_check (kind, 1, type))
- return false;
-
- return true;
-}
-
-
-/* Check subroutine suitable for ceiling, floor and nint. */
-
-bool
-gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
-{
- return check_a_kind (a, kind, BT_INTEGER);
-}
-
-
-/* Check subroutine suitable for aint, anint. */
-
-bool
-gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
-{
- return check_a_kind (a, kind, BT_REAL);
-}
-
-
-bool
-gfc_check_abs (gfc_expr *a)
-{
- if (!numeric_check (a, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_achar (gfc_expr *a, gfc_expr *kind)
-{
- if (a->ts.type == BT_BOZ)
- {
- if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in "
- "ACHAR intrinsic subprogram"), &a->where))
- return false;
-
- if (!gfc_boz2int (a, gfc_default_integer_kind))
- return false;
- }
-
- if (!type_check (a, 0, BT_INTEGER))
- return false;
-
- if (!kind_check (kind, 1, BT_CHARACTER))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
-{
- if (!type_check (name, 0, BT_CHARACTER)
- || !scalar_check (name, 0))
- return false;
- if (!kind_value_check (name, 0, gfc_default_character_kind))
- return false;
-
- if (!type_check (mode, 1, BT_CHARACTER)
- || !scalar_check (mode, 1))
- return false;
- if (!kind_value_check (mode, 1, gfc_default_character_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
-{
- if (!logical_array_check (mask, 0))
- return false;
-
- if (!dim_check (dim, 1, false))
- return false;
-
- if (!dim_rank_check (dim, mask, 0))
- return false;
-
- return true;
-}
-
-
-/* Limited checking for ALLOCATED intrinsic. Additional checking
- is performed in intrinsic.c(sort_actual), because ALLOCATED
- has two mutually exclusive non-optional arguments. */
-
-bool
-gfc_check_allocated (gfc_expr *array)
-{
- /* Tests on allocated components of coarrays need to detour the check to
- argument of the _caf_get. */
- if (flag_coarray == GFC_FCOARRAY_LIB && array->expr_type == EXPR_FUNCTION
- && array->value.function.isym
- && array->value.function.isym->id == GFC_ISYM_CAF_GET)
- {
- array = array->value.function.actual->expr;
- if (!array->ref)
- return false;
- }
-
- if (!variable_check (array, 0, false))
- return false;
- if (!allocatable_check (array, 0))
- return false;
-
- return true;
-}
-
-
-/* Common check function where the first argument must be real or
- integer and the second argument must be the same as the first. */
-
-bool
-gfc_check_a_p (gfc_expr *a, gfc_expr *p)
-{
- if (!int_or_real_check (a, 0))
- return false;
-
- if (a->ts.type != p->ts.type)
- {
- gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
- "have the same type", gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &p->where);
- return false;
- }
-
- if (a->ts.kind != p->ts.kind)
- {
- if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
- &p->where))
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
-{
- if (!double_check (x, 0) || !double_check (y, 1))
- return false;
-
- return true;
-}
-
-bool
-gfc_invalid_null_arg (gfc_expr *x)
-{
- if (x->expr_type == EXPR_NULL)
- {
- gfc_error ("NULL at %L is not permitted as actual argument "
- "to %qs intrinsic function", &x->where,
- gfc_current_intrinsic);
- return true;
- }
- return false;
-}
-
-bool
-gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
-{
- symbol_attribute attr1, attr2;
- int i;
- bool t;
-
- if (gfc_invalid_null_arg (pointer))
- return false;
-
- attr1 = gfc_expr_attr (pointer);
-
- if (!attr1.pointer && !attr1.proc_pointer)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &pointer->where);
- return false;
- }
-
- /* F2008, C1242. */
- if (attr1.pointer && gfc_is_coindexed (pointer))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
- "coindexed", gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &pointer->where);
- return false;
- }
-
- /* Target argument is optional. */
- if (target == NULL)
- return true;
-
- if (gfc_invalid_null_arg (target))
- return false;
-
- if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
- attr2 = gfc_expr_attr (target);
- else
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
- "or target VARIABLE or FUNCTION",
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &target->where);
- return false;
- }
-
- if (attr1.pointer && !attr2.pointer && !attr2.target)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
- "or a TARGET", gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic, &target->where);
- return false;
- }
-
- /* F2008, C1242. */
- if (attr1.pointer && gfc_is_coindexed (target))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
- "coindexed", gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic, &target->where);
- return false;
- }
-
- t = true;
- if (!same_type_check (pointer, 0, target, 1, true))
- t = false;
- /* F2018 C838 explicitly allows an assumed-rank variable as the first
- argument of intrinsic inquiry functions. */
- if (pointer->rank != -1 && !rank_check (target, 0, pointer->rank))
- t = false;
- if (target->rank > 0)
- {
- for (i = 0; i < target->rank; i++)
- if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
- {
- gfc_error ("Array section with a vector subscript at %L shall not "
- "be the target of a pointer",
- &target->where);
- t = false;
- break;
- }
- }
- return t;
-}
-
-
-bool
-gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
-{
- /* gfc_notify_std would be a waste of time as the return value
- is seemingly used only for the generic resolution. The error
- will be: Too many arguments. */
- if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
- return false;
-
- return gfc_check_atan2 (y, x);
-}
-
-
-bool
-gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
-{
- if (!type_check (y, 0, BT_REAL))
- return false;
- if (!same_type_check (y, 0, x, 1))
- return false;
-
- return true;
-}
-
-
-static bool
-gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no,
- gfc_expr *stat, int stat_no)
-{
- if (!scalar_check (atom, atom_no) || !scalar_check (value, val_no))
- return false;
-
- if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
- && !(atom->ts.type == BT_LOGICAL
- && atom->ts.kind == gfc_atomic_logical_kind))
- {
- gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
- "integer of ATOMIC_INT_KIND or a logical of "
- "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic);
- return false;
- }
-
- if (!gfc_is_coarray (atom) && !gfc_is_coindexed (atom))
- {
- gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
- "coarray or coindexed", &atom->where, gfc_current_intrinsic);
- return false;
- }
-
- if (atom->ts.type != value->ts.type)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
- "type as %qs at %L", gfc_current_intrinsic_arg[val_no]->name,
- gfc_current_intrinsic, &value->where,
- gfc_current_intrinsic_arg[atom_no]->name, &atom->where);
- return false;
- }
-
- if (stat != NULL)
- {
- if (!type_check (stat, stat_no, BT_INTEGER))
- return false;
- if (!scalar_check (stat, stat_no))
- return false;
- if (!variable_check (stat, stat_no, false))
- return false;
- if (!kind_value_check (stat, stat_no, gfc_default_integer_kind))
- return false;
-
- if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L",
- gfc_current_intrinsic, &stat->where))
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value, gfc_expr *stat)
-{
- if (atom->expr_type == EXPR_FUNCTION
- && atom->value.function.isym
- && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
- atom = atom->value.function.actual->expr;
-
- if (!gfc_check_vardef_context (atom, false, false, false, NULL))
- {
- gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
- "definable", gfc_current_intrinsic, &atom->where);
- return false;
- }
-
- return gfc_check_atomic (atom, 0, value, 1, stat, 2);
-}
-
-
-bool
-gfc_check_atomic_op (gfc_expr *atom, gfc_expr *value, gfc_expr *stat)
-{
- if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind)
- {
- gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
- "integer of ATOMIC_INT_KIND", &atom->where,
- gfc_current_intrinsic);
- return false;
- }
-
- return gfc_check_atomic_def (atom, value, stat);
-}
-
-
-bool
-gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat)
-{
- if (atom->expr_type == EXPR_FUNCTION
- && atom->value.function.isym
- && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
- atom = atom->value.function.actual->expr;
-
- if (!gfc_check_vardef_context (value, false, false, false, NULL))
- {
- gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
- "definable", gfc_current_intrinsic, &value->where);
- return false;
- }
-
- return gfc_check_atomic (atom, 1, value, 0, stat, 2);
-}
-
-
-bool
-gfc_check_image_status (gfc_expr *image, gfc_expr *team)
-{
- /* IMAGE has to be a positive, scalar integer. */
- if (!type_check (image, 0, BT_INTEGER) || !scalar_check (image, 0)
- || !positive_check (0, image))
- return false;
-
- if (team)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &team->where);
- return false;
- }
- return true;
-}
-
-
-bool
-gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind)
-{
- if (team)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &team->where);
- return false;
- }
-
- if (kind)
- {
- int k;
-
- if (!type_check (kind, 1, BT_INTEGER) || !scalar_check (kind, 1)
- || !positive_check (1, kind))
- return false;
-
- /* Get the kind, reporting error on non-constant or overflow. */
- gfc_current_locus = kind->where;
- if (gfc_extract_int (kind, &k, 1))
- return false;
- if (gfc_validate_kind (BT_INTEGER, k, true) == -1)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L shall specify a "
- "valid integer kind", gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic, &kind->where);
- return false;
- }
- }
- return true;
-}
-
-
-bool
-gfc_check_get_team (gfc_expr *level)
-{
- if (level)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &level->where);
- return false;
- }
- return true;
-}
-
-
-bool
-gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare,
- gfc_expr *new_val, gfc_expr *stat)
-{
- if (atom->expr_type == EXPR_FUNCTION
- && atom->value.function.isym
- && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
- atom = atom->value.function.actual->expr;
-
- if (!gfc_check_atomic (atom, 0, new_val, 3, stat, 4))
- return false;
-
- if (!scalar_check (old, 1) || !scalar_check (compare, 2))
- return false;
-
- if (!same_type_check (atom, 0, old, 1))
- return false;
-
- if (!same_type_check (atom, 0, compare, 2))
- return false;
-
- if (!gfc_check_vardef_context (atom, false, false, false, NULL))
- {
- gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
- "definable", gfc_current_intrinsic, &atom->where);
- return false;
- }
-
- if (!gfc_check_vardef_context (old, false, false, false, NULL))
- {
- gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
- "definable", gfc_current_intrinsic, &old->where);
- return false;
- }
-
- return true;
-}
-
-bool
-gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat)
-{
- if (event->ts.type != BT_DERIVED
- || event->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
- || event->ts.u.derived->intmod_sym_id != ISOFORTRAN_EVENT_TYPE)
- {
- gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
- "shall be of type EVENT_TYPE", &event->where);
- return false;
- }
-
- if (!scalar_check (event, 0))
- return false;
-
- if (!gfc_check_vardef_context (count, false, false, false, NULL))
- {
- gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
- "shall be definable", &count->where);
- return false;
- }
-
- if (!type_check (count, 1, BT_INTEGER))
- return false;
-
- int i = gfc_validate_kind (BT_INTEGER, count->ts.kind, false);
- int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
-
- if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range)
- {
- gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
- "shall have at least the range of the default integer",
- &count->where);
- return false;
- }
-
- if (stat != NULL)
- {
- if (!type_check (stat, 2, BT_INTEGER))
- return false;
- if (!scalar_check (stat, 2))
- return false;
- if (!variable_check (stat, 2, false))
- return false;
-
- if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L",
- gfc_current_intrinsic, &stat->where))
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old,
- gfc_expr *stat)
-{
- if (atom->expr_type == EXPR_FUNCTION
- && atom->value.function.isym
- && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
- atom = atom->value.function.actual->expr;
-
- if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind)
- {
- gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
- "integer of ATOMIC_INT_KIND", &atom->where,
- gfc_current_intrinsic);
- return false;
- }
-
- if (!gfc_check_atomic (atom, 0, value, 1, stat, 3))
- return false;
-
- if (!scalar_check (old, 2))
- return false;
-
- if (!same_type_check (atom, 0, old, 2))
- return false;
-
- if (!gfc_check_vardef_context (atom, false, false, false, NULL))
- {
- gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
- "definable", gfc_current_intrinsic, &atom->where);
- return false;
- }
-
- if (!gfc_check_vardef_context (old, false, false, false, NULL))
- {
- gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
- "definable", gfc_current_intrinsic, &old->where);
- return false;
- }
-
- return true;
-}
-
-
-/* BESJN and BESYN functions. */
-
-bool
-gfc_check_besn (gfc_expr *n, gfc_expr *x)
-{
- if (!type_check (n, 0, BT_INTEGER))
- return false;
- if (n->expr_type == EXPR_CONSTANT)
- {
- int i;
- gfc_extract_int (n, &i);
- if (i < 0 && !gfc_notify_std (GFC_STD_GNU, "Negative argument "
- "N at %L", &n->where))
- return false;
- }
-
- if (!type_check (x, 1, BT_REAL))
- return false;
-
- return true;
-}
-
-
-/* Transformational version of the Bessel JN and YN functions. */
-
-bool
-gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
-{
- if (!type_check (n1, 0, BT_INTEGER))
- return false;
- if (!scalar_check (n1, 0))
- return false;
- if (!nonnegative_check ("N1", n1))
- return false;
-
- if (!type_check (n2, 1, BT_INTEGER))
- return false;
- if (!scalar_check (n2, 1))
- return false;
- if (!nonnegative_check ("N2", n2))
- return false;
-
- if (!type_check (x, 2, BT_REAL))
- return false;
- if (!scalar_check (x, 2))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
-{
- extern int gfc_max_integer_kind;
-
- /* If i and j are both BOZ, convert to widest INTEGER. */
- if (i->ts.type == BT_BOZ && j->ts.type == BT_BOZ)
- {
- if (!gfc_boz2int (i, gfc_max_integer_kind))
- return false;
- if (!gfc_boz2int (j, gfc_max_integer_kind))
- return false;
- }
-
- /* If i is BOZ and j is integer, convert i to type of j. */
- if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
- && !gfc_boz2int (i, j->ts.kind))
- return false;
-
- /* If j is BOZ and i is integer, convert j to type of i. */
- if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
- && !gfc_boz2int (j, i->ts.kind))
- return false;
-
- if (!type_check (i, 0, BT_INTEGER))
- return false;
-
- if (!type_check (j, 1, BT_INTEGER))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
-{
- if (!type_check (i, 0, BT_INTEGER))
- return false;
-
- if (!type_check (pos, 1, BT_INTEGER))
- return false;
-
- if (!nonnegative_check ("pos", pos))
- return false;
-
- if (!less_than_bitsize1 ("i", i, "pos", pos, false))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_char (gfc_expr *i, gfc_expr *kind)
-{
- if (i->ts.type == BT_BOZ)
- {
- if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in "
- "CHAR intrinsic subprogram"), &i->where))
- return false;
-
- if (!gfc_boz2int (i, gfc_default_integer_kind))
- return false;
- }
-
- if (!type_check (i, 0, BT_INTEGER))
- return false;
-
- if (!kind_check (kind, 1, BT_CHARACTER))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_chdir (gfc_expr *dir)
-{
- if (!type_check (dir, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (dir, 0, gfc_default_character_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
-{
- if (!type_check (dir, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (dir, 0, gfc_default_character_kind))
- return false;
-
- if (status == NULL)
- return true;
-
- if (!type_check (status, 1, BT_INTEGER))
- return false;
- if (!scalar_check (status, 1))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
-{
- if (!type_check (name, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (name, 0, gfc_default_character_kind))
- return false;
-
- if (!type_check (mode, 1, BT_CHARACTER))
- return false;
- if (!kind_value_check (mode, 1, gfc_default_character_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
-{
- if (!type_check (name, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (name, 0, gfc_default_character_kind))
- return false;
-
- if (!type_check (mode, 1, BT_CHARACTER))
- return false;
- if (!kind_value_check (mode, 1, gfc_default_character_kind))
- return false;
-
- if (status == NULL)
- return true;
-
- if (!type_check (status, 2, BT_INTEGER))
- return false;
-
- if (!scalar_check (status, 2))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
-{
- int k;
-
- /* Check kind first, because it may be needed in conversion of a BOZ. */
- if (kind)
- {
- if (!kind_check (kind, 2, BT_COMPLEX))
- return false;
- gfc_extract_int (kind, &k);
- }
- else
- k = gfc_default_complex_kind;
-
- if (x->ts.type == BT_BOZ && !gfc_boz2real (x, k))
- return false;
-
- if (!numeric_check (x, 0))
- return false;
-
- if (y != NULL)
- {
- if (y->ts.type == BT_BOZ && !gfc_boz2real (y, k))
- return false;
-
- if (!numeric_check (y, 1))
- return false;
-
- if (x->ts.type == BT_COMPLEX)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must not be "
- "present if %<x%> is COMPLEX",
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &y->where);
- return false;
- }
-
- if (y->ts.type == BT_COMPLEX)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
- "of either REAL or INTEGER",
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &y->where);
- return false;
- }
- }
-
- if (!kind && warn_conversion
- && x->ts.type == BT_REAL && x->ts.kind > gfc_default_real_kind)
- gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind "
- "COMPLEX(%d) at %L might lose precision, consider using "
- "the KIND argument", gfc_typename (&x->ts),
- gfc_default_real_kind, &x->where);
- else if (y && !kind && warn_conversion
- && y->ts.type == BT_REAL && y->ts.kind > gfc_default_real_kind)
- gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind "
- "COMPLEX(%d) at %L might lose precision, consider using "
- "the KIND argument", gfc_typename (&y->ts),
- gfc_default_real_kind, &y->where);
- return true;
-}
-
-
-static bool
-check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat,
- gfc_expr *errmsg, bool co_reduce)
-{
- if (!variable_check (a, 0, false))
- return false;
-
- if (!gfc_check_vardef_context (a, false, false, false, "argument 'A' with "
- "INTENT(INOUT)"))
- return false;
-
- /* Fortran 2008, 12.5.2.4, paragraph 18. */
- if (gfc_has_vector_subscript (a))
- {
- gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
- "subroutine %s shall not have a vector subscript",
- &a->where, gfc_current_intrinsic);
- return false;
- }
-
- if (gfc_is_coindexed (a))
- {
- gfc_error ("The A argument at %L to the intrinsic %s shall not be "
- "coindexed", &a->where, gfc_current_intrinsic);
- return false;
- }
-
- if (image_idx != NULL)
- {
- if (!type_check (image_idx, co_reduce ? 2 : 1, BT_INTEGER))
- return false;
- if (!scalar_check (image_idx, co_reduce ? 2 : 1))
- return false;
- }
-
- if (stat != NULL)
- {
- if (!type_check (stat, co_reduce ? 3 : 2, BT_INTEGER))
- return false;
- if (!scalar_check (stat, co_reduce ? 3 : 2))
- return false;
- if (!variable_check (stat, co_reduce ? 3 : 2, false))
- return false;
- if (stat->ts.kind != 4)
- {
- gfc_error ("The stat= argument at %L must be a kind=4 integer "
- "variable", &stat->where);
- return false;
- }
- }
-
- if (errmsg != NULL)
- {
- if (!type_check (errmsg, co_reduce ? 4 : 3, BT_CHARACTER))
- return false;
- if (!scalar_check (errmsg, co_reduce ? 4 : 3))
- return false;
- if (!variable_check (errmsg, co_reduce ? 4 : 3, false))
- return false;
- if (errmsg->ts.kind != 1)
- {
- gfc_error ("The errmsg= argument at %L must be a default-kind "
- "character variable", &errmsg->where);
- return false;
- }
- }
-
- if (flag_coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
- &a->where);
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat,
- gfc_expr *errmsg)
-{
- if (a->ts.type == BT_CLASS || gfc_expr_attr (a).alloc_comp)
- {
- gfc_error ("Support for the A argument at %L which is polymorphic A "
- "argument or has allocatable components is not yet "
- "implemented", &a->where);
- return false;
- }
- return check_co_collective (a, source_image, stat, errmsg, false);
-}
-
-
-bool
-gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
- gfc_expr *stat, gfc_expr *errmsg)
-{
- symbol_attribute attr;
- gfc_formal_arglist *formal;
- gfc_symbol *sym;
-
- if (a->ts.type == BT_CLASS)
- {
- gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
- &a->where);
- return false;
- }
-
- if (gfc_expr_attr (a).alloc_comp)
- {
- gfc_error ("Support for the A argument at %L with allocatable components"
- " is not yet implemented", &a->where);
- return false;
- }
-
- if (!check_co_collective (a, result_image, stat, errmsg, true))
- return false;
-
- if (!gfc_resolve_expr (op))
- return false;
-
- attr = gfc_expr_attr (op);
- if (!attr.pure || !attr.function)
- {
- gfc_error ("OPERATION argument at %L must be a PURE function",
- &op->where);
- return false;
- }
-
- if (attr.intrinsic)
- {
- /* None of the intrinsics fulfills the criteria of taking two arguments,
- returning the same type and kind as the arguments and being permitted
- as actual argument. */
- gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
- op->symtree->n.sym->name, &op->where);
- return false;
- }
-
- if (gfc_is_proc_ptr_comp (op))
- {
- gfc_component *comp = gfc_get_proc_ptr_comp (op);
- sym = comp->ts.interface;
- }
- else
- sym = op->symtree->n.sym;
-
- formal = sym->formal;
-
- if (!formal || !formal->next || formal->next->next)
- {
- gfc_error ("The function passed as OPERATION at %L shall have two "
- "arguments", &op->where);
- return false;
- }
-
- if (sym->result->ts.type == BT_UNKNOWN)
- gfc_set_default_type (sym->result, 0, NULL);
-
- if (!gfc_compare_types (&a->ts, &sym->result->ts))
- {
- gfc_error ("The A argument at %L has type %s but the function passed as "
- "OPERATION at %L returns %s",
- &a->where, gfc_typename (a), &op->where,
- gfc_typename (&sym->result->ts));
- return false;
- }
- if (!gfc_compare_types (&a->ts, &formal->sym->ts)
- || !gfc_compare_types (&a->ts, &formal->next->sym->ts))
- {
- gfc_error ("The function passed as OPERATION at %L has arguments of type "
- "%s and %s but shall have type %s", &op->where,
- gfc_typename (&formal->sym->ts),
- gfc_typename (&formal->next->sym->ts), gfc_typename (a));
- return false;
- }
- if (op->rank || attr.allocatable || attr.pointer || formal->sym->as
- || formal->next->sym->as || formal->sym->attr.allocatable
- || formal->next->sym->attr.allocatable || formal->sym->attr.pointer
- || formal->next->sym->attr.pointer)
- {
- gfc_error ("The function passed as OPERATION at %L shall have scalar "
- "nonallocatable nonpointer arguments and return a "
- "nonallocatable nonpointer scalar", &op->where);
- return false;
- }
-
- if (formal->sym->attr.value != formal->next->sym->attr.value)
- {
- gfc_error ("The function passed as OPERATION at %L shall have the VALUE "
- "attribute either for none or both arguments", &op->where);
- return false;
- }
-
- if (formal->sym->attr.target != formal->next->sym->attr.target)
- {
- gfc_error ("The function passed as OPERATION at %L shall have the TARGET "
- "attribute either for none or both arguments", &op->where);
- return false;
- }
-
- if (formal->sym->attr.asynchronous != formal->next->sym->attr.asynchronous)
- {
- gfc_error ("The function passed as OPERATION at %L shall have the "
- "ASYNCHRONOUS attribute either for none or both arguments",
- &op->where);
- return false;
- }
-
- if (formal->sym->attr.optional || formal->next->sym->attr.optional)
- {
- gfc_error ("The function passed as OPERATION at %L shall not have the "
- "OPTIONAL attribute for either of the arguments", &op->where);
- return false;
- }
-
- if (a->ts.type == BT_CHARACTER)
- {
- gfc_charlen *cl;
- unsigned long actual_size, formal_size1, formal_size2, result_size;
-
- cl = a->ts.u.cl;
- actual_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
- ? mpz_get_ui (cl->length->value.integer) : 0;
-
- cl = formal->sym->ts.u.cl;
- formal_size1 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
- ? mpz_get_ui (cl->length->value.integer) : 0;
-
- cl = formal->next->sym->ts.u.cl;
- formal_size2 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
- ? mpz_get_ui (cl->length->value.integer) : 0;
-
- cl = sym->ts.u.cl;
- result_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
- ? mpz_get_ui (cl->length->value.integer) : 0;
-
- if (actual_size
- && ((formal_size1 && actual_size != formal_size1)
- || (formal_size2 && actual_size != formal_size2)))
- {
- gfc_error ("The character length of the A argument at %L and of the "
- "arguments of the OPERATION at %L shall be the same",
- &a->where, &op->where);
- return false;
- }
- if (actual_size && result_size && actual_size != result_size)
- {
- gfc_error ("The character length of the A argument at %L and of the "
- "function result of the OPERATION at %L shall be the same",
- &a->where, &op->where);
- return false;
- }
- }
-
- return true;
-}
-
-
-bool
-gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
- gfc_expr *errmsg)
-{
- if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL
- && a->ts.type != BT_CHARACTER)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
- "integer, real or character",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &a->where);
- return false;
- }
- return check_co_collective (a, result_image, stat, errmsg, false);
-}
-
-
-bool
-gfc_check_co_sum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
- gfc_expr *errmsg)
-{
- if (!numeric_check (a, 0))
- return false;
- return check_co_collective (a, result_image, stat, errmsg, false);
-}
-
-
-bool
-gfc_check_complex (gfc_expr *x, gfc_expr *y)
-{
- if (!boz_args_check (x, y))
- return false;
-
- if (x->ts.type == BT_BOZ)
- {
- if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX"
- " intrinsic subprogram"), &x->where))
- {
- reset_boz (x);
- return false;
- }
- if (y->ts.type == BT_INTEGER && !gfc_boz2int (x, y->ts.kind))
- return false;
- if (y->ts.type == BT_REAL && !gfc_boz2real (x, y->ts.kind))
- return false;
- }
-
- if (y->ts.type == BT_BOZ)
- {
- if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX"
- " intrinsic subprogram"), &y->where))
- {
- reset_boz (y);
- return false;
- }
- if (x->ts.type == BT_INTEGER && !gfc_boz2int (y, x->ts.kind))
- return false;
- if (x->ts.type == BT_REAL && !gfc_boz2real (y, x->ts.kind))
- return false;
- }
-
- if (!int_or_real_check (x, 0))
- return false;
- if (!scalar_check (x, 0))
- return false;
-
- if (!int_or_real_check (y, 1))
- return false;
- if (!scalar_check (y, 1))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
-{
- if (!logical_array_check (mask, 0))
- return false;
- if (!dim_check (dim, 1, false))
- return false;
- if (!dim_rank_check (dim, mask, 0))
- return false;
- if (!kind_check (kind, 2, BT_INTEGER))
- return false;
- if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
- gfc_current_intrinsic, &kind->where))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
-{
- if (!array_check (array, 0))
- return false;
-
- if (!type_check (shift, 1, BT_INTEGER))
- return false;
-
- if (!dim_check (dim, 2, true))
- return false;
-
- if (!dim_rank_check (dim, array, false))
- return false;
-
- if (array->rank == 1 || shift->rank == 0)
- {
- if (!scalar_check (shift, 1))
- return false;
- }
- else if (shift->rank == array->rank - 1)
- {
- int d;
- if (!dim)
- d = 1;
- else if (dim->expr_type == EXPR_CONSTANT)
- gfc_extract_int (dim, &d);
- else
- d = -1;
-
- if (d > 0)
- {
- int i, j;
- for (i = 0, j = 0; i < array->rank; i++)
- if (i != d - 1)
- {
- if (!identical_dimen_shape (array, i, shift, j))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L has "
- "invalid shape in dimension %d (%ld/%ld)",
- gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic, &shift->where, i + 1,
- mpz_get_si (array->shape[i]),
- mpz_get_si (shift->shape[j]));
- return false;
- }
-
- j += 1;
- }
- }
- }
- else
- {
- gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
- "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic, &shift->where, array->rank - 1);
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_ctime (gfc_expr *time)
-{
- if (!scalar_check (time, 0))
- return false;
-
- if (!type_check (time, 0, BT_INTEGER))
- return false;
-
- return true;
-}
-
-
-bool gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
-{
- if (!double_check (y, 0) || !double_check (x, 1))
- return false;
-
- return true;
-}
-
-bool
-gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
-{
- if (x->ts.type == BT_BOZ && !gfc_boz2real (x, gfc_default_double_kind))
- return false;
-
- if (!numeric_check (x, 0))
- return false;
-
- if (y != NULL)
- {
- if (y->ts.type == BT_BOZ && !gfc_boz2real (y, gfc_default_double_kind))
- return false;
-
- if (!numeric_check (y, 1))
- return false;
-
- if (x->ts.type == BT_COMPLEX)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must not be "
- "present if %<x%> is COMPLEX",
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &y->where);
- return false;
- }
-
- if (y->ts.type == BT_COMPLEX)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
- "of either REAL or INTEGER",
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &y->where);
- return false;
- }
- }
-
- return true;
-}
-
-
-bool
-gfc_check_dble (gfc_expr *x)
-{
- if (x->ts.type == BT_BOZ && !gfc_boz2real (x, gfc_default_double_kind))
- return false;
-
- if (!numeric_check (x, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_digits (gfc_expr *x)
-{
- if (!int_or_real_check (x, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
-{
- switch (vector_a->ts.type)
- {
- case BT_LOGICAL:
- if (!type_check (vector_b, 1, BT_LOGICAL))
- return false;
- break;
-
- case BT_INTEGER:
- case BT_REAL:
- case BT_COMPLEX:
- if (!numeric_check (vector_b, 1))
- return false;
- break;
-
- default:
- gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
- "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &vector_a->where);
- return false;
- }
-
- if (!rank_check (vector_a, 0, 1))
- return false;
-
- if (!rank_check (vector_b, 1, 1))
- return false;
-
- if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
- {
- gfc_error ("Different shape for arguments %qs and %qs at %L for "
- "intrinsic %<dot_product%>",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[1]->name, &vector_a->where);
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_dprod (gfc_expr *x, gfc_expr *y)
-{
- if (!type_check (x, 0, BT_REAL)
- || !type_check (y, 1, BT_REAL))
- return false;
-
- if (x->ts.kind != gfc_default_real_kind)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be default "
- "real", gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &x->where);
- return false;
- }
-
- if (y->ts.kind != gfc_default_real_kind)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be default "
- "real", gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic, &y->where);
- return false;
- }
-
- return true;
-}
-
-bool
-gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
-{
- /* i and j cannot both be BOZ literal constants. */
- if (!boz_args_check (i, j))
- return false;
-
- /* If i is BOZ and j is integer, convert i to type of j. If j is not
- an integer, clear the BOZ; otherwise, check that i is an integer. */
- if (i->ts.type == BT_BOZ)
- {
- if (j->ts.type != BT_INTEGER)
- reset_boz (i);
- else if (!gfc_boz2int (i, j->ts.kind))
- return false;
- }
- else if (!type_check (i, 0, BT_INTEGER))
- {
- if (j->ts.type == BT_BOZ)
- reset_boz (j);
- return false;
- }
-
- /* If j is BOZ and i is integer, convert j to type of i. If i is not
- an integer, clear the BOZ; otherwise, check that i is an integer. */
- if (j->ts.type == BT_BOZ)
- {
- if (i->ts.type != BT_INTEGER)
- reset_boz (j);
- else if (!gfc_boz2int (j, i->ts.kind))
- return false;
- }
- else if (!type_check (j, 1, BT_INTEGER))
- return false;
-
- if (!same_type_check (i, 0, j, 1))
- return false;
-
- if (!type_check (shift, 2, BT_INTEGER))
- return false;
-
- if (!nonnegative_check ("SHIFT", shift))
- return false;
-
- if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
- gfc_expr *dim)
-{
- int d;
-
- if (!array_check (array, 0))
- return false;
-
- if (!type_check (shift, 1, BT_INTEGER))
- return false;
-
- if (!dim_check (dim, 3, true))
- return false;
-
- if (!dim_rank_check (dim, array, false))
- return false;
-
- if (!dim)
- d = 1;
- else if (dim->expr_type == EXPR_CONSTANT)
- gfc_extract_int (dim, &d);
- else
- d = -1;
-
- if (array->rank == 1 || shift->rank == 0)
- {
- if (!scalar_check (shift, 1))
- return false;
- }
- else if (shift->rank == array->rank - 1)
- {
- if (d > 0)
- {
- int i, j;
- for (i = 0, j = 0; i < array->rank; i++)
- if (i != d - 1)
- {
- if (!identical_dimen_shape (array, i, shift, j))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L has "
- "invalid shape in dimension %d (%ld/%ld)",
- gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic, &shift->where, i + 1,
- mpz_get_si (array->shape[i]),
- mpz_get_si (shift->shape[j]));
- return false;
- }
-
- j += 1;
- }
- }
- }
- else
- {
- gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
- "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic, &shift->where, array->rank - 1);
- return false;
- }
-
- if (boundary != NULL)
- {
- if (!same_type_check (array, 0, boundary, 2))
- return false;
-
- /* Reject unequal string lengths and emit a better error message than
- gfc_check_same_strlen would. */
- if (array->ts.type == BT_CHARACTER)
- {
- ssize_t len_a, len_b;
-
- len_a = gfc_var_strlen (array);
- len_b = gfc_var_strlen (boundary);
- if (len_a != -1 && len_b != -1 && len_a != len_b)
- {
- gfc_error ("%qs must be of same type and kind as %qs at %L in %qs",
- gfc_current_intrinsic_arg[2]->name,
- gfc_current_intrinsic_arg[0]->name,
- &boundary->where, gfc_current_intrinsic);
- return false;
- }
- }
-
- if (array->rank == 1 || boundary->rank == 0)
- {
- if (!scalar_check (boundary, 2))
- return false;
- }
- else if (boundary->rank == array->rank - 1)
- {
- if (d > 0)
- {
- int i,j;
- for (i = 0, j = 0; i < array->rank; i++)
- {
- if (i != d - 1)
- {
- if (!identical_dimen_shape (array, i, boundary, j))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L has "
- "invalid shape in dimension %d (%ld/%ld)",
- gfc_current_intrinsic_arg[2]->name,
- gfc_current_intrinsic, &shift->where, i+1,
- mpz_get_si (array->shape[i]),
- mpz_get_si (boundary->shape[j]));
- return false;
- }
- j += 1;
- }
- }
- }
- }
- else
- {
- gfc_error ("%qs argument of intrinsic %qs at %L of must have "
- "rank %d or be a scalar",
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &shift->where, array->rank - 1);
- return false;
- }
- }
- else
- {
- switch (array->ts.type)
- {
- case BT_INTEGER:
- case BT_LOGICAL:
- case BT_REAL:
- case BT_COMPLEX:
- case BT_CHARACTER:
- break;
-
- default:
- gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs "
- "of type %qs", gfc_current_intrinsic_arg[2]->name,
- gfc_current_intrinsic, &array->where,
- gfc_current_intrinsic_arg[0]->name,
- gfc_typename (array));
- return false;
- }
- }
-
- return true;
-}
-
-
-bool
-gfc_check_float (gfc_expr *a)
-{
- if (a->ts.type == BT_BOZ)
- {
- if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in the"
- " FLOAT intrinsic subprogram"), &a->where))
- {
- reset_boz (a);
- return false;
- }
- if (!gfc_boz2int (a, gfc_default_integer_kind))
- return false;
- }
-
- if (!type_check (a, 0, BT_INTEGER))
- return false;
-
- if ((a->ts.kind != gfc_default_integer_kind)
- && !gfc_notify_std (GFC_STD_GNU, "non-default INTEGER "
- "kind argument to %s intrinsic at %L",
- gfc_current_intrinsic, &a->where))
- return false;
-
- return true;
-}
-
-/* A single complex argument. */
-
-bool
-gfc_check_fn_c (gfc_expr *a)
-{
- if (!type_check (a, 0, BT_COMPLEX))
- return false;
-
- return true;
-}
-
-
-/* A single real argument. */
-
-bool
-gfc_check_fn_r (gfc_expr *a)
-{
- if (!type_check (a, 0, BT_REAL))
- return false;
-
- return true;
-}
-
-/* A single double argument. */
-
-bool
-gfc_check_fn_d (gfc_expr *a)
-{
- if (!double_check (a, 0))
- return false;
-
- return true;
-}
-
-/* A single real or complex argument. */
-
-bool
-gfc_check_fn_rc (gfc_expr *a)
-{
- if (!real_or_complex_check (a, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_fn_rc2008 (gfc_expr *a)
-{
- if (!real_or_complex_check (a, 0))
- return false;
-
- if (a->ts.type == BT_COMPLEX
- && !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument %qs "
- "of %qs intrinsic at %L",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &a->where))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_fnum (gfc_expr *unit)
-{
- if (!type_check (unit, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (unit, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_huge (gfc_expr *x)
-{
- if (!int_or_real_check (x, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_hypot (gfc_expr *x, gfc_expr *y)
-{
- if (!type_check (x, 0, BT_REAL))
- return false;
- if (!same_type_check (x, 0, y, 1))
- return false;
-
- return true;
-}
-
-
-/* Check that the single argument is an integer. */
-
-bool
-gfc_check_i (gfc_expr *i)
-{
- if (!type_check (i, 0, BT_INTEGER))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
-{
- /* i and j cannot both be BOZ literal constants. */
- if (!boz_args_check (i, j))
- return false;
-
- /* If i is BOZ and j is integer, convert i to type of j. */
- if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
- && !gfc_boz2int (i, j->ts.kind))
- return false;
-
- /* If j is BOZ and i is integer, convert j to type of i. */
- if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
- && !gfc_boz2int (j, i->ts.kind))
- return false;
-
- if (!type_check (i, 0, BT_INTEGER))
- return false;
-
- if (!type_check (j, 1, BT_INTEGER))
- return false;
-
- if (i->ts.kind != j->ts.kind)
- {
- gfc_error ("Arguments of %qs have different kind type parameters "
- "at %L", gfc_current_intrinsic, &i->where);
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
-{
- if (!type_check (i, 0, BT_INTEGER))
- return false;
-
- if (!type_check (pos, 1, BT_INTEGER))
- return false;
-
- if (!type_check (len, 2, BT_INTEGER))
- return false;
-
- if (!nonnegative_check ("pos", pos))
- return false;
-
- if (!nonnegative_check ("len", len))
- return false;
-
- if (!less_than_bitsize2 ("i", i, "pos", pos, "len", len))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
-{
- int i;
-
- if (!type_check (c, 0, BT_CHARACTER))
- return false;
-
- if (!kind_check (kind, 1, BT_INTEGER))
- return false;
-
- if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
- gfc_current_intrinsic, &kind->where))
- return false;
-
- if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
- {
- gfc_expr *start;
- gfc_expr *end;
- gfc_ref *ref;
-
- /* Substring references don't have the charlength set. */
- ref = c->ref;
- while (ref && ref->type != REF_SUBSTRING)
- ref = ref->next;
-
- gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
-
- if (!ref)
- {
- /* Check that the argument is length one. Non-constant lengths
- can't be checked here, so assume they are ok. */
- if (c->ts.u.cl && c->ts.u.cl->length)
- {
- /* If we already have a length for this expression then use it. */
- if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
- return true;
- i = mpz_get_si (c->ts.u.cl->length->value.integer);
- }
- else
- return true;
- }
- else
- {
- start = ref->u.ss.start;
- end = ref->u.ss.end;
-
- gcc_assert (start);
- if (end == NULL || end->expr_type != EXPR_CONSTANT
- || start->expr_type != EXPR_CONSTANT)
- return true;
-
- i = mpz_get_si (end->value.integer) + 1
- - mpz_get_si (start->value.integer);
- }
- }
- else
- return true;
-
- if (i != 1)
- {
- gfc_error ("Argument of %s at %L must be of length one",
- gfc_current_intrinsic, &c->where);
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_idnint (gfc_expr *a)
-{
- if (!double_check (a, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
- gfc_expr *kind)
-{
- if (!type_check (string, 0, BT_CHARACTER)
- || !type_check (substring, 1, BT_CHARACTER))
- return false;
-
- if (back != NULL && !type_check (back, 2, BT_LOGICAL))
- return false;
-
- if (!kind_check (kind, 3, BT_INTEGER))
- return false;
- if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
- gfc_current_intrinsic, &kind->where))
- return false;
-
- if (string->ts.kind != substring->ts.kind)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
- "kind as %qs", gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic, &substring->where,
- gfc_current_intrinsic_arg[0]->name);
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_int (gfc_expr *x, gfc_expr *kind)
-{
- /* BOZ is dealt within simplify_int*. */
- if (x->ts.type == BT_BOZ)
- return true;
-
- if (!numeric_check (x, 0))
- return false;
-
- if (!kind_check (kind, 1, BT_INTEGER))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_intconv (gfc_expr *x)
-{
- if (strcmp (gfc_current_intrinsic, "short") == 0
- || strcmp (gfc_current_intrinsic, "long") == 0)
- {
- gfc_error ("%qs intrinsic subprogram at %L has been removed. "
- "Use INT intrinsic subprogram.", gfc_current_intrinsic,
- &x->where);
- return false;
- }
-
- /* BOZ is dealt within simplify_int*. */
- if (x->ts.type == BT_BOZ)
- return true;
-
- if (!numeric_check (x, 0))
- return false;
-
- return true;
-}
-
-bool
-gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
-{
- if (!type_check (i, 0, BT_INTEGER)
- || !type_check (shift, 1, BT_INTEGER))
- return false;
-
- if (!less_than_bitsize1 ("I", i, NULL, shift, true))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
-{
- if (!type_check (i, 0, BT_INTEGER)
- || !type_check (shift, 1, BT_INTEGER))
- return false;
-
- if (size != NULL)
- {
- int i2, i3;
-
- if (!type_check (size, 2, BT_INTEGER))
- return false;
-
- if (!less_than_bitsize1 ("I", i, "SIZE", size, true))
- return false;
-
- if (size->expr_type == EXPR_CONSTANT)
- {
- gfc_extract_int (size, &i3);
- if (i3 <= 0)
- {
- gfc_error ("SIZE at %L must be positive", &size->where);
- return false;
- }
-
- if (shift->expr_type == EXPR_CONSTANT)
- {
- gfc_extract_int (shift, &i2);
- if (i2 < 0)
- i2 = -i2;
-
- if (i2 > i3)
- {
- gfc_error ("The absolute value of SHIFT at %L must be less "
- "than or equal to SIZE at %L", &shift->where,
- &size->where);
- return false;
- }
- }
- }
- }
- else if (!less_than_bitsize1 ("I", i, NULL, shift, true))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
-{
- if (!type_check (pid, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (pid, 0))
- return false;
-
- if (!type_check (sig, 1, BT_INTEGER))
- return false;
-
- if (!scalar_check (sig, 1))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
-{
- if (!type_check (pid, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (pid, 0))
- return false;
-
- if (!type_check (sig, 1, BT_INTEGER))
- return false;
-
- if (!scalar_check (sig, 1))
- return false;
-
- if (status)
- {
- if (!type_check (status, 2, BT_INTEGER))
- return false;
-
- if (!scalar_check (status, 2))
- return false;
-
- if (status->expr_type != EXPR_VARIABLE)
- {
- gfc_error ("STATUS at %L shall be an INTENT(OUT) variable",
- &status->where);
- return false;
- }
-
- if (status->expr_type == EXPR_VARIABLE
- && status->symtree && status->symtree->n.sym
- && status->symtree->n.sym->attr.intent == INTENT_IN)
- {
- gfc_error ("%qs at %L shall be an INTENT(OUT) variable",
- status->symtree->name, &status->where);
- return false;
- }
- }
-
- return true;
-}
-
-
-bool
-gfc_check_kind (gfc_expr *x)
-{
- if (gfc_invalid_null_arg (x))
- return false;
-
- if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be of "
- "intrinsic type", gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &x->where);
- return false;
- }
- if (x->ts.type == BT_PROCEDURE)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &x->where);
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
-{
- if (!array_check (array, 0))
- return false;
-
- if (!dim_check (dim, 1, false))
- return false;
-
- if (!dim_rank_check (dim, array, 1))
- return false;
-
- if (!kind_check (kind, 2, BT_INTEGER))
- return false;
- if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
- gfc_current_intrinsic, &kind->where))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
-{
- if (flag_coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
- return false;
- }
-
- if (!coarray_check (coarray, 0))
- return false;
-
- if (dim != NULL)
- {
- if (!dim_check (dim, 1, false))
- return false;
-
- if (!dim_corank_check (dim, coarray))
- return false;
- }
-
- if (!kind_check (kind, 2, BT_INTEGER))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
-{
- if (!type_check (s, 0, BT_CHARACTER))
- return false;
-
- if (gfc_invalid_null_arg (s))
- return false;
-
- if (!kind_check (kind, 1, BT_INTEGER))
- return false;
- if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
- gfc_current_intrinsic, &kind->where))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
-{
- if (!type_check (a, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (a, 0, gfc_default_character_kind))
- return false;
-
- if (!type_check (b, 1, BT_CHARACTER))
- return false;
- if (!kind_value_check (b, 1, gfc_default_character_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_link (gfc_expr *path1, gfc_expr *path2)
-{
- if (!type_check (path1, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (path1, 0, gfc_default_character_kind))
- return false;
-
- if (!type_check (path2, 1, BT_CHARACTER))
- return false;
- if (!kind_value_check (path2, 1, gfc_default_character_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
-{
- if (!type_check (path1, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (path1, 0, gfc_default_character_kind))
- return false;
-
- if (!type_check (path2, 1, BT_CHARACTER))
- return false;
- if (!kind_value_check (path2, 0, gfc_default_character_kind))
- return false;
-
- if (status == NULL)
- return true;
-
- if (!type_check (status, 2, BT_INTEGER))
- return false;
-
- if (!scalar_check (status, 2))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_loc (gfc_expr *expr)
-{
- return variable_check (expr, 0, true);
-}
-
-
-bool
-gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
-{
- if (!type_check (path1, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (path1, 0, gfc_default_character_kind))
- return false;
-
- if (!type_check (path2, 1, BT_CHARACTER))
- return false;
- if (!kind_value_check (path2, 1, gfc_default_character_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
-{
- if (!type_check (path1, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (path1, 0, gfc_default_character_kind))
- return false;
-
- if (!type_check (path2, 1, BT_CHARACTER))
- return false;
- if (!kind_value_check (path2, 1, gfc_default_character_kind))
- return false;
-
- if (status == NULL)
- return true;
-
- if (!type_check (status, 2, BT_INTEGER))
- return false;
-
- if (!scalar_check (status, 2))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_logical (gfc_expr *a, gfc_expr *kind)
-{
- if (!type_check (a, 0, BT_LOGICAL))
- return false;
- if (!kind_check (kind, 1, BT_LOGICAL))
- return false;
-
- return true;
-}
-
-
-/* Min/max family. */
-
-static bool
-min_max_args (gfc_actual_arglist *args)
-{
- gfc_actual_arglist *arg;
- int i, j, nargs, *nlabels, nlabelless;
- bool a1 = false, a2 = false;
-
- if (args == NULL || args->next == NULL)
- {
- gfc_error ("Intrinsic %qs at %L must have at least two arguments",
- gfc_current_intrinsic, gfc_current_intrinsic_where);
- return false;
- }
-
- if (!args->name)
- a1 = true;
-
- if (!args->next->name)
- a2 = true;
-
- nargs = 0;
- for (arg = args; arg; arg = arg->next)
- if (arg->name)
- nargs++;
-
- if (nargs == 0)
- return true;
-
- /* Note: Having a keywordless argument after an "arg=" is checked before. */
- nlabelless = 0;
- nlabels = XALLOCAVEC (int, nargs);
- for (arg = args, i = 0; arg; arg = arg->next, i++)
- if (arg->name)
- {
- int n;
- char *endp;
-
- if (arg->name[0] != 'a' || arg->name[1] < '1' || arg->name[1] > '9')
- goto unknown;
- n = strtol (&arg->name[1], &endp, 10);
- if (endp[0] != '\0')
- goto unknown;
- if (n <= 0)
- goto unknown;
- if (n <= nlabelless)
- goto duplicate;
- nlabels[i] = n;
- if (n == 1)
- a1 = true;
- if (n == 2)
- a2 = true;
- }
- else
- nlabelless++;
-
- if (!a1 || !a2)
- {
- gfc_error ("Missing %qs argument to the %s intrinsic at %L",
- !a1 ? "a1" : "a2", gfc_current_intrinsic,
- gfc_current_intrinsic_where);
- return false;
- }
-
- /* Check for duplicates. */
- for (i = 0; i < nargs; i++)
- for (j = i + 1; j < nargs; j++)
- if (nlabels[i] == nlabels[j])
- goto duplicate;
-
- return true;
-
-duplicate:
- gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name,
- &arg->expr->where, gfc_current_intrinsic);
- return false;
-
-unknown:
- gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name,
- &arg->expr->where, gfc_current_intrinsic);
- return false;
-}
-
-
-static bool
-check_rest (bt type, int kind, gfc_actual_arglist *arglist)
-{
- gfc_actual_arglist *arg, *tmp;
- gfc_expr *x;
- int m, n;
-
- if (!min_max_args (arglist))
- return false;
-
- for (arg = arglist, n=1; arg; arg = arg->next, n++)
- {
- x = arg->expr;
- if (x->ts.type != type || x->ts.kind != kind)
- {
- if (x->ts.type == type)
- {
- if (x->ts.type == BT_CHARACTER)
- {
- gfc_error ("Different character kinds at %L", &x->where);
- return false;
- }
- if (!gfc_notify_std (GFC_STD_GNU, "Different type "
- "kinds at %L", &x->where))
- return false;
- }
- else
- {
- gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
- "%s(%d)", n, gfc_current_intrinsic, &x->where,
- gfc_basic_typename (type), kind);
- return false;
- }
- }
-
- for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
- if (!gfc_check_conformance (tmp->expr, x,
- _("arguments 'a%d' and 'a%d' for "
- "intrinsic '%s'"), m, n,
- gfc_current_intrinsic))
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_min_max (gfc_actual_arglist *arg)
-{
- gfc_expr *x;
-
- if (!min_max_args (arg))
- return false;
-
- x = arg->expr;
-
- if (x->ts.type == BT_CHARACTER)
- {
- if (!gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with CHARACTER argument at %L",
- gfc_current_intrinsic, &x->where))
- return false;
- }
- else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
- {
- gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
- "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
- return false;
- }
-
- return check_rest (x->ts.type, x->ts.kind, arg);
-}
-
-
-bool
-gfc_check_min_max_integer (gfc_actual_arglist *arg)
-{
- return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
-}
-
-
-bool
-gfc_check_min_max_real (gfc_actual_arglist *arg)
-{
- return check_rest (BT_REAL, gfc_default_real_kind, arg);
-}
-
-
-bool
-gfc_check_min_max_double (gfc_actual_arglist *arg)
-{
- return check_rest (BT_REAL, gfc_default_double_kind, arg);
-}
-
-
-/* End of min/max family. */
-
-bool
-gfc_check_malloc (gfc_expr *size)
-{
- if (!type_check (size, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (size, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
-{
- if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
- "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &matrix_a->where);
- return false;
- }
-
- if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
- "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic, &matrix_b->where);
- return false;
- }
-
- if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
- || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
- {
- gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
- gfc_current_intrinsic, &matrix_a->where,
- gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
- return false;
- }
-
- switch (matrix_a->rank)
- {
- case 1:
- if (!rank_check (matrix_b, 1, 2))
- return false;
- /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
- if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
- {
- gfc_error ("Different shape on dimension 1 for arguments %qs "
- "and %qs at %L for intrinsic matmul",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
- return false;
- }
- break;
-
- case 2:
- if (matrix_b->rank != 2)
- {
- if (!rank_check (matrix_b, 1, 1))
- return false;
- }
- /* matrix_b has rank 1 or 2 here. Common check for the cases
- - matrix_a has shape (n,m) and matrix_b has shape (m, k)
- - matrix_a has shape (n,m) and matrix_b has shape (m). */
- if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
- {
- gfc_error ("Different shape on dimension 2 for argument %qs and "
- "dimension 1 for argument %qs at %L for intrinsic "
- "matmul", gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
- return false;
- }
- break;
-
- default:
- gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
- "1 or 2", gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &matrix_a->where);
- return false;
- }
-
- return true;
-}
-
-
-/* Whoever came up with this interface was probably on something.
- The possibilities for the occupation of the second and third
- parameters are:
-
- Arg #2 Arg #3
- NULL NULL
- DIM NULL
- MASK NULL
- NULL MASK minloc(array, mask=m)
- DIM MASK
-
- I.e. in the case of minloc(array,mask), mask will be in the second
- position of the argument list and we'll have to fix that up. Also,
- add the BACK argument if that isn't present. */
-
-bool
-gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
-{
- gfc_expr *a, *m, *d, *k, *b;
-
- a = ap->expr;
- if (!int_or_real_or_char_check_f2003 (a, 0) || !array_check (a, 0))
- return false;
-
- d = ap->next->expr;
- m = ap->next->next->expr;
- k = ap->next->next->next->expr;
- b = ap->next->next->next->next->expr;
-
- if (b)
- {
- if (!type_check (b, 4, BT_LOGICAL) || !scalar_check (b,4))
- return false;
- }
- else
- {
- b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0);
- ap->next->next->next->next->expr = b;
- }
-
- if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
- && ap->next->name == NULL)
- {
- m = d;
- d = NULL;
- ap->next->expr = NULL;
- ap->next->next->expr = m;
- }
-
- if (!dim_check (d, 1, false))
- return false;
-
- if (!dim_rank_check (d, a, 0))
- return false;
-
- if (m != NULL && !type_check (m, 2, BT_LOGICAL))
- return false;
-
- if (m != NULL
- && !gfc_check_conformance (a, m,
- _("arguments '%s' and '%s' for intrinsic %s"),
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[2]->name,
- gfc_current_intrinsic))
- return false;
-
- if (!kind_check (k, 1, BT_INTEGER))
- return false;
-
- return true;
-}
-
-/* Check function for findloc. Mostly like gfc_check_minloc_maxloc
- above, with the additional "value" argument. */
-
-bool
-gfc_check_findloc (gfc_actual_arglist *ap)
-{
- gfc_expr *a, *v, *m, *d, *k, *b;
- bool a1, v1;
-
- a = ap->expr;
- if (!intrinsic_type_check (a, 0) || !array_check (a, 0))
- return false;
-
- v = ap->next->expr;
- if (!intrinsic_type_check (v, 1) || !scalar_check (v,1))
- return false;
-
- /* Check if the type are both logical. */
- a1 = a->ts.type == BT_LOGICAL;
- v1 = v->ts.type == BT_LOGICAL;
- if ((a1 && !v1) || (!a1 && v1))
- goto incompat;
-
- /* Check if the type are both character. */
- a1 = a->ts.type == BT_CHARACTER;
- v1 = v->ts.type == BT_CHARACTER;
- if ((a1 && !v1) || (!a1 && v1))
- goto incompat;
-
- /* Check the kind of the characters argument match. */
- if (a1 && v1 && a->ts.kind != v->ts.kind)
- goto incompat;
-
- d = ap->next->next->expr;
- m = ap->next->next->next->expr;
- k = ap->next->next->next->next->expr;
- b = ap->next->next->next->next->next->expr;
-
- if (b)
- {
- if (!type_check (b, 5, BT_LOGICAL) || !scalar_check (b,4))
- return false;
- }
- else
- {
- b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0);
- ap->next->next->next->next->next->expr = b;
- }
-
- if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
- && ap->next->name == NULL)
- {
- m = d;
- d = NULL;
- ap->next->next->expr = NULL;
- ap->next->next->next->expr = m;
- }
-
- if (!dim_check (d, 2, false))
- return false;
-
- if (!dim_rank_check (d, a, 0))
- return false;
-
- if (m != NULL && !type_check (m, 3, BT_LOGICAL))
- return false;
-
- if (m != NULL
- && !gfc_check_conformance (a, m,
- _("arguments '%s' and '%s' for intrinsic %s"),
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[3]->name,
- gfc_current_intrinsic))
- return false;
-
- if (!kind_check (k, 1, BT_INTEGER))
- return false;
-
- return true;
-
-incompat:
- gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
- "conformance to argument %qs at %L",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &a->where,
- gfc_current_intrinsic_arg[1]->name, &v->where);
- return false;
-}
-
-
-/* Similar to minloc/maxloc, the argument list might need to be
- reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
- difference is that MINLOC/MAXLOC take an additional KIND argument.
- The possibilities are:
-
- Arg #2 Arg #3
- NULL NULL
- DIM NULL
- MASK NULL
- NULL MASK minval(array, mask=m)
- DIM MASK
-
- I.e. in the case of minval(array,mask), mask will be in the second
- position of the argument list and we'll have to fix that up. */
-
-static bool
-check_reduction (gfc_actual_arglist *ap)
-{
- gfc_expr *a, *m, *d;
-
- a = ap->expr;
- d = ap->next->expr;
- m = ap->next->next->expr;
-
- if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
- && ap->next->name == NULL)
- {
- m = d;
- d = NULL;
- ap->next->expr = NULL;
- ap->next->next->expr = m;
- }
-
- if (!dim_check (d, 1, false))
- return false;
-
- if (!dim_rank_check (d, a, 0))
- return false;
-
- if (m != NULL && !type_check (m, 2, BT_LOGICAL))
- return false;
-
- if (m != NULL
- && !gfc_check_conformance (a, m,
- _("arguments '%s' and '%s' for intrinsic %s"),
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[2]->name,
- gfc_current_intrinsic))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_minval_maxval (gfc_actual_arglist *ap)
-{
- if (!int_or_real_or_char_check_f2003 (ap->expr, 0)
- || !array_check (ap->expr, 0))
- return false;
-
- return check_reduction (ap);
-}
-
-
-bool
-gfc_check_product_sum (gfc_actual_arglist *ap)
-{
- if (!numeric_check (ap->expr, 0)
- || !array_check (ap->expr, 0))
- return false;
-
- return check_reduction (ap);
-}
-
-
-/* For IANY, IALL and IPARITY. */
-
-bool
-gfc_check_mask (gfc_expr *i, gfc_expr *kind)
-{
- int k;
-
- if (!type_check (i, 0, BT_INTEGER))
- return false;
-
- if (!nonnegative_check ("I", i))
- return false;
-
- if (!kind_check (kind, 1, BT_INTEGER))
- return false;
-
- if (kind)
- gfc_extract_int (kind, &k);
- else
- k = gfc_default_integer_kind;
-
- if (!less_than_bitsizekind ("I", i, k))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
-{
- if (ap->expr->ts.type != BT_INTEGER)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &ap->expr->where);
- return false;
- }
-
- if (!array_check (ap->expr, 0))
- return false;
-
- return check_reduction (ap);
-}
-
-
-bool
-gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
-{
- if (gfc_invalid_null_arg (tsource))
- return false;
-
- if (gfc_invalid_null_arg (fsource))
- return false;
-
- if (!same_type_check (tsource, 0, fsource, 1))
- return false;
-
- if (!type_check (mask, 2, BT_LOGICAL))
- return false;
-
- if (tsource->ts.type == BT_CHARACTER)
- return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
-
- return true;
-}
-
-
-bool
-gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
-{
- /* i and j cannot both be BOZ literal constants. */
- if (!boz_args_check (i, j))
- return false;
-
- /* If i is BOZ and j is integer, convert i to type of j. */
- if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
- && !gfc_boz2int (i, j->ts.kind))
- return false;
-
- /* If j is BOZ and i is integer, convert j to type of i. */
- if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
- && !gfc_boz2int (j, i->ts.kind))
- return false;
-
- if (!type_check (i, 0, BT_INTEGER))
- return false;
-
- if (!type_check (j, 1, BT_INTEGER))
- return false;
-
- if (!same_type_check (i, 0, j, 1))
- return false;
-
- if (mask->ts.type == BT_BOZ && !gfc_boz2int(mask, i->ts.kind))
- return false;
-
- if (!type_check (mask, 2, BT_INTEGER))
- return false;
-
- if (!same_type_check (i, 0, mask, 2))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
-{
- if (!variable_check (from, 0, false))
- return false;
- if (!allocatable_check (from, 0))
- return false;
- if (gfc_is_coindexed (from))
- {
- gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
- "coindexed", &from->where);
- return false;
- }
-
- if (!variable_check (to, 1, false))
- return false;
- if (!allocatable_check (to, 1))
- return false;
- if (gfc_is_coindexed (to))
- {
- gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
- "coindexed", &to->where);
- return false;
- }
-
- if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
- {
- gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
- "polymorphic if FROM is polymorphic",
- &to->where);
- return false;
- }
-
- if (!same_type_check (to, 1, from, 0))
- return false;
-
- if (to->rank != from->rank)
- {
- gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
- "must have the same rank %d/%d", &to->where, from->rank,
- to->rank);
- return false;
- }
-
- /* IR F08/0040; cf. 12-006A. */
- if (gfc_get_corank (to) != gfc_get_corank (from))
- {
- gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
- "must have the same corank %d/%d", &to->where,
- gfc_get_corank (from), gfc_get_corank (to));
- return false;
- }
-
- /* This is based losely on F2003 12.4.1.7. It is intended to prevent
- the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
- and cmp2 are allocatable. After the allocation is transferred,
- the 'to' chain is broken by the nullification of the 'from'. A bit
- of reflection reveals that this can only occur for derived types
- with recursive allocatable components. */
- if (to->expr_type == EXPR_VARIABLE && from->expr_type == EXPR_VARIABLE
- && !strcmp (to->symtree->n.sym->name, from->symtree->n.sym->name))
- {
- gfc_ref *to_ref, *from_ref;
- to_ref = to->ref;
- from_ref = from->ref;
- bool aliasing = true;
-
- for (; from_ref && to_ref;
- from_ref = from_ref->next, to_ref = to_ref->next)
- {
- if (to_ref->type != from->ref->type)
- aliasing = false;
- else if (to_ref->type == REF_ARRAY
- && to_ref->u.ar.type != AR_FULL
- && from_ref->u.ar.type != AR_FULL)
- /* Play safe; assume sections and elements are different. */
- aliasing = false;
- else if (to_ref->type == REF_COMPONENT
- && to_ref->u.c.component != from_ref->u.c.component)
- aliasing = false;
-
- if (!aliasing)
- break;
- }
-
- if (aliasing)
- {
- gfc_error ("The FROM and TO arguments at %L violate aliasing "
- "restrictions (F2003 12.4.1.7)", &to->where);
- return false;
- }
- }
-
- /* CLASS arguments: Make sure the vtab of from is present. */
- if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from))
- gfc_find_vtab (&from->ts);
-
- return true;
-}
-
-
-bool
-gfc_check_nearest (gfc_expr *x, gfc_expr *s)
-{
- if (!type_check (x, 0, BT_REAL))
- return false;
-
- if (!type_check (s, 1, BT_REAL))
- return false;
-
- if (s->expr_type == EXPR_CONSTANT)
- {
- if (mpfr_sgn (s->value.real) == 0)
- {
- gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
- &s->where);
- return false;
- }
- }
-
- return true;
-}
-
-
-bool
-gfc_check_new_line (gfc_expr *a)
-{
- if (!type_check (a, 0, BT_CHARACTER))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
-{
- if (!type_check (array, 0, BT_REAL))
- return false;
-
- if (!array_check (array, 0))
- return false;
-
- if (!dim_rank_check (dim, array, false))
- return false;
-
- return true;
-}
-
-bool
-gfc_check_null (gfc_expr *mold)
-{
- symbol_attribute attr;
-
- if (mold == NULL)
- return true;
-
- if (!variable_check (mold, 0, true))
- return false;
-
- attr = gfc_variable_attr (mold, NULL);
-
- if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
- "ALLOCATABLE or procedure pointer",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &mold->where);
- return false;
- }
-
- if (attr.allocatable
- && !gfc_notify_std (GFC_STD_F2003, "NULL intrinsic with "
- "allocatable MOLD at %L", &mold->where))
- return false;
-
- /* F2008, C1242. */
- if (gfc_is_coindexed (mold))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
- "coindexed", gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &mold->where);
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
-{
- if (!array_check (array, 0))
- return false;
-
- if (!type_check (mask, 1, BT_LOGICAL))
- return false;
-
- if (!gfc_check_conformance (array, mask,
- _("arguments '%s' and '%s' for intrinsic '%s'"),
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic))
- return false;
-
- if (vector != NULL)
- {
- mpz_t array_size, vector_size;
- bool have_array_size, have_vector_size;
-
- if (!same_type_check (array, 0, vector, 2))
- return false;
-
- if (!rank_check (vector, 2, 1))
- return false;
-
- /* VECTOR requires at least as many elements as MASK
- has .TRUE. values. */
- have_array_size = gfc_array_size(array, &array_size);
- have_vector_size = gfc_array_size(vector, &vector_size);
-
- if (have_vector_size
- && (mask->expr_type == EXPR_ARRAY
- || (mask->expr_type == EXPR_CONSTANT
- && have_array_size)))
- {
- int mask_true_values = 0;
-
- if (mask->expr_type == EXPR_ARRAY)
- {
- gfc_constructor *mask_ctor;
- mask_ctor = gfc_constructor_first (mask->value.constructor);
- while (mask_ctor)
- {
- if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
- {
- mask_true_values = 0;
- break;
- }
-
- if (mask_ctor->expr->value.logical)
- mask_true_values++;
-
- mask_ctor = gfc_constructor_next (mask_ctor);
- }
- }
- else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
- mask_true_values = mpz_get_si (array_size);
-
- if (mpz_get_si (vector_size) < mask_true_values)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must "
- "provide at least as many elements as there "
- "are .TRUE. values in %qs (%ld/%d)",
- gfc_current_intrinsic_arg[2]->name,
- gfc_current_intrinsic, &vector->where,
- gfc_current_intrinsic_arg[1]->name,
- mpz_get_si (vector_size), mask_true_values);
- return false;
- }
- }
-
- if (have_array_size)
- mpz_clear (array_size);
- if (have_vector_size)
- mpz_clear (vector_size);
- }
-
- return true;
-}
-
-
-bool
-gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
-{
- if (!type_check (mask, 0, BT_LOGICAL))
- return false;
-
- if (!array_check (mask, 0))
- return false;
-
- if (!dim_rank_check (dim, mask, false))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_precision (gfc_expr *x)
-{
- if (!real_or_complex_check (x, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_present (gfc_expr *a)
-{
- gfc_symbol *sym;
-
- if (!variable_check (a, 0, true))
- return false;
-
- sym = a->symtree->n.sym;
- if (!sym->attr.dummy)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
- "dummy variable", gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &a->where);
- return false;
- }
-
- /* For CLASS, the optional attribute might be set at either location. */
- if ((sym->ts.type != BT_CLASS || !CLASS_DATA (sym)->attr.optional)
- && !sym->attr.optional)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be of "
- "an OPTIONAL dummy variable",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &a->where);
- return false;
- }
-
- /* 13.14.82 PRESENT(A)
- ......
- Argument. A shall be the name of an optional dummy argument that is
- accessible in the subprogram in which the PRESENT function reference
- appears... */
-
- if (a->ref != NULL
- && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
- && (a->ref->u.ar.type == AR_FULL
- || (a->ref->u.ar.type == AR_ELEMENT
- && a->ref->u.ar.as->rank == 0))))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
- "subobject of %qs", gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &a->where, sym->name);
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_radix (gfc_expr *x)
-{
- if (!int_or_real_check (x, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_range (gfc_expr *x)
-{
- if (!numeric_check (x, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_rank (gfc_expr *a)
-{
- /* Any data object is allowed; a "data object" is a "constant (4.1.3),
- variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
-
- bool is_variable = true;
-
- /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
- if (a->expr_type == EXPR_FUNCTION)
- is_variable = a->value.function.esym
- ? a->value.function.esym->result->attr.pointer
- : a->symtree->n.sym->result->attr.pointer;
-
- if (a->expr_type == EXPR_OP
- || a->expr_type == EXPR_NULL
- || a->expr_type == EXPR_COMPCALL
- || a->expr_type == EXPR_PPC
- || a->ts.type == BT_PROCEDURE
- || !is_variable)
- {
- gfc_error ("The argument of the RANK intrinsic at %L must be a data "
- "object", &a->where);
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_real (gfc_expr *a, gfc_expr *kind)
-{
- if (!kind_check (kind, 1, BT_REAL))
- return false;
-
- /* BOZ is dealt with in gfc_simplify_real. */
- if (a->ts.type == BT_BOZ)
- return true;
-
- if (!numeric_check (a, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
-{
- if (!type_check (path1, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (path1, 0, gfc_default_character_kind))
- return false;
-
- if (!type_check (path2, 1, BT_CHARACTER))
- return false;
- if (!kind_value_check (path2, 1, gfc_default_character_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
-{
- if (!type_check (path1, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (path1, 0, gfc_default_character_kind))
- return false;
-
- if (!type_check (path2, 1, BT_CHARACTER))
- return false;
- if (!kind_value_check (path2, 1, gfc_default_character_kind))
- return false;
-
- if (status == NULL)
- return true;
-
- if (!type_check (status, 2, BT_INTEGER))
- return false;
-
- if (!scalar_check (status, 2))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_repeat (gfc_expr *x, gfc_expr *y)
-{
- if (!type_check (x, 0, BT_CHARACTER))
- return false;
-
- if (!scalar_check (x, 0))
- return false;
-
- if (!type_check (y, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (y, 1))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
- gfc_expr *pad, gfc_expr *order)
-{
- mpz_t size;
- mpz_t nelems;
- int shape_size;
- bool shape_is_const;
-
- if (!array_check (source, 0))
- return false;
-
- if (!rank_check (shape, 1, 1))
- return false;
-
- if (!type_check (shape, 1, BT_INTEGER))
- return false;
-
- if (!gfc_array_size (shape, &size))
- {
- gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
- "array of constant size", &shape->where);
- return false;
- }
-
- shape_size = mpz_get_ui (size);
- mpz_clear (size);
-
- if (shape_size <= 0)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L is empty",
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &shape->where);
- return false;
- }
- else if (shape_size > GFC_MAX_DIMENSIONS)
- {
- gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
- "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
- return false;
- }
-
- gfc_simplify_expr (shape, 0);
- shape_is_const = gfc_is_constant_expr (shape);
-
- if (shape->expr_type == EXPR_ARRAY && shape_is_const)
- {
- gfc_expr *e;
- int i, extent;
- for (i = 0; i < shape_size; ++i)
- {
- e = gfc_constructor_lookup_expr (shape->value.constructor, i);
- if (e->expr_type != EXPR_CONSTANT)
- continue;
-
- gfc_extract_int (e, &extent);
- if (extent < 0)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L has "
- "negative element (%d)",
- gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic, &shape->where, extent);
- return false;
- }
- }
- }
-
- if (pad != NULL)
- {
- if (!same_type_check (source, 0, pad, 2))
- return false;
-
- if (!array_check (pad, 2))
- return false;
- }
-
- if (order != NULL)
- {
- if (!array_check (order, 3))
- return false;
-
- if (!type_check (order, 3, BT_INTEGER))
- return false;
-
- if (order->expr_type == EXPR_ARRAY && gfc_is_constant_expr (order))
- {
- int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
- gfc_expr *e;
-
- for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
- perm[i] = 0;
-
- gfc_array_size (order, &size);
- order_size = mpz_get_ui (size);
- mpz_clear (size);
-
- if (order_size != shape_size)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L "
- "has wrong number of elements (%d/%d)",
- gfc_current_intrinsic_arg[3]->name,
- gfc_current_intrinsic, &order->where,
- order_size, shape_size);
- return false;
- }
-
- for (i = 1; i <= order_size; ++i)
- {
- e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
- if (e->expr_type != EXPR_CONSTANT)
- continue;
-
- gfc_extract_int (e, &dim);
-
- if (dim < 1 || dim > order_size)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L "
- "has out-of-range dimension (%d)",
- gfc_current_intrinsic_arg[3]->name,
- gfc_current_intrinsic, &e->where, dim);
- return false;
- }
-
- if (perm[dim-1] != 0)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L has "
- "invalid permutation of dimensions (dimension "
- "%qd duplicated)",
- gfc_current_intrinsic_arg[3]->name,
- gfc_current_intrinsic, &e->where, dim);
- return false;
- }
-
- perm[dim-1] = 1;
- }
- }
- }
-
- if (pad == NULL && shape->expr_type == EXPR_ARRAY && shape_is_const
- && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
- && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
- {
- /* Check the match in size between source and destination. */
- if (gfc_array_size (source, &nelems))
- {
- gfc_constructor *c;
- bool test;
-
-
- mpz_init_set_ui (size, 1);
- for (c = gfc_constructor_first (shape->value.constructor);
- c; c = gfc_constructor_next (c))
- mpz_mul (size, size, c->expr->value.integer);
-
- test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
- mpz_clear (nelems);
- mpz_clear (size);
-
- if (test)
- {
- gfc_error ("Without padding, there are not enough elements "
- "in the intrinsic RESHAPE source at %L to match "
- "the shape", &source->where);
- return false;
- }
- }
- }
-
- return true;
-}
-
-
-bool
-gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
-{
- if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L "
- "cannot be of type %s",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic,
- &a->where, gfc_typename (a));
- return false;
- }
-
- if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a)))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L "
- "must be of an extensible type",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &a->where);
- return false;
- }
-
- if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L "
- "cannot be of type %s",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic,
- &b->where, gfc_typename (b));
- return false;
- }
-
- if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b)))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L "
- "must be of an extensible type",
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &b->where);
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_scale (gfc_expr *x, gfc_expr *i)
-{
- if (!type_check (x, 0, BT_REAL))
- return false;
-
- if (!type_check (i, 1, BT_INTEGER))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
-{
- if (!type_check (x, 0, BT_CHARACTER))
- return false;
-
- if (!type_check (y, 1, BT_CHARACTER))
- return false;
-
- if (z != NULL && !type_check (z, 2, BT_LOGICAL))
- return false;
-
- if (!kind_check (kind, 3, BT_INTEGER))
- return false;
- if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
- gfc_current_intrinsic, &kind->where))
- return false;
-
- if (!same_type_check (x, 0, y, 1))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_secnds (gfc_expr *r)
-{
- if (!type_check (r, 0, BT_REAL))
- return false;
-
- if (!kind_value_check (r, 0, 4))
- return false;
-
- if (!scalar_check (r, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_selected_char_kind (gfc_expr *name)
-{
- if (!type_check (name, 0, BT_CHARACTER))
- return false;
-
- if (!kind_value_check (name, 0, gfc_default_character_kind))
- return false;
-
- if (!scalar_check (name, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_selected_int_kind (gfc_expr *r)
-{
- if (!type_check (r, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (r, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
-{
- if (p == NULL && r == NULL
- && !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with"
- " neither %<P%> nor %<R%> argument at %L",
- gfc_current_intrinsic_where))
- return false;
-
- if (p)
- {
- if (!type_check (p, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (p, 0))
- return false;
- }
-
- if (r)
- {
- if (!type_check (r, 1, BT_INTEGER))
- return false;
-
- if (!scalar_check (r, 1))
- return false;
- }
-
- if (radix)
- {
- if (!type_check (radix, 1, BT_INTEGER))
- return false;
-
- if (!scalar_check (radix, 1))
- return false;
-
- if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with "
- "RADIX argument at %L", gfc_current_intrinsic,
- &radix->where))
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
-{
- if (!type_check (x, 0, BT_REAL))
- return false;
-
- if (!type_check (i, 1, BT_INTEGER))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_shape (gfc_expr *source, gfc_expr *kind)
-{
- gfc_array_ref *ar;
-
- if (gfc_invalid_null_arg (source))
- return false;
-
- if (!kind_check (kind, 1, BT_INTEGER))
- return false;
- if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
- gfc_current_intrinsic, &kind->where))
- return false;
-
- if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
- return true;
-
- if (source->ref == NULL)
- return false;
-
- ar = gfc_find_array_ref (source);
-
- if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
- {
- gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
- "an assumed size array", &source->where);
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_shift (gfc_expr *i, gfc_expr *shift)
-{
- if (!type_check (i, 0, BT_INTEGER))
- return false;
-
- if (!type_check (shift, 0, BT_INTEGER))
- return false;
-
- if (!nonnegative_check ("SHIFT", shift))
- return false;
-
- if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_sign (gfc_expr *a, gfc_expr *b)
-{
- if (!int_or_real_check (a, 0))
- return false;
-
- if (!same_type_check (a, 0, b, 1))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
-{
- if (!array_check (array, 0))
- return false;
-
- if (!dim_check (dim, 1, true))
- return false;
-
- if (!dim_rank_check (dim, array, 0))
- return false;
-
- if (!kind_check (kind, 2, BT_INTEGER))
- return false;
- if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
- gfc_current_intrinsic, &kind->where))
- return false;
-
-
- return true;
-}
-
-
-bool
-gfc_check_sizeof (gfc_expr *arg)
-{
- if (gfc_invalid_null_arg (arg))
- return false;
-
- if (arg->ts.type == BT_PROCEDURE)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &arg->where);
- return false;
- }
-
- if (illegal_boz_arg (arg))
- return false;
-
- /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
- if (arg->ts.type == BT_ASSUMED
- && (arg->symtree->n.sym->as == NULL
- || (arg->symtree->n.sym->as->type != AS_ASSUMED_SHAPE
- && arg->symtree->n.sym->as->type != AS_DEFERRED
- && arg->symtree->n.sym->as->type != AS_ASSUMED_RANK)))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &arg->where);
- return false;
- }
-
- if (arg->rank && arg->expr_type == EXPR_VARIABLE
- && arg->symtree->n.sym->as != NULL
- && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
- && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
- "assumed-size array", gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &arg->where);
- return false;
- }
-
- return true;
-}
-
-
-/* Check whether an expression is interoperable. When returning false,
- msg is set to a string telling why the expression is not interoperable,
- otherwise, it is set to NULL. The msg string can be used in diagnostics.
- If c_loc is true, character with len > 1 are allowed (cf. Fortran
- 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
- arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
- are permitted. */
-
-static bool
-is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr)
-{
- *msg = NULL;
-
- if (expr->expr_type == EXPR_NULL)
- {
- *msg = "NULL() is not interoperable";
- return false;
- }
-
- if (expr->ts.type == BT_BOZ)
- {
- *msg = "BOZ literal constant";
- return false;
- }
-
- if (expr->ts.type == BT_CLASS)
- {
- *msg = "Expression is polymorphic";
- return false;
- }
-
- if (expr->ts.type == BT_DERIVED && !expr->ts.u.derived->attr.is_bind_c
- && !expr->ts.u.derived->ts.is_iso_c)
- {
- *msg = "Expression is a noninteroperable derived type";
- return false;
- }
-
- if (expr->ts.type == BT_PROCEDURE)
- {
- *msg = "Procedure unexpected as argument";
- return false;
- }
-
- if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_LOGICAL)
- {
- int i;
- for (i = 0; gfc_logical_kinds[i].kind; i++)
- if (gfc_logical_kinds[i].kind == expr->ts.kind)
- return true;
- *msg = "Extension to use a non-C_Bool-kind LOGICAL";
- return false;
- }
-
- if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_CHARACTER
- && expr->ts.kind != 1)
- {
- *msg = "Extension to use a non-C_CHAR-kind CHARACTER";
- return false;
- }
-
- if (expr->ts.type == BT_CHARACTER) {
- if (expr->ts.deferred)
- {
- /* TS 29113 allows deferred-length strings as dummy arguments,
- but it is not an interoperable type. */
- *msg = "Expression shall not be a deferred-length string";
- return false;
- }
-
- if (expr->ts.u.cl && expr->ts.u.cl->length
- && !gfc_simplify_expr (expr->ts.u.cl->length, 0))
- gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
-
- if (!c_loc && expr->ts.u.cl
- && (!expr->ts.u.cl->length
- || expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
- || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0))
- {
- *msg = "Type shall have a character length of 1";
- return false;
- }
- }
-
- /* Note: The following checks are about interoperatable variables, Fortran
- 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
- is allowed, e.g. assumed-shape arrays with TS 29113. */
-
- if (gfc_is_coarray (expr))
- {
- *msg = "Coarrays are not interoperable";
- return false;
- }
-
- if (!c_loc && expr->rank > 0 && expr->expr_type != EXPR_ARRAY)
- {
- gfc_array_ref *ar = gfc_find_array_ref (expr);
- if (ar->type != AR_FULL)
- {
- *msg = "Only whole-arrays are interoperable";
- return false;
- }
- if (!c_f_ptr && ar->as->type != AS_EXPLICIT
- && ar->as->type != AS_ASSUMED_SIZE)
- {
- *msg = "Only explicit-size and assumed-size arrays are interoperable";
- return false;
- }
- }
-
- return true;
-}
-
-
-bool
-gfc_check_c_sizeof (gfc_expr *arg)
-{
- const char *msg;
-
- if (!is_c_interoperable (arg, &msg, false, false))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be an "
- "interoperable data entity: %s",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &arg->where, msg);
- return false;
- }
-
- if (arg->ts.type == BT_ASSUMED)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
- "TYPE(*)",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &arg->where);
- return false;
- }
-
- if (arg->rank && arg->expr_type == EXPR_VARIABLE
- && arg->symtree->n.sym->as != NULL
- && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
- && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
- "assumed-size array", gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &arg->where);
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
-{
- if (c_ptr_1->ts.type != BT_DERIVED
- || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
- || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
- && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
- {
- gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
- "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
- return false;
- }
-
- if (!scalar_check (c_ptr_1, 0))
- return false;
-
- if (c_ptr_2
- && (c_ptr_2->ts.type != BT_DERIVED
- || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
- || (c_ptr_1->ts.u.derived->intmod_sym_id
- != c_ptr_2->ts.u.derived->intmod_sym_id)))
- {
- gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
- "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where,
- gfc_typename (&c_ptr_1->ts),
- gfc_typename (&c_ptr_2->ts));
- return false;
- }
-
- if (c_ptr_2 && !scalar_check (c_ptr_2, 1))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
-{
- symbol_attribute attr;
- const char *msg;
-
- if (cptr->ts.type != BT_DERIVED
- || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
- || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
- {
- gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
- "type TYPE(C_PTR)", &cptr->where);
- return false;
- }
-
- if (!scalar_check (cptr, 0))
- return false;
-
- attr = gfc_expr_attr (fptr);
-
- if (!attr.pointer)
- {
- gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
- &fptr->where);
- return false;
- }
-
- if (fptr->ts.type == BT_CLASS)
- {
- gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
- &fptr->where);
- return false;
- }
-
- if (gfc_is_coindexed (fptr))
- {
- gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
- "coindexed", &fptr->where);
- return false;
- }
-
- if (fptr->rank == 0 && shape)
- {
- gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
- "FPTR", &fptr->where);
- return false;
- }
- else if (fptr->rank && !shape)
- {
- gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
- "FPTR at %L", &fptr->where);
- return false;
- }
-
- if (shape && !rank_check (shape, 2, 1))
- return false;
-
- if (shape && !type_check (shape, 2, BT_INTEGER))
- return false;
-
- if (shape)
- {
- mpz_t size;
- if (gfc_array_size (shape, &size))
- {
- if (mpz_cmp_ui (size, fptr->rank) != 0)
- {
- mpz_clear (size);
- gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
- "size as the RANK of FPTR", &shape->where);
- return false;
- }
- mpz_clear (size);
- }
- }
-
- if (fptr->ts.type == BT_CLASS)
- {
- gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where);
- return false;
- }
-
- if (fptr->rank > 0 && !is_c_interoperable (fptr, &msg, false, true))
- return gfc_notify_std (GFC_STD_F2018, "Noninteroperable array FPTR "
- "at %L to C_F_POINTER: %s", &fptr->where, msg);
-
- return true;
-}
-
-
-bool
-gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr)
-{
- symbol_attribute attr;
-
- if (cptr->ts.type != BT_DERIVED
- || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
- || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)
- {
- gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
- "type TYPE(C_FUNPTR)", &cptr->where);
- return false;
- }
-
- if (!scalar_check (cptr, 0))
- return false;
-
- attr = gfc_expr_attr (fptr);
-
- if (!attr.proc_pointer)
- {
- gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
- "pointer", &fptr->where);
- return false;
- }
-
- if (gfc_is_coindexed (fptr))
- {
- gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
- "coindexed", &fptr->where);
- return false;
- }
-
- if (!attr.is_bind_c)
- return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure "
- "pointer at %L to C_F_PROCPOINTER", &fptr->where);
-
- return true;
-}
-
-
-bool
-gfc_check_c_funloc (gfc_expr *x)
-{
- symbol_attribute attr;
-
- if (gfc_is_coindexed (x))
- {
- gfc_error ("Argument X at %L to C_FUNLOC shall not be "
- "coindexed", &x->where);
- return false;
- }
-
- attr = gfc_expr_attr (x);
-
- if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE
- && x->symtree->n.sym == x->symtree->n.sym->result)
- for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
- if (x->symtree->n.sym == ns->proc_name)
- {
- gfc_error ("Function result %qs at %L is invalid as X argument "
- "to C_FUNLOC", x->symtree->n.sym->name, &x->where);
- return false;
- }
-
- if (attr.flavor != FL_PROCEDURE)
- {
- gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
- "or a procedure pointer", &x->where);
- return false;
- }
-
- if (!attr.is_bind_c)
- return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure "
- "at %L to C_FUNLOC", &x->where);
- return true;
-}
-
-
-bool
-gfc_check_c_loc (gfc_expr *x)
-{
- symbol_attribute attr;
- const char *msg;
-
- if (gfc_is_coindexed (x))
- {
- gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where);
- return false;
- }
-
- if (x->ts.type == BT_CLASS)
- {
- gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
- &x->where);
- return false;
- }
-
- attr = gfc_expr_attr (x);
-
- if (!attr.pointer
- && (x->expr_type != EXPR_VARIABLE || !attr.target
- || attr.flavor == FL_PARAMETER))
- {
- gfc_error ("Argument X at %L to C_LOC shall have either "
- "the POINTER or the TARGET attribute", &x->where);
- return false;
- }
-
- if (x->ts.type == BT_CHARACTER
- && gfc_var_strlen (x) == 0)
- {
- gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
- "string", &x->where);
- return false;
- }
-
- if (!is_c_interoperable (x, &msg, true, false))
- {
- if (x->ts.type == BT_CLASS)
- {
- gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
- &x->where);
- return false;
- }
-
- if (x->rank
- && !gfc_notify_std (GFC_STD_F2018,
- "Noninteroperable array at %L as"
- " argument to C_LOC: %s", &x->where, msg))
- return false;
- }
- else if (x->rank > 0 && gfc_notification_std (GFC_STD_F2008))
- {
- gfc_array_ref *ar = gfc_find_array_ref (x);
-
- if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE
- && !attr.allocatable
- && !gfc_notify_std (GFC_STD_F2008,
- "Array of interoperable type at %L "
- "to C_LOC which is nonallocatable and neither "
- "assumed size nor explicit size", &x->where))
- return false;
- else if (ar->type != AR_FULL
- && !gfc_notify_std (GFC_STD_F2008, "Array section at %L "
- "to C_LOC", &x->where))
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_sleep_sub (gfc_expr *seconds)
-{
- if (!type_check (seconds, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (seconds, 0))
- return false;
-
- return true;
-}
-
-bool
-gfc_check_sngl (gfc_expr *a)
-{
- if (!type_check (a, 0, BT_REAL))
- return false;
-
- if ((a->ts.kind != gfc_default_double_kind)
- && !gfc_notify_std (GFC_STD_GNU, "non double precision "
- "REAL argument to %s intrinsic at %L",
- gfc_current_intrinsic, &a->where))
- return false;
-
- return true;
-}
-
-bool
-gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
-{
- if (gfc_invalid_null_arg (source))
- return false;
-
- if (source->rank >= GFC_MAX_DIMENSIONS)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be less "
- "than rank %d", gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
-
- return false;
- }
-
- if (dim == NULL)
- return false;
-
- if (!dim_check (dim, 1, false))
- return false;
-
- /* dim_rank_check() does not apply here. */
- if (dim
- && dim->expr_type == EXPR_CONSTANT
- && (mpz_cmp_ui (dim->value.integer, 1) < 0
- || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
- {
- gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
- "dimension index", gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic, &dim->where);
- return false;
- }
-
- if (!type_check (ncopies, 2, BT_INTEGER))
- return false;
-
- if (!scalar_check (ncopies, 2))
- return false;
-
- return true;
-}
-
-
-/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
- functions). */
-
-bool
-arg_strlen_is_zero (gfc_expr *c, int n)
-{
- if (gfc_var_strlen (c) == 0)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must have "
- "length at least 1", gfc_current_intrinsic_arg[n]->name,
- gfc_current_intrinsic, &c->where);
- return true;
- }
- return false;
-}
-
-bool
-gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
-{
- if (!type_check (unit, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (unit, 0))
- return false;
-
- if (!type_check (c, 1, BT_CHARACTER))
- return false;
- if (!kind_value_check (c, 1, gfc_default_character_kind))
- return false;
- if (strcmp (gfc_current_intrinsic, "fgetc") == 0
- && !variable_check (c, 1, false))
- return false;
- if (arg_strlen_is_zero (c, 1))
- return false;
-
- if (status == NULL)
- return true;
-
- if (!type_check (status, 2, BT_INTEGER)
- || !kind_value_check (status, 2, gfc_default_integer_kind)
- || !scalar_check (status, 2)
- || !variable_check (status, 2, false))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
-{
- return gfc_check_fgetputc_sub (unit, c, NULL);
-}
-
-
-bool
-gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
-{
- if (!type_check (c, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (c, 0, gfc_default_character_kind))
- return false;
- if (strcmp (gfc_current_intrinsic, "fget") == 0
- && !variable_check (c, 0, false))
- return false;
- if (arg_strlen_is_zero (c, 0))
- return false;
-
- if (status == NULL)
- return true;
-
- if (!type_check (status, 1, BT_INTEGER)
- || !kind_value_check (status, 1, gfc_default_integer_kind)
- || !scalar_check (status, 1)
- || !variable_check (status, 1, false))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_fgetput (gfc_expr *c)
-{
- return gfc_check_fgetput_sub (c, NULL);
-}
-
-
-bool
-gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
-{
- if (!type_check (unit, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (unit, 0))
- return false;
-
- if (!type_check (offset, 1, BT_INTEGER))
- return false;
-
- if (!scalar_check (offset, 1))
- return false;
-
- if (!type_check (whence, 2, BT_INTEGER))
- return false;
-
- if (!scalar_check (whence, 2))
- return false;
-
- if (status == NULL)
- return true;
-
- if (!type_check (status, 3, BT_INTEGER))
- return false;
-
- if (!kind_value_check (status, 3, 4))
- return false;
-
- if (!scalar_check (status, 3))
- return false;
-
- return true;
-}
-
-
-
-bool
-gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
-{
- if (!type_check (unit, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (unit, 0))
- return false;
-
- if (!type_check (array, 1, BT_INTEGER)
- || !kind_value_check (unit, 0, gfc_default_integer_kind))
- return false;
-
- if (!array_check (array, 1))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
-{
- if (!type_check (unit, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (unit, 0))
- return false;
-
- if (!type_check (array, 1, BT_INTEGER)
- || !kind_value_check (array, 1, gfc_default_integer_kind))
- return false;
-
- if (!array_check (array, 1))
- return false;
-
- if (status == NULL)
- return true;
-
- if (!type_check (status, 2, BT_INTEGER)
- || !kind_value_check (status, 2, gfc_default_integer_kind))
- return false;
-
- if (!scalar_check (status, 2))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_ftell (gfc_expr *unit)
-{
- if (!type_check (unit, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (unit, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
-{
- if (!type_check (unit, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (unit, 0))
- return false;
-
- if (!type_check (offset, 1, BT_INTEGER))
- return false;
-
- if (!scalar_check (offset, 1))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_stat (gfc_expr *name, gfc_expr *array)
-{
- if (!type_check (name, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (name, 0, gfc_default_character_kind))
- return false;
-
- if (!type_check (array, 1, BT_INTEGER)
- || !kind_value_check (array, 1, gfc_default_integer_kind))
- return false;
-
- if (!array_check (array, 1))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
-{
- if (!type_check (name, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (name, 0, gfc_default_character_kind))
- return false;
-
- if (!type_check (array, 1, BT_INTEGER)
- || !kind_value_check (array, 1, gfc_default_integer_kind))
- return false;
-
- if (!array_check (array, 1))
- return false;
-
- if (status == NULL)
- return true;
-
- if (!type_check (status, 2, BT_INTEGER)
- || !kind_value_check (array, 1, gfc_default_integer_kind))
- return false;
-
- if (!scalar_check (status, 2))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
-{
- mpz_t nelems;
-
- if (flag_coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
- return false;
- }
-
- if (!coarray_check (coarray, 0))
- return false;
-
- if (sub->rank != 1)
- {
- gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
- gfc_current_intrinsic_arg[1]->name, &sub->where);
- return false;
- }
-
- if (sub->ts.type != BT_INTEGER)
- {
- gfc_error ("Type of %s argument of IMAGE_INDEX at %L shall be INTEGER",
- gfc_current_intrinsic_arg[1]->name, &sub->where);
- return false;
- }
-
- if (gfc_array_size (sub, &nelems))
- {
- int corank = gfc_get_corank (coarray);
-
- if (mpz_cmp_ui (nelems, corank) != 0)
- {
- gfc_error ("The number of array elements of the SUB argument to "
- "IMAGE_INDEX at %L shall be %d (corank) not %d",
- &sub->where, corank, (int) mpz_get_si (nelems));
- mpz_clear (nelems);
- return false;
- }
- mpz_clear (nelems);
- }
-
- return true;
-}
-
-
-bool
-gfc_check_num_images (gfc_expr *distance, gfc_expr *failed)
-{
- if (flag_coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
- return false;
- }
-
- if (distance)
- {
- if (!type_check (distance, 0, BT_INTEGER))
- return false;
-
- if (!nonnegative_check ("DISTANCE", distance))
- return false;
-
- if (!scalar_check (distance, 0))
- return false;
-
- if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to "
- "NUM_IMAGES at %L", &distance->where))
- return false;
- }
-
- if (failed)
- {
- if (!type_check (failed, 1, BT_LOGICAL))
- return false;
-
- if (!scalar_check (failed, 1))
- return false;
-
- if (!gfc_notify_std (GFC_STD_F2018, "FAILED= argument to "
- "NUM_IMAGES at %L", &failed->where))
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_team_number (gfc_expr *team)
-{
- if (flag_coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
- return false;
- }
-
- if (team)
- {
- if (team->ts.type != BT_DERIVED
- || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
- || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
- {
- gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
- "shall be of type TEAM_TYPE", &team->where);
- return false;
- }
- }
- else
- return true;
-
- return true;
-}
-
-
-bool
-gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance)
-{
- if (flag_coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
- return false;
- }
-
- if (coarray == NULL && dim == NULL && distance == NULL)
- return true;
-
- if (dim != NULL && coarray == NULL)
- {
- gfc_error ("DIM argument without COARRAY argument not allowed for "
- "THIS_IMAGE intrinsic at %L", &dim->where);
- return false;
- }
-
- if (distance && (coarray || dim))
- {
- gfc_error ("The DISTANCE argument may not be specified together with the "
- "COARRAY or DIM argument in intrinsic at %L",
- &distance->where);
- return false;
- }
-
- /* Assume that we have "this_image (distance)". */
- if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER)
- {
- if (dim)
- {
- gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
- &coarray->where);
- return false;
- }
- distance = coarray;
- }
-
- if (distance)
- {
- if (!type_check (distance, 2, BT_INTEGER))
- return false;
-
- if (!nonnegative_check ("DISTANCE", distance))
- return false;
-
- if (!scalar_check (distance, 2))
- return false;
-
- if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to "
- "THIS_IMAGE at %L", &distance->where))
- return false;
-
- return true;
- }
-
- if (!coarray_check (coarray, 0))
- return false;
-
- if (dim != NULL)
- {
- if (!dim_check (dim, 1, false))
- return false;
-
- if (!dim_corank_check (dim, coarray))
- return false;
- }
-
- return true;
-}
-
-/* Calculate the sizes for transfer, used by gfc_check_transfer and also
- by gfc_simplify_transfer. Return false if we cannot do so. */
-
-bool
-gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
- size_t *source_size, size_t *result_size,
- size_t *result_length_p)
-{
- size_t result_elt_size;
-
- if (source->expr_type == EXPR_FUNCTION)
- return false;
-
- if (size && size->expr_type != EXPR_CONSTANT)
- return false;
-
- /* Calculate the size of the source. */
- if (!gfc_target_expr_size (source, source_size))
- return false;
-
- /* Determine the size of the element. */
- if (!gfc_element_size (mold, &result_elt_size))
- return false;
-
- /* If the storage size of SOURCE is greater than zero and MOLD is an array,
- * a scalar with the type and type parameters of MOLD shall not have a
- * storage size equal to zero.
- * If MOLD is a scalar and SIZE is absent, the result is a scalar.
- * If MOLD is an array and SIZE is absent, the result is an array and of
- * rank one. Its size is as small as possible such that its physical
- * representation is not shorter than that of SOURCE.
- * If SIZE is present, the result is an array of rank one and size SIZE.
- */
- if (result_elt_size == 0 && *source_size > 0 && !size
- && mold->expr_type == EXPR_ARRAY)
- {
- gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L is an "
- "array and shall not have storage size 0 when %<SOURCE%> "
- "argument has size greater than 0", &mold->where);
- return false;
- }
-
- if (result_elt_size == 0 && *source_size == 0 && !size)
- {
- *result_size = 0;
- if (result_length_p)
- *result_length_p = 0;
- return true;
- }
-
- if ((result_elt_size > 0 && (mold->expr_type == EXPR_ARRAY || mold->rank))
- || size)
- {
- int result_length;
-
- if (size)
- result_length = (size_t)mpz_get_ui (size->value.integer);
- else
- {
- result_length = *source_size / result_elt_size;
- if (result_length * result_elt_size < *source_size)
- result_length += 1;
- }
-
- *result_size = result_length * result_elt_size;
- if (result_length_p)
- *result_length_p = result_length;
- }
- else
- *result_size = result_elt_size;
-
- return true;
-}
-
-
-bool
-gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
-{
- size_t source_size;
- size_t result_size;
-
- if (gfc_invalid_null_arg (source))
- return false;
-
- /* SOURCE shall be a scalar or array of any type. */
- if (source->ts.type == BT_PROCEDURE
- && source->symtree->n.sym->attr.subroutine == 1)
- {
- gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L "
- "must not be a %s", &source->where,
- gfc_basic_typename (source->ts.type));
- return false;
- }
-
- if (source->ts.type == BT_BOZ && illegal_boz_arg (source))
- return false;
-
- if (mold->ts.type == BT_BOZ && illegal_boz_arg (mold))
- return false;
-
- if (gfc_invalid_null_arg (mold))
- return false;
-
- /* MOLD shall be a scalar or array of any type. */
- if (mold->ts.type == BT_PROCEDURE
- && mold->symtree->n.sym->attr.subroutine == 1)
- {
- gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L "
- "must not be a %s", &mold->where,
- gfc_basic_typename (mold->ts.type));
- return false;
- }
-
- if (mold->ts.type == BT_HOLLERITH)
- {
- gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
- " %s", &mold->where, gfc_basic_typename (BT_HOLLERITH));
- return false;
- }
-
- /* SIZE (optional) shall be an integer scalar. The corresponding actual
- argument shall not be an optional dummy argument. */
- if (size != NULL)
- {
- if (!type_check (size, 2, BT_INTEGER))
- {
- if (size->ts.type == BT_BOZ)
- reset_boz (size);
- return false;
- }
-
- if (!scalar_check (size, 2))
- return false;
-
- if (!nonoptional_check (size, 2))
- return false;
- }
-
- if (!warn_surprising)
- return true;
-
- /* If we can't calculate the sizes, we cannot check any more.
- Return true for that case. */
-
- if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
- &result_size, NULL))
- return true;
-
- if (source_size < result_size)
- gfc_warning (OPT_Wsurprising,
- "Intrinsic TRANSFER at %L has partly undefined result: "
- "source size %ld < result size %ld", &source->where,
- (long) source_size, (long) result_size);
-
- return true;
-}
-
-
-bool
-gfc_check_transpose (gfc_expr *matrix)
-{
- if (!rank_check (matrix, 0, 2))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
-{
- if (!array_check (array, 0))
- return false;
-
- if (!dim_check (dim, 1, false))
- return false;
-
- if (!dim_rank_check (dim, array, 0))
- return false;
-
- if (!kind_check (kind, 2, BT_INTEGER))
- return false;
- if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
- gfc_current_intrinsic, &kind->where))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
-{
- if (flag_coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
- return false;
- }
-
- if (!coarray_check (coarray, 0))
- return false;
-
- if (dim != NULL)
- {
- if (!dim_check (dim, 1, false))
- return false;
-
- if (!dim_corank_check (dim, coarray))
- return false;
- }
-
- if (!kind_check (kind, 2, BT_INTEGER))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
-{
- mpz_t vector_size;
-
- if (!rank_check (vector, 0, 1))
- return false;
-
- if (!array_check (mask, 1))
- return false;
-
- if (!type_check (mask, 1, BT_LOGICAL))
- return false;
-
- if (!same_type_check (vector, 0, field, 2))
- return false;
-
- if (mask->expr_type == EXPR_ARRAY
- && gfc_array_size (vector, &vector_size))
- {
- int mask_true_count = 0;
- gfc_constructor *mask_ctor;
- mask_ctor = gfc_constructor_first (mask->value.constructor);
- while (mask_ctor)
- {
- if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
- {
- mask_true_count = 0;
- break;
- }
-
- if (mask_ctor->expr->value.logical)
- mask_true_count++;
-
- mask_ctor = gfc_constructor_next (mask_ctor);
- }
-
- if (mpz_get_si (vector_size) < mask_true_count)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must "
- "provide at least as many elements as there "
- "are .TRUE. values in %qs (%ld/%d)",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &vector->where, gfc_current_intrinsic_arg[1]->name,
- mpz_get_si (vector_size), mask_true_count);
- return false;
- }
-
- mpz_clear (vector_size);
- }
-
- if (mask->rank != field->rank && field->rank != 0)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must have "
- "the same rank as %qs or be a scalar",
- gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
- &field->where, gfc_current_intrinsic_arg[1]->name);
- return false;
- }
-
- if (mask->rank == field->rank)
- {
- int i;
- for (i = 0; i < field->rank; i++)
- if (! identical_dimen_shape (mask, i, field, i))
- {
- gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
- "must have identical shape.",
- gfc_current_intrinsic_arg[2]->name,
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &field->where);
- }
- }
-
- return true;
-}
-
-
-bool
-gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
-{
- if (!type_check (x, 0, BT_CHARACTER))
- return false;
-
- if (!same_type_check (x, 0, y, 1))
- return false;
-
- if (z != NULL && !type_check (z, 2, BT_LOGICAL))
- return false;
-
- if (!kind_check (kind, 3, BT_INTEGER))
- return false;
- if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
- gfc_current_intrinsic, &kind->where))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_trim (gfc_expr *x)
-{
- if (!type_check (x, 0, BT_CHARACTER))
- return false;
-
- if (gfc_invalid_null_arg (x))
- return false;
-
- if (!scalar_check (x, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_ttynam (gfc_expr *unit)
-{
- if (!scalar_check (unit, 0))
- return false;
-
- if (!type_check (unit, 0, BT_INTEGER))
- return false;
-
- return true;
-}
-
-
-/************* Check functions for intrinsic subroutines *************/
-
-bool
-gfc_check_cpu_time (gfc_expr *time)
-{
- if (!scalar_check (time, 0))
- return false;
-
- if (!type_check (time, 0, BT_REAL))
- return false;
-
- if (!variable_check (time, 0, false))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
- gfc_expr *zone, gfc_expr *values)
-{
- if (date != NULL)
- {
- if (!type_check (date, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (date, 0, gfc_default_character_kind))
- return false;
- if (!scalar_check (date, 0))
- return false;
- if (!variable_check (date, 0, false))
- return false;
- }
-
- if (time != NULL)
- {
- if (!type_check (time, 1, BT_CHARACTER))
- return false;
- if (!kind_value_check (time, 1, gfc_default_character_kind))
- return false;
- if (!scalar_check (time, 1))
- return false;
- if (!variable_check (time, 1, false))
- return false;
- }
-
- if (zone != NULL)
- {
- if (!type_check (zone, 2, BT_CHARACTER))
- return false;
- if (!kind_value_check (zone, 2, gfc_default_character_kind))
- return false;
- if (!scalar_check (zone, 2))
- return false;
- if (!variable_check (zone, 2, false))
- return false;
- }
-
- if (values != NULL)
- {
- if (!type_check (values, 3, BT_INTEGER))
- return false;
- if (!array_check (values, 3))
- return false;
- if (!rank_check (values, 3, 1))
- return false;
- if (!variable_check (values, 3, false))
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
- gfc_expr *to, gfc_expr *topos)
-{
- if (!type_check (from, 0, BT_INTEGER))
- return false;
-
- if (!type_check (frompos, 1, BT_INTEGER))
- return false;
-
- if (!type_check (len, 2, BT_INTEGER))
- return false;
-
- if (!same_type_check (from, 0, to, 3))
- return false;
-
- if (!variable_check (to, 3, false))
- return false;
-
- if (!type_check (topos, 4, BT_INTEGER))
- return false;
-
- if (!nonnegative_check ("frompos", frompos))
- return false;
-
- if (!nonnegative_check ("topos", topos))
- return false;
-
- if (!nonnegative_check ("len", len))
- return false;
-
- if (!less_than_bitsize2 ("from", from, "frompos", frompos, "len", len))
- return false;
-
- if (!less_than_bitsize2 ("to", to, "topos", topos, "len", len))
- return false;
-
- return true;
-}
-
-
-/* Check the arguments for RANDOM_INIT. */
-
-bool
-gfc_check_random_init (gfc_expr *repeatable, gfc_expr *image_distinct)
-{
- if (!type_check (repeatable, 0, BT_LOGICAL))
- return false;
-
- if (!scalar_check (repeatable, 0))
- return false;
-
- if (!type_check (image_distinct, 1, BT_LOGICAL))
- return false;
-
- if (!scalar_check (image_distinct, 1))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_random_number (gfc_expr *harvest)
-{
- if (!type_check (harvest, 0, BT_REAL))
- return false;
-
- if (!variable_check (harvest, 0, false))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
-{
- unsigned int nargs = 0, seed_size;
- locus *where = NULL;
- mpz_t put_size, get_size;
-
- /* Keep the number of bytes in sync with master_state in
- libgfortran/intrinsics/random.c. */
- seed_size = 32 / gfc_default_integer_kind;
-
- if (size != NULL)
- {
- if (size->expr_type != EXPR_VARIABLE
- || !size->symtree->n.sym->attr.optional)
- nargs++;
-
- if (!scalar_check (size, 0))
- return false;
-
- if (!type_check (size, 0, BT_INTEGER))
- return false;
-
- if (!variable_check (size, 0, false))
- return false;
-
- if (!kind_value_check (size, 0, gfc_default_integer_kind))
- return false;
- }
-
- if (put != NULL)
- {
- if (put->expr_type != EXPR_VARIABLE
- || !put->symtree->n.sym->attr.optional)
- {
- nargs++;
- where = &put->where;
- }
-
- if (!array_check (put, 1))
- return false;
-
- if (!rank_check (put, 1, 1))
- return false;
-
- if (!type_check (put, 1, BT_INTEGER))
- return false;
-
- if (!kind_value_check (put, 1, gfc_default_integer_kind))
- return false;
-
- if (gfc_array_size (put, &put_size)
- && mpz_get_ui (put_size) < seed_size)
- gfc_error ("Size of %qs argument of %qs intrinsic at %L "
- "too small (%i/%i)",
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &put->where, (int) mpz_get_ui (put_size), seed_size);
- }
-
- if (get != NULL)
- {
- if (get->expr_type != EXPR_VARIABLE
- || !get->symtree->n.sym->attr.optional)
- {
- nargs++;
- where = &get->where;
- }
-
- if (!array_check (get, 2))
- return false;
-
- if (!rank_check (get, 2, 1))
- return false;
-
- if (!type_check (get, 2, BT_INTEGER))
- return false;
-
- if (!variable_check (get, 2, false))
- return false;
-
- if (!kind_value_check (get, 2, gfc_default_integer_kind))
- return false;
-
- if (gfc_array_size (get, &get_size)
- && mpz_get_ui (get_size) < seed_size)
- gfc_error ("Size of %qs argument of %qs intrinsic at %L "
- "too small (%i/%i)",
- gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
- &get->where, (int) mpz_get_ui (get_size), seed_size);
- }
-
- /* RANDOM_SEED may not have more than one non-optional argument. */
- if (nargs > 1)
- gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
-
- return true;
-}
-
-bool
-gfc_check_fe_runtime_error (gfc_actual_arglist *a)
-{
- gfc_expr *e;
- size_t len, i;
- int num_percent, nargs;
-
- e = a->expr;
- if (e->expr_type != EXPR_CONSTANT)
- return true;
-
- len = e->value.character.length;
- if (e->value.character.string[len-1] != '\0')
- gfc_internal_error ("fe_runtime_error string must be null terminated");
-
- num_percent = 0;
- for (i=0; i<len-1; i++)
- if (e->value.character.string[i] == '%')
- num_percent ++;
-
- nargs = 0;
- for (; a; a = a->next)
- nargs ++;
-
- if (nargs -1 != num_percent)
- gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
- nargs, num_percent++);
-
- return true;
-}
-
-bool
-gfc_check_second_sub (gfc_expr *time)
-{
- if (!scalar_check (time, 0))
- return false;
-
- if (!type_check (time, 0, BT_REAL))
- return false;
-
- if (!kind_value_check (time, 0, 4))
- return false;
-
- return true;
-}
-
-
-/* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
- variables in Fortran 95. In Fortran 2003 and later, they can be of any
- kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
- count_max are all optional arguments */
-
-bool
-gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
- gfc_expr *count_max)
-{
- if (count != NULL)
- {
- if (!scalar_check (count, 0))
- return false;
-
- if (!type_check (count, 0, BT_INTEGER))
- return false;
-
- if (count->ts.kind != gfc_default_integer_kind
- && !gfc_notify_std (GFC_STD_F2003, "COUNT argument to "
- "SYSTEM_CLOCK at %L has non-default kind",
- &count->where))
- return false;
-
- if (!variable_check (count, 0, false))
- return false;
- }
-
- if (count_rate != NULL)
- {
- if (!scalar_check (count_rate, 1))
- return false;
-
- if (!variable_check (count_rate, 1, false))
- return false;
-
- if (count_rate->ts.type == BT_REAL)
- {
- if (!gfc_notify_std (GFC_STD_F2003, "Real COUNT_RATE argument to "
- "SYSTEM_CLOCK at %L", &count_rate->where))
- return false;
- }
- else
- {
- if (!type_check (count_rate, 1, BT_INTEGER))
- return false;
-
- if (count_rate->ts.kind != gfc_default_integer_kind
- && !gfc_notify_std (GFC_STD_F2003, "COUNT_RATE argument to "
- "SYSTEM_CLOCK at %L has non-default kind",
- &count_rate->where))
- return false;
- }
-
- }
-
- if (count_max != NULL)
- {
- if (!scalar_check (count_max, 2))
- return false;
-
- if (!type_check (count_max, 2, BT_INTEGER))
- return false;
-
- if (count_max->ts.kind != gfc_default_integer_kind
- && !gfc_notify_std (GFC_STD_F2003, "COUNT_MAX argument to "
- "SYSTEM_CLOCK at %L has non-default kind",
- &count_max->where))
- return false;
-
- if (!variable_check (count_max, 2, false))
- return false;
- }
-
- return true;
-}
-
-
-bool
-gfc_check_irand (gfc_expr *x)
-{
- if (x == NULL)
- return true;
-
- if (!scalar_check (x, 0))
- return false;
-
- if (!type_check (x, 0, BT_INTEGER))
- return false;
-
- if (!kind_value_check (x, 0, 4))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
-{
- if (!scalar_check (seconds, 0))
- return false;
- if (!type_check (seconds, 0, BT_INTEGER))
- return false;
-
- if (!int_or_proc_check (handler, 1))
- return false;
- if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
- return false;
-
- if (status == NULL)
- return true;
-
- if (!scalar_check (status, 2))
- return false;
- if (!type_check (status, 2, BT_INTEGER))
- return false;
- if (!kind_value_check (status, 2, gfc_default_integer_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_rand (gfc_expr *x)
-{
- if (x == NULL)
- return true;
-
- if (!scalar_check (x, 0))
- return false;
-
- if (!type_check (x, 0, BT_INTEGER))
- return false;
-
- if (!kind_value_check (x, 0, 4))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_srand (gfc_expr *x)
-{
- if (!scalar_check (x, 0))
- return false;
-
- if (!type_check (x, 0, BT_INTEGER))
- return false;
-
- if (!kind_value_check (x, 0, 4))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
-{
- if (!scalar_check (time, 0))
- return false;
- if (!type_check (time, 0, BT_INTEGER))
- return false;
-
- if (!type_check (result, 1, BT_CHARACTER))
- return false;
- if (!kind_value_check (result, 1, gfc_default_character_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_dtime_etime (gfc_expr *x)
-{
- if (!array_check (x, 0))
- return false;
-
- if (!rank_check (x, 0, 1))
- return false;
-
- if (!variable_check (x, 0, false))
- return false;
-
- if (!type_check (x, 0, BT_REAL))
- return false;
-
- if (!kind_value_check (x, 0, 4))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
-{
- if (!array_check (values, 0))
- return false;
-
- if (!rank_check (values, 0, 1))
- return false;
-
- if (!variable_check (values, 0, false))
- return false;
-
- if (!type_check (values, 0, BT_REAL))
- return false;
-
- if (!kind_value_check (values, 0, 4))
- return false;
-
- if (!scalar_check (time, 1))
- return false;
-
- if (!type_check (time, 1, BT_REAL))
- return false;
-
- if (!kind_value_check (time, 1, 4))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_fdate_sub (gfc_expr *date)
-{
- if (!type_check (date, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (date, 0, gfc_default_character_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_gerror (gfc_expr *msg)
-{
- if (!type_check (msg, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (msg, 0, gfc_default_character_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
-{
- if (!type_check (cwd, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (cwd, 0, gfc_default_character_kind))
- return false;
-
- if (status == NULL)
- return true;
-
- if (!scalar_check (status, 1))
- return false;
-
- if (!type_check (status, 1, BT_INTEGER))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
-{
- if (!type_check (pos, 0, BT_INTEGER))
- return false;
-
- if (pos->ts.kind > gfc_default_integer_kind)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
- "not wider than the default kind (%d)",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &pos->where, gfc_default_integer_kind);
- return false;
- }
-
- if (!type_check (value, 1, BT_CHARACTER))
- return false;
- if (!kind_value_check (value, 1, gfc_default_character_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_getlog (gfc_expr *msg)
-{
- if (!type_check (msg, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (msg, 0, gfc_default_character_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_exit (gfc_expr *status)
-{
- if (status == NULL)
- return true;
-
- if (!type_check (status, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (status, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_flush (gfc_expr *unit)
-{
- if (unit == NULL)
- return true;
-
- if (!type_check (unit, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (unit, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_free (gfc_expr *i)
-{
- if (!type_check (i, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (i, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_hostnm (gfc_expr *name)
-{
- if (!type_check (name, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (name, 0, gfc_default_character_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
-{
- if (!type_check (name, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (name, 0, gfc_default_character_kind))
- return false;
-
- if (status == NULL)
- return true;
-
- if (!scalar_check (status, 1))
- return false;
-
- if (!type_check (status, 1, BT_INTEGER))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_itime_idate (gfc_expr *values)
-{
- if (!array_check (values, 0))
- return false;
-
- if (!rank_check (values, 0, 1))
- return false;
-
- if (!variable_check (values, 0, false))
- return false;
-
- if (!type_check (values, 0, BT_INTEGER))
- return false;
-
- if (!kind_value_check (values, 0, gfc_default_integer_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
-{
- if (!type_check (time, 0, BT_INTEGER))
- return false;
-
- if (!kind_value_check (time, 0, gfc_default_integer_kind))
- return false;
-
- if (!scalar_check (time, 0))
- return false;
-
- if (!array_check (values, 1))
- return false;
-
- if (!rank_check (values, 1, 1))
- return false;
-
- if (!variable_check (values, 1, false))
- return false;
-
- if (!type_check (values, 1, BT_INTEGER))
- return false;
-
- if (!kind_value_check (values, 1, gfc_default_integer_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
-{
- if (!scalar_check (unit, 0))
- return false;
-
- if (!type_check (unit, 0, BT_INTEGER))
- return false;
-
- if (!type_check (name, 1, BT_CHARACTER))
- return false;
- if (!kind_value_check (name, 1, gfc_default_character_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_is_contiguous (gfc_expr *array)
-{
- if (array->expr_type == EXPR_NULL)
- {
- gfc_error ("Actual argument at %L of %qs intrinsic shall be an "
- "associated pointer", &array->where, gfc_current_intrinsic);
- return false;
- }
-
- if (!array_check (array, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_isatty (gfc_expr *unit)
-{
- if (unit == NULL)
- return false;
-
- if (!type_check (unit, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (unit, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_isnan (gfc_expr *x)
-{
- if (!type_check (x, 0, BT_REAL))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_perror (gfc_expr *string)
-{
- if (!type_check (string, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (string, 0, gfc_default_character_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_umask (gfc_expr *mask)
-{
- if (!type_check (mask, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (mask, 0))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
-{
- if (!type_check (mask, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (mask, 0))
- return false;
-
- if (old == NULL)
- return true;
-
- if (!scalar_check (old, 1))
- return false;
-
- if (!type_check (old, 1, BT_INTEGER))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_unlink (gfc_expr *name)
-{
- if (!type_check (name, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (name, 0, gfc_default_character_kind))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
-{
- if (!type_check (name, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (name, 0, gfc_default_character_kind))
- return false;
-
- if (status == NULL)
- return true;
-
- if (!scalar_check (status, 1))
- return false;
-
- if (!type_check (status, 1, BT_INTEGER))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_signal (gfc_expr *number, gfc_expr *handler)
-{
- if (!scalar_check (number, 0))
- return false;
- if (!type_check (number, 0, BT_INTEGER))
- return false;
-
- if (!int_or_proc_check (handler, 1))
- return false;
- if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
-{
- if (!scalar_check (number, 0))
- return false;
- if (!type_check (number, 0, BT_INTEGER))
- return false;
-
- if (!int_or_proc_check (handler, 1))
- return false;
- if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
- return false;
-
- if (status == NULL)
- return true;
-
- if (!type_check (status, 2, BT_INTEGER))
- return false;
- if (!scalar_check (status, 2))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
-{
- if (!type_check (cmd, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (cmd, 0, gfc_default_character_kind))
- return false;
-
- if (!scalar_check (status, 1))
- return false;
-
- if (!type_check (status, 1, BT_INTEGER))
- return false;
-
- if (!kind_value_check (status, 1, gfc_default_integer_kind))
- return false;
-
- return true;
-}
-
-
-/* This is used for the GNU intrinsics AND, OR and XOR. */
-bool
-gfc_check_and (gfc_expr *i, gfc_expr *j)
-{
- if (i->ts.type != BT_INTEGER
- && i->ts.type != BT_LOGICAL
- && i->ts.type != BT_BOZ)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
- "LOGICAL, or a BOZ literal constant",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &i->where);
- return false;
- }
-
- if (j->ts.type != BT_INTEGER
- && j->ts.type != BT_LOGICAL
- && j->ts.type != BT_BOZ)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
- "LOGICAL, or a BOZ literal constant",
- gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic, &j->where);
- return false;
- }
-
- /* i and j cannot both be BOZ literal constants. */
- if (!boz_args_check (i, j))
- return false;
-
- /* If i is BOZ and j is integer, convert i to type of j. */
- if (i->ts.type == BT_BOZ)
- {
- if (j->ts.type != BT_INTEGER)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
- gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic, &j->where);
- reset_boz (i);
- return false;
- }
- if (!gfc_boz2int (i, j->ts.kind))
- return false;
- }
-
- /* If j is BOZ and i is integer, convert j to type of i. */
- if (j->ts.type == BT_BOZ)
- {
- if (i->ts.type != BT_INTEGER)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &j->where);
- reset_boz (j);
- return false;
- }
- if (!gfc_boz2int (j, i->ts.kind))
- return false;
- }
-
- if (!same_type_check (i, 0, j, 1, false))
- return false;
-
- if (!scalar_check (i, 0))
- return false;
-
- if (!scalar_check (j, 1))
- return false;
-
- return true;
-}
-
-
-bool
-gfc_check_storage_size (gfc_expr *a, gfc_expr *kind)
-{
-
- if (a->expr_type == EXPR_NULL)
- {
- gfc_error ("Intrinsic function NULL at %L cannot be an actual "
- "argument to STORAGE_SIZE, because it returns a "
- "disassociated pointer", &a->where);
- return false;
- }
-
- if (a->ts.type == BT_ASSUMED)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &a->where);
- return false;
- }
-
- if (a->ts.type == BT_PROCEDURE)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
- "procedure", gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic, &a->where);
- return false;
- }
-
- if (a->ts.type == BT_BOZ && illegal_boz_arg (a))
- return false;
-
- if (kind == NULL)
- return true;
-
- if (!type_check (kind, 1, BT_INTEGER))
- return false;
-
- if (!scalar_check (kind, 1))
- return false;
-
- if (kind->expr_type != EXPR_CONSTANT)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &kind->where);
- return false;
- }
-
- return true;
-}
generated by cgit v1.1 at 2025-05-28 12:40:20 +0000