aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
authorGiuliano Belinassi <giuliano.belinassi@usp.br>2020-08-22 17:43:43 -0300
committerGiuliano Belinassi <giuliano.belinassi@usp.br>2020-08-22 17:43:43 -0300
commita926878ddbd5a98b272c22171ce58663fc04c3e0 (patch)
tree86af256e5d9a9c06263c00adc90e5fe348008c43 /gcc/ada
parent542730f087133690b47e036dfd43eb0db8a650ce (diff)
parent07cbaed8ba7d1b6e4ab3a9f44175502a4e1ecdb1 (diff)
downloadgcc-devel/autopar_devel.zip
gcc-devel/autopar_devel.tar.gz
gcc-devel/autopar_devel.tar.bz2
Merge branch 'autopar_rebase2' into autopar_develdevel/autopar_devel
Quickly commit changes in the rebase branch.
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/ChangeLog8053
-rw-r--r--gcc/ada/Makefile.rtl83
-rw-r--r--gcc/ada/ada_get_targ.adb2
-rw-r--r--gcc/ada/adabkend.adb3
-rw-r--r--gcc/ada/adabkend.ads2
-rw-r--r--gcc/ada/adadecode.c2
-rw-r--r--gcc/ada/adadecode.h2
-rw-r--r--gcc/ada/adaint.c14
-rw-r--r--gcc/ada/adaint.h7
-rw-r--r--gcc/ada/affinity.c2
-rw-r--r--gcc/ada/ali-util.adb2
-rw-r--r--gcc/ada/ali-util.ads2
-rw-r--r--gcc/ada/ali.adb50
-rw-r--r--gcc/ada/ali.ads2
-rw-r--r--gcc/ada/alloc.ads2
-rw-r--r--gcc/ada/argv-lynxos178-raven-cert.c2
-rw-r--r--gcc/ada/argv.c2
-rw-r--r--gcc/ada/aspects.adb234
-rw-r--r--gcc/ada/aspects.ads193
-rw-r--r--gcc/ada/atree.adb532
-rw-r--r--gcc/ada/atree.ads354
-rw-r--r--gcc/ada/atree.h2
-rw-r--r--gcc/ada/aux-io.c2
-rw-r--r--gcc/ada/back_end.adb5
-rw-r--r--gcc/ada/back_end.ads3
-rw-r--r--gcc/ada/bcheck.adb5
-rw-r--r--gcc/ada/bcheck.ads2
-rw-r--r--gcc/ada/binde.adb6
-rw-r--r--gcc/ada/binde.ads2
-rw-r--r--gcc/ada/binderr.adb2
-rw-r--r--gcc/ada/binderr.ads2
-rw-r--r--gcc/ada/bindgen.adb33
-rw-r--r--gcc/ada/bindgen.ads2
-rw-r--r--gcc/ada/bindo-augmentors.adb40
-rw-r--r--gcc/ada/bindo-augmentors.ads10
-rw-r--r--gcc/ada/bindo-builders.adb5
-rw-r--r--gcc/ada/bindo-builders.ads2
-rw-r--r--gcc/ada/bindo-diagnostics.adb77
-rw-r--r--gcc/ada/bindo-diagnostics.ads10
-rw-r--r--gcc/ada/bindo-elaborators.adb6
-rw-r--r--gcc/ada/bindo-elaborators.ads2
-rw-r--r--gcc/ada/bindo-graphs.adb1950
-rw-r--r--gcc/ada/bindo-graphs.ads983
-rw-r--r--gcc/ada/bindo-units.adb2
-rw-r--r--gcc/ada/bindo-units.ads2
-rw-r--r--gcc/ada/bindo-validators.adb2
-rw-r--r--gcc/ada/bindo-validators.ads2
-rw-r--r--gcc/ada/bindo-writers.adb18
-rw-r--r--gcc/ada/bindo-writers.ads2
-rw-r--r--gcc/ada/bindo.adb2
-rw-r--r--gcc/ada/bindo.ads2
-rw-r--r--gcc/ada/bindusg.adb7
-rw-r--r--gcc/ada/bindusg.ads2
-rw-r--r--gcc/ada/butil.adb2
-rw-r--r--gcc/ada/butil.ads2
-rw-r--r--gcc/ada/cal.c2
-rw-r--r--gcc/ada/casing.adb2
-rw-r--r--gcc/ada/casing.ads2
-rw-r--r--gcc/ada/ceinfo.adb2
-rw-r--r--gcc/ada/checks.adb1883
-rw-r--r--gcc/ada/checks.ads150
-rw-r--r--gcc/ada/cio.c2
-rw-r--r--gcc/ada/clean.adb2
-rw-r--r--gcc/ada/clean.ads2
-rw-r--r--gcc/ada/comperr.adb16
-rw-r--r--gcc/ada/comperr.ads2
-rw-r--r--gcc/ada/contracts.adb555
-rw-r--r--gcc/ada/contracts.ads19
-rw-r--r--gcc/ada/csets.adb2
-rw-r--r--gcc/ada/csets.ads2
-rw-r--r--gcc/ada/csinfo.adb11
-rw-r--r--gcc/ada/cstand.adb196
-rw-r--r--gcc/ada/cstand.ads2
-rw-r--r--gcc/ada/cstreams.c2
-rw-r--r--gcc/ada/ctrl_c.c2
-rw-r--r--gcc/ada/debug.adb47
-rw-r--r--gcc/ada/debug.ads2
-rw-r--r--gcc/ada/debug_a.adb2
-rw-r--r--gcc/ada/debug_a.ads2
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_advice.rst35
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst7
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst32
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst194
-rw-r--r--gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst2
-rw-r--r--gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst145
-rw-r--r--gcc/ada/doc/gnat_ugn/about_this_guide.rst81
-rw-r--r--gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst43
-rw-r--r--gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst128
-rw-r--r--gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst1350
-rw-r--r--gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst47
-rw-r--r--gcc/ada/einfo.adb1042
-rw-r--r--gcc/ada/einfo.ads335
-rw-r--r--gcc/ada/elists.adb22
-rw-r--r--gcc/ada/elists.ads14
-rw-r--r--gcc/ada/elists.h2
-rw-r--r--gcc/ada/env.c2
-rw-r--r--gcc/ada/env.h2
-rw-r--r--gcc/ada/err_vars.ads2
-rw-r--r--gcc/ada/errno.c2
-rw-r--r--gcc/ada/errout.adb172
-rw-r--r--gcc/ada/errout.ads25
-rw-r--r--gcc/ada/erroutc.adb58
-rw-r--r--gcc/ada/erroutc.ads14
-rw-r--r--gcc/ada/errutil.adb41
-rw-r--r--gcc/ada/errutil.ads5
-rw-r--r--gcc/ada/eval_fat.adb2
-rw-r--r--gcc/ada/eval_fat.ads2
-rw-r--r--gcc/ada/exit.c2
-rw-r--r--gcc/ada/exp_aggr.adb1847
-rw-r--r--gcc/ada/exp_aggr.ads2
-rw-r--r--gcc/ada/exp_atag.adb211
-rw-r--r--gcc/ada/exp_atag.ads22
-rw-r--r--gcc/ada/exp_attr.adb1436
-rw-r--r--gcc/ada/exp_attr.ads2
-rw-r--r--gcc/ada/exp_cg.adb7
-rw-r--r--gcc/ada/exp_cg.ads2
-rw-r--r--gcc/ada/exp_ch10.ads2
-rw-r--r--gcc/ada/exp_ch11.adb12
-rw-r--r--gcc/ada/exp_ch11.ads2
-rw-r--r--gcc/ada/exp_ch12.adb2
-rw-r--r--gcc/ada/exp_ch12.ads2
-rw-r--r--gcc/ada/exp_ch13.adb2
-rw-r--r--gcc/ada/exp_ch13.ads2
-rw-r--r--gcc/ada/exp_ch2.adb23
-rw-r--r--gcc/ada/exp_ch2.ads2
-rw-r--r--gcc/ada/exp_ch3.adb671
-rw-r--r--gcc/ada/exp_ch3.ads19
-rw-r--r--gcc/ada/exp_ch4.adb1599
-rw-r--r--gcc/ada/exp_ch4.ads2
-rw-r--r--gcc/ada/exp_ch5.adb180
-rw-r--r--gcc/ada/exp_ch5.ads2
-rw-r--r--gcc/ada/exp_ch6.adb1711
-rw-r--r--gcc/ada/exp_ch6.ads18
-rw-r--r--gcc/ada/exp_ch7.adb129
-rw-r--r--gcc/ada/exp_ch7.ads2
-rw-r--r--gcc/ada/exp_ch8.adb9
-rw-r--r--gcc/ada/exp_ch8.ads2
-rw-r--r--gcc/ada/exp_ch9.adb939
-rw-r--r--gcc/ada/exp_ch9.ads19
-rw-r--r--gcc/ada/exp_code.adb2
-rw-r--r--gcc/ada/exp_code.ads2
-rw-r--r--gcc/ada/exp_dbug.adb16
-rw-r--r--gcc/ada/exp_dbug.ads2
-rw-r--r--gcc/ada/exp_disp.adb120
-rw-r--r--gcc/ada/exp_disp.ads31
-rw-r--r--gcc/ada/exp_dist.adb2
-rw-r--r--gcc/ada/exp_dist.ads2
-rw-r--r--gcc/ada/exp_fixd.adb147
-rw-r--r--gcc/ada/exp_fixd.ads2
-rw-r--r--gcc/ada/exp_imgv.adb90
-rw-r--r--gcc/ada/exp_imgv.ads2
-rw-r--r--gcc/ada/exp_intr.adb75
-rw-r--r--gcc/ada/exp_intr.ads2
-rw-r--r--gcc/ada/exp_pakd.adb51
-rw-r--r--gcc/ada/exp_pakd.ads11
-rw-r--r--gcc/ada/exp_prag.adb118
-rw-r--r--gcc/ada/exp_prag.ads2
-rw-r--r--gcc/ada/exp_put_image.adb1041
-rw-r--r--gcc/ada/exp_put_image.ads103
-rw-r--r--gcc/ada/exp_sel.adb2
-rw-r--r--gcc/ada/exp_sel.ads2
-rw-r--r--gcc/ada/exp_smem.adb8
-rw-r--r--gcc/ada/exp_smem.ads2
-rw-r--r--gcc/ada/exp_spark.adb329
-rw-r--r--gcc/ada/exp_spark.ads2
-rw-r--r--gcc/ada/exp_strm.adb31
-rw-r--r--gcc/ada/exp_strm.ads9
-rw-r--r--gcc/ada/exp_tss.adb40
-rw-r--r--gcc/ada/exp_tss.ads11
-rw-r--r--gcc/ada/exp_unst.adb91
-rw-r--r--gcc/ada/exp_unst.ads2
-rw-r--r--gcc/ada/exp_util.adb537
-rw-r--r--gcc/ada/exp_util.ads16
-rw-r--r--gcc/ada/expander.adb10
-rw-r--r--gcc/ada/expander.ads21
-rw-r--r--gcc/ada/expect.c9
-rw-r--r--gcc/ada/fe.h10
-rw-r--r--gcc/ada/final.c2
-rw-r--r--gcc/ada/fmap.adb2
-rw-r--r--gcc/ada/fmap.ads2
-rw-r--r--gcc/ada/fname-sf.adb2
-rw-r--r--gcc/ada/fname-sf.ads2
-rw-r--r--gcc/ada/fname-uf.adb2
-rw-r--r--gcc/ada/fname-uf.ads2
-rw-r--r--gcc/ada/fname.adb46
-rw-r--r--gcc/ada/fname.ads12
-rw-r--r--gcc/ada/freeze.adb499
-rw-r--r--gcc/ada/freeze.ads2
-rw-r--r--gcc/ada/frontend.adb24
-rw-r--r--gcc/ada/frontend.ads2
-rw-r--r--gcc/ada/gcc-interface/Make-lang.in8
-rw-r--r--gcc/ada/gcc-interface/Makefile.in6
-rw-r--r--gcc/ada/gcc-interface/ada-tree.h23
-rw-r--r--gcc/ada/gcc-interface/ada.h2
-rw-r--r--gcc/ada/gcc-interface/cuintp.c2
-rw-r--r--gcc/ada/gcc-interface/decl.c717
-rw-r--r--gcc/ada/gcc-interface/gadaint.h2
-rw-r--r--gcc/ada/gcc-interface/gigi.h75
-rw-r--r--gcc/ada/gcc-interface/lang-specs.h22
-rw-r--r--gcc/ada/gcc-interface/lang.opt4
-rw-r--r--gcc/ada/gcc-interface/misc.c153
-rw-r--r--gcc/ada/gcc-interface/targtyps.c2
-rw-r--r--gcc/ada/gcc-interface/trans.c1216
-rw-r--r--gcc/ada/gcc-interface/utils.c243
-rw-r--r--gcc/ada/gcc-interface/utils2.c70
-rw-r--r--gcc/ada/get_scos.adb2
-rw-r--r--gcc/ada/get_scos.ads2
-rw-r--r--gcc/ada/get_targ.adb2
-rw-r--r--gcc/ada/get_targ.ads2
-rw-r--r--gcc/ada/ghost.adb85
-rw-r--r--gcc/ada/ghost.ads2
-rw-r--r--gcc/ada/gnat1drv.adb84
-rw-r--r--gcc/ada/gnat1drv.ads2
-rw-r--r--gcc/ada/gnat_rm.texi2334
-rw-r--r--gcc/ada/gnat_ugn.texi2448
-rw-r--r--gcc/ada/gnatbind.adb49
-rw-r--r--gcc/ada/gnatbind.ads2
-rw-r--r--gcc/ada/gnatchop.adb2
-rw-r--r--gcc/ada/gnatclean.adb2
-rw-r--r--gcc/ada/gnatcmd.adb2
-rw-r--r--gcc/ada/gnatcmd.ads2
-rw-r--r--gcc/ada/gnatdll.adb2
-rw-r--r--gcc/ada/gnatfind.adb2
-rw-r--r--gcc/ada/gnatkr.adb2
-rw-r--r--gcc/ada/gnatkr.ads2
-rw-r--r--gcc/ada/gnatlink.adb2
-rw-r--r--gcc/ada/gnatlink.ads2
-rw-r--r--gcc/ada/gnatls.adb2
-rw-r--r--gcc/ada/gnatls.ads2
-rw-r--r--gcc/ada/gnatmake.adb2
-rw-r--r--gcc/ada/gnatmake.ads2
-rw-r--r--gcc/ada/gnatname.adb4
-rw-r--r--gcc/ada/gnatname.ads2
-rw-r--r--gcc/ada/gnatprep.adb2
-rw-r--r--gcc/ada/gnatprep.ads2
-rw-r--r--gcc/ada/gnatvsn.adb2
-rw-r--r--gcc/ada/gnatvsn.ads2
-rw-r--r--gcc/ada/gnatxref.adb2
-rw-r--r--gcc/ada/gprep.adb2
-rw-r--r--gcc/ada/gprep.ads2
-rw-r--r--gcc/ada/gsocket.h2
-rw-r--r--gcc/ada/hostparm.ads2
-rw-r--r--gcc/ada/impunit.adb21
-rw-r--r--gcc/ada/impunit.ads2
-rw-r--r--gcc/ada/indepsw-aix.adb2
-rw-r--r--gcc/ada/indepsw-darwin.adb2
-rw-r--r--gcc/ada/indepsw-gnu.adb2
-rw-r--r--gcc/ada/indepsw.adb2
-rw-r--r--gcc/ada/indepsw.ads2
-rw-r--r--gcc/ada/init.c3
-rw-r--r--gcc/ada/initialize.c2
-rw-r--r--gcc/ada/inline.adb764
-rw-r--r--gcc/ada/inline.ads8
-rw-r--r--gcc/ada/itypes.adb7
-rw-r--r--gcc/ada/itypes.ads2
-rw-r--r--gcc/ada/krunch.adb2
-rw-r--r--gcc/ada/krunch.ads2
-rw-r--r--gcc/ada/layout.adb18
-rw-r--r--gcc/ada/layout.ads2
-rw-r--r--gcc/ada/lib-list.adb2
-rw-r--r--gcc/ada/lib-load.adb2
-rw-r--r--gcc/ada/lib-load.ads2
-rw-r--r--gcc/ada/lib-sort.adb2
-rw-r--r--gcc/ada/lib-util.adb2
-rw-r--r--gcc/ada/lib-util.ads2
-rw-r--r--gcc/ada/lib-writ.adb8
-rw-r--r--gcc/ada/lib-writ.ads4
-rw-r--r--gcc/ada/lib-xref-spark_specific.adb20
-rw-r--r--gcc/ada/lib-xref.adb48
-rw-r--r--gcc/ada/lib-xref.ads5
-rw-r--r--gcc/ada/lib.adb92
-rw-r--r--gcc/ada/lib.ads17
-rw-r--r--gcc/ada/libgnarl/a-astaco.adb2
-rw-r--r--gcc/ada/libgnarl/a-dispat.adb2
-rw-r--r--gcc/ada/libgnarl/a-dynpri.adb12
-rw-r--r--gcc/ada/libgnarl/a-etgrbu.ads2
-rw-r--r--gcc/ada/libgnarl/a-exetim__darwin.adb2
-rw-r--r--gcc/ada/libgnarl/a-exetim__default.ads2
-rw-r--r--gcc/ada/libgnarl/a-exetim__mingw.adb2
-rw-r--r--gcc/ada/libgnarl/a-exetim__mingw.ads2
-rw-r--r--gcc/ada/libgnarl/a-exetim__posix.adb2
-rw-r--r--gcc/ada/libgnarl/a-interr.adb2
-rw-r--r--gcc/ada/libgnarl/a-interr.ads2
-rw-r--r--gcc/ada/libgnarl/a-intnam.ads2
-rw-r--r--gcc/ada/libgnarl/a-intnam__aix.ads2
-rw-r--r--gcc/ada/libgnarl/a-intnam__darwin.ads2
-rw-r--r--gcc/ada/libgnarl/a-intnam__dragonfly.ads2
-rw-r--r--gcc/ada/libgnarl/a-intnam__dummy.ads2
-rw-r--r--gcc/ada/libgnarl/a-intnam__freebsd.ads2
-rw-r--r--gcc/ada/libgnarl/a-intnam__hpux.ads2
-rw-r--r--gcc/ada/libgnarl/a-intnam__linux.ads2
-rw-r--r--gcc/ada/libgnarl/a-intnam__lynxos.ads2
-rw-r--r--gcc/ada/libgnarl/a-intnam__mingw.ads2
-rw-r--r--gcc/ada/libgnarl/a-intnam__qnx.ads2
-rw-r--r--gcc/ada/libgnarl/a-intnam__rtems.ads2
-rw-r--r--gcc/ada/libgnarl/a-intnam__solaris.ads2
-rw-r--r--gcc/ada/libgnarl/a-intnam__vxworks.ads2
-rw-r--r--gcc/ada/libgnarl/a-reatim.adb2
-rw-r--r--gcc/ada/libgnarl/a-reatim.ads2
-rw-r--r--gcc/ada/libgnarl/a-retide.adb2
-rw-r--r--gcc/ada/libgnarl/a-retide.ads2
-rw-r--r--gcc/ada/libgnarl/a-rttiev.adb2
-rw-r--r--gcc/ada/libgnarl/a-rttiev.ads2
-rw-r--r--gcc/ada/libgnarl/a-synbar.adb4
-rw-r--r--gcc/ada/libgnarl/a-synbar.ads4
-rw-r--r--gcc/ada/libgnarl/a-synbar__posix.adb4
-rw-r--r--gcc/ada/libgnarl/a-synbar__posix.ads4
-rw-r--r--gcc/ada/libgnarl/a-sytaco.adb2
-rw-r--r--gcc/ada/libgnarl/a-sytaco.ads2
-rw-r--r--gcc/ada/libgnarl/a-tasatt.adb2
-rw-r--r--gcc/ada/libgnarl/a-tasatt.ads2
-rw-r--r--gcc/ada/libgnarl/a-taside.adb28
-rw-r--r--gcc/ada/libgnarl/a-taside.ads2
-rw-r--r--gcc/ada/libgnarl/a-tasini.adb46
-rw-r--r--gcc/ada/libgnarl/a-tasini.ads42
-rw-r--r--gcc/ada/libgnarl/a-taster.adb35
-rw-r--r--gcc/ada/libgnarl/g-boubuf.adb2
-rw-r--r--gcc/ada/libgnarl/g-boubuf.ads2
-rw-r--r--gcc/ada/libgnarl/g-boumai.ads2
-rw-r--r--gcc/ada/libgnarl/g-semaph.adb2
-rw-r--r--gcc/ada/libgnarl/g-semaph.ads2
-rw-r--r--gcc/ada/libgnarl/g-signal.adb2
-rw-r--r--gcc/ada/libgnarl/g-signal.ads2
-rw-r--r--gcc/ada/libgnarl/g-tastus.ads2
-rw-r--r--gcc/ada/libgnarl/g-thread.adb2
-rw-r--r--gcc/ada/libgnarl/g-thread.ads2
-rw-r--r--gcc/ada/libgnarl/i-vxinco.adb2
-rw-r--r--gcc/ada/libgnarl/i-vxinco.ads2
-rw-r--r--gcc/ada/libgnarl/libgnarl.gpr28
-rw-r--r--gcc/ada/libgnarl/s-inmaop.ads2
-rw-r--r--gcc/ada/libgnarl/s-inmaop__dummy.adb2
-rw-r--r--gcc/ada/libgnarl/s-inmaop__posix.adb2
-rw-r--r--gcc/ada/libgnarl/s-inmaop__vxworks.adb2
-rw-r--r--gcc/ada/libgnarl/s-interr.adb43
-rw-r--r--gcc/ada/libgnarl/s-interr.ads2
-rw-r--r--gcc/ada/libgnarl/s-interr__dummy.adb2
-rw-r--r--gcc/ada/libgnarl/s-interr__hwint.adb2
-rw-r--r--gcc/ada/libgnarl/s-interr__sigaction.adb14
-rw-r--r--gcc/ada/libgnarl/s-interr__vxworks.adb2
-rw-r--r--gcc/ada/libgnarl/s-intman.ads2
-rw-r--r--gcc/ada/libgnarl/s-intman__android.adb2
-rw-r--r--gcc/ada/libgnarl/s-intman__dummy.adb2
-rw-r--r--gcc/ada/libgnarl/s-intman__lynxos.adb2
-rw-r--r--gcc/ada/libgnarl/s-intman__mingw.adb2
-rw-r--r--gcc/ada/libgnarl/s-intman__posix.adb2
-rw-r--r--gcc/ada/libgnarl/s-intman__qnx.adb2
-rw-r--r--gcc/ada/libgnarl/s-intman__solaris.adb2
-rw-r--r--gcc/ada/libgnarl/s-intman__susv3.adb2
-rw-r--r--gcc/ada/libgnarl/s-intman__vxworks.adb2
-rw-r--r--gcc/ada/libgnarl/s-intman__vxworks.ads2
-rw-r--r--gcc/ada/libgnarl/s-linux.ads2
-rw-r--r--gcc/ada/libgnarl/s-linux__alpha.ads2
-rw-r--r--gcc/ada/libgnarl/s-linux__android.ads2
-rw-r--r--gcc/ada/libgnarl/s-linux__hppa.ads2
-rw-r--r--gcc/ada/libgnarl/s-linux__mips.ads2
-rw-r--r--gcc/ada/libgnarl/s-linux__riscv.ads2
-rw-r--r--gcc/ada/libgnarl/s-linux__sparc.ads2
-rw-r--r--gcc/ada/libgnarl/s-linux__x32.ads2
-rw-r--r--gcc/ada/libgnarl/s-mudido.adb2
-rw-r--r--gcc/ada/libgnarl/s-mudido__affinity.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__aix.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__aix.ads2
-rw-r--r--gcc/ada/libgnarl/s-osinte__android.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__android.ads2
-rw-r--r--gcc/ada/libgnarl/s-osinte__darwin.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__darwin.ads2
-rw-r--r--gcc/ada/libgnarl/s-osinte__dragonfly.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__dragonfly.ads2
-rw-r--r--gcc/ada/libgnarl/s-osinte__dummy.ads2
-rw-r--r--gcc/ada/libgnarl/s-osinte__freebsd.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__freebsd.ads2
-rw-r--r--gcc/ada/libgnarl/s-osinte__gnu.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__gnu.ads2
-rw-r--r--gcc/ada/libgnarl/s-osinte__hpux-dce.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__hpux-dce.ads2
-rw-r--r--gcc/ada/libgnarl/s-osinte__hpux.ads2
-rw-r--r--gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads2
-rw-r--r--gcc/ada/libgnarl/s-osinte__linux.ads20
-rw-r--r--gcc/ada/libgnarl/s-osinte__lynxos178.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__lynxos178e.ads2
-rw-r--r--gcc/ada/libgnarl/s-osinte__mingw.ads2
-rw-r--r--gcc/ada/libgnarl/s-osinte__posix.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__qnx.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__qnx.ads2
-rw-r--r--gcc/ada/libgnarl/s-osinte__rtems.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__rtems.ads2
-rw-r--r--gcc/ada/libgnarl/s-osinte__solaris.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__solaris.ads2
-rw-r--r--gcc/ada/libgnarl/s-osinte__vxworks.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__vxworks.ads2
-rw-r--r--gcc/ada/libgnarl/s-osinte__x32.adb2
-rw-r--r--gcc/ada/libgnarl/s-proinf.adb2
-rw-r--r--gcc/ada/libgnarl/s-proinf.ads2
-rw-r--r--gcc/ada/libgnarl/s-qnx.ads2
-rw-r--r--gcc/ada/libgnarl/s-solita.adb2
-rw-r--r--gcc/ada/libgnarl/s-solita.ads2
-rw-r--r--gcc/ada/libgnarl/s-stusta.adb2
-rw-r--r--gcc/ada/libgnarl/s-stusta.ads2
-rw-r--r--gcc/ada/libgnarl/s-taasde.adb33
-rw-r--r--gcc/ada/libgnarl/s-taasde.ads2
-rw-r--r--gcc/ada/libgnarl/s-tadeca.adb2
-rw-r--r--gcc/ada/libgnarl/s-tadeca.ads2
-rw-r--r--gcc/ada/libgnarl/s-tadert.adb2
-rw-r--r--gcc/ada/libgnarl/s-tadert.ads2
-rw-r--r--gcc/ada/libgnarl/s-taenca.adb84
-rw-r--r--gcc/ada/libgnarl/s-taenca.ads5
-rw-r--r--gcc/ada/libgnarl/s-taprob.adb2
-rw-r--r--gcc/ada/libgnarl/s-taprob.ads2
-rw-r--r--gcc/ada/libgnarl/s-taprop.ads27
-rw-r--r--gcc/ada/libgnarl/s-taprop__dummy.adb2
-rw-r--r--gcc/ada/libgnarl/s-taprop__hpux-dce.adb105
-rw-r--r--gcc/ada/libgnarl/s-taprop__linux.adb72
-rw-r--r--gcc/ada/libgnarl/s-taprop__mingw.adb99
-rw-r--r--gcc/ada/libgnarl/s-taprop__posix.adb122
-rw-r--r--gcc/ada/libgnarl/s-taprop__qnx.adb72
-rw-r--r--gcc/ada/libgnarl/s-taprop__solaris.adb155
-rw-r--r--gcc/ada/libgnarl/s-taprop__vxworks.adb111
-rw-r--r--gcc/ada/libgnarl/s-tarest.adb52
-rw-r--r--gcc/ada/libgnarl/s-tarest.ads2
-rw-r--r--gcc/ada/libgnarl/s-tasdeb.adb2
-rw-r--r--gcc/ada/libgnarl/s-tasdeb.ads2
-rw-r--r--gcc/ada/libgnarl/s-tasinf.adb2
-rw-r--r--gcc/ada/libgnarl/s-tasinf.ads2
-rw-r--r--gcc/ada/libgnarl/s-tasinf__linux.adb2
-rw-r--r--gcc/ada/libgnarl/s-tasinf__linux.ads2
-rw-r--r--gcc/ada/libgnarl/s-tasinf__mingw.adb2
-rw-r--r--gcc/ada/libgnarl/s-tasinf__mingw.ads2
-rw-r--r--gcc/ada/libgnarl/s-tasinf__solaris.adb2
-rw-r--r--gcc/ada/libgnarl/s-tasinf__solaris.ads2
-rw-r--r--gcc/ada/libgnarl/s-tasinf__vxworks.ads2
-rw-r--r--gcc/ada/libgnarl/s-tasini.adb17
-rw-r--r--gcc/ada/libgnarl/s-tasini.ads2
-rw-r--r--gcc/ada/libgnarl/s-taskin.adb2
-rw-r--r--gcc/ada/libgnarl/s-taskin.ads10
-rw-r--r--gcc/ada/libgnarl/s-taspri__dummy.ads2
-rw-r--r--gcc/ada/libgnarl/s-taspri__hpux-dce.ads2
-rw-r--r--gcc/ada/libgnarl/s-taspri__lynxos.ads2
-rw-r--r--gcc/ada/libgnarl/s-taspri__mingw.ads2
-rw-r--r--gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads2
-rw-r--r--gcc/ada/libgnarl/s-taspri__posix.ads2
-rw-r--r--gcc/ada/libgnarl/s-taspri__solaris.ads2
-rw-r--r--gcc/ada/libgnarl/s-taspri__vxworks.ads2
-rw-r--r--gcc/ada/libgnarl/s-tasque.adb15
-rw-r--r--gcc/ada/libgnarl/s-tasque.ads7
-rw-r--r--gcc/ada/libgnarl/s-tasren.adb199
-rw-r--r--gcc/ada/libgnarl/s-tasren.ads5
-rw-r--r--gcc/ada/libgnarl/s-tasres.ads2
-rw-r--r--gcc/ada/libgnarl/s-tassta.adb138
-rw-r--r--gcc/ada/libgnarl/s-tassta.ads2
-rw-r--r--gcc/ada/libgnarl/s-tasuti.adb16
-rw-r--r--gcc/ada/libgnarl/s-tasuti.ads7
-rw-r--r--gcc/ada/libgnarl/s-tataat.adb2
-rw-r--r--gcc/ada/libgnarl/s-tataat.ads2
-rw-r--r--gcc/ada/libgnarl/s-tpinop.adb2
-rw-r--r--gcc/ada/libgnarl/s-tpinop.ads2
-rw-r--r--gcc/ada/libgnarl/s-tpoaal.adb2
-rw-r--r--gcc/ada/libgnarl/s-tpoben.adb23
-rw-r--r--gcc/ada/libgnarl/s-tpoben.ads2
-rw-r--r--gcc/ada/libgnarl/s-tpobmu.adb2
-rw-r--r--gcc/ada/libgnarl/s-tpobmu.ads2
-rw-r--r--gcc/ada/libgnarl/s-tpobop.adb121
-rw-r--r--gcc/ada/libgnarl/s-tpobop.ads2
-rw-r--r--gcc/ada/libgnarl/s-tpopmo.adb19
-rw-r--r--gcc/ada/libgnarl/s-tpopsp__posix-foreign.adb2
-rw-r--r--gcc/ada/libgnarl/s-tpopsp__posix.adb2
-rw-r--r--gcc/ada/libgnarl/s-tpopsp__solaris.adb2
-rw-r--r--gcc/ada/libgnarl/s-tpopsp__tls.adb2
-rw-r--r--gcc/ada/libgnarl/s-tpopsp__vxworks-rtp.adb2
-rw-r--r--gcc/ada/libgnarl/s-tpopsp__vxworks-tls.adb2
-rw-r--r--gcc/ada/libgnarl/s-tpopsp__vxworks.adb2
-rw-r--r--gcc/ada/libgnarl/s-tporft.adb2
-rw-r--r--gcc/ada/libgnarl/s-tposen.adb38
-rw-r--r--gcc/ada/libgnarl/s-tposen.ads2
-rw-r--r--gcc/ada/libgnarl/s-vxwext.adb2
-rw-r--r--gcc/ada/libgnarl/s-vxwext.ads2
-rw-r--r--gcc/ada/libgnarl/s-vxwext__kernel-smp.adb2
-rw-r--r--gcc/ada/libgnarl/s-vxwext__kernel.adb2
-rw-r--r--gcc/ada/libgnarl/s-vxwext__kernel.ads2
-rw-r--r--gcc/ada/libgnarl/s-vxwext__noints.adb2
-rw-r--r--gcc/ada/libgnarl/s-vxwext__rtp-smp.adb2
-rw-r--r--gcc/ada/libgnarl/s-vxwext__rtp.adb2
-rw-r--r--gcc/ada/libgnarl/s-vxwext__rtp.ads2
-rw-r--r--gcc/ada/libgnarl/s-vxwext__vthreads.ads2
-rw-r--r--gcc/ada/libgnarl/s-vxwork__aarch64.ads2
-rw-r--r--gcc/ada/libgnarl/s-vxwork__arm.ads2
-rw-r--r--gcc/ada/libgnarl/s-vxwork__ppc.ads2
-rw-r--r--gcc/ada/libgnarl/s-vxwork__x86.ads2
-rw-r--r--gcc/ada/libgnarl/thread.c2
-rw-r--r--gcc/ada/libgnat/a-assert.adb2
-rw-r--r--gcc/ada/libgnat/a-assert.ads2
-rw-r--r--gcc/ada/libgnat/a-btgbso.adb2
-rw-r--r--gcc/ada/libgnat/a-btgbso.ads2
-rw-r--r--gcc/ada/libgnat/a-calari.adb2
-rw-r--r--gcc/ada/libgnat/a-calari.ads2
-rw-r--r--gcc/ada/libgnat/a-calcon.adb3
-rw-r--r--gcc/ada/libgnat/a-calcon.ads5
-rw-r--r--gcc/ada/libgnat/a-caldel.adb4
-rw-r--r--gcc/ada/libgnat/a-caldel.ads2
-rw-r--r--gcc/ada/libgnat/a-calend.adb22
-rw-r--r--gcc/ada/libgnat/a-calend.ads30
-rw-r--r--gcc/ada/libgnat/a-calfor.adb2
-rw-r--r--gcc/ada/libgnat/a-calfor.ads10
-rw-r--r--gcc/ada/libgnat/a-catizo.adb12
-rw-r--r--gcc/ada/libgnat/a-catizo.ads5
-rw-r--r--gcc/ada/libgnat/a-cbdlli.adb60
-rw-r--r--gcc/ada/libgnat/a-cbdlli.ads6
-rw-r--r--gcc/ada/libgnat/a-cbhama.adb18
-rw-r--r--gcc/ada/libgnat/a-cbhama.ads6
-rw-r--r--gcc/ada/libgnat/a-cbhase.adb14
-rw-r--r--gcc/ada/libgnat/a-cbhase.ads6
-rw-r--r--gcc/ada/libgnat/a-cbmutr.adb66
-rw-r--r--gcc/ada/libgnat/a-cbmutr.ads6
-rw-r--r--gcc/ada/libgnat/a-cborma.adb14
-rw-r--r--gcc/ada/libgnat/a-cborma.ads6
-rw-r--r--gcc/ada/libgnat/a-cborse.adb18
-rw-r--r--gcc/ada/libgnat/a-cborse.ads6
-rw-r--r--gcc/ada/libgnat/a-cbprqu.adb6
-rw-r--r--gcc/ada/libgnat/a-cbprqu.ads6
-rw-r--r--gcc/ada/libgnat/a-cbsyqu.adb6
-rw-r--r--gcc/ada/libgnat/a-cbsyqu.ads6
-rw-r--r--gcc/ada/libgnat/a-cdlili.adb52
-rw-r--r--gcc/ada/libgnat/a-cdlili.ads6
-rw-r--r--gcc/ada/libgnat/a-cfdlli.adb2
-rw-r--r--gcc/ada/libgnat/a-cfdlli.ads9
-rw-r--r--gcc/ada/libgnat/a-cfhama.adb2
-rw-r--r--gcc/ada/libgnat/a-cfhama.ads9
-rw-r--r--gcc/ada/libgnat/a-cfhase.adb2
-rw-r--r--gcc/ada/libgnat/a-cfhase.ads9
-rw-r--r--gcc/ada/libgnat/a-cfinve.adb2
-rw-r--r--gcc/ada/libgnat/a-cfinve.ads2
-rw-r--r--gcc/ada/libgnat/a-cforma.adb2
-rw-r--r--gcc/ada/libgnat/a-cforma.ads9
-rw-r--r--gcc/ada/libgnat/a-cforse.adb2
-rw-r--r--gcc/ada/libgnat/a-cforse.ads9
-rw-r--r--gcc/ada/libgnat/a-cgaaso.adb2
-rw-r--r--gcc/ada/libgnat/a-cgaaso.ads2
-rw-r--r--gcc/ada/libgnat/a-cgarso.adb2
-rw-r--r--gcc/ada/libgnat/a-cgcaso.adb2
-rw-r--r--gcc/ada/libgnat/a-chacon.adb2
-rw-r--r--gcc/ada/libgnat/a-chacon.ads2
-rw-r--r--gcc/ada/libgnat/a-chahan.adb13
-rw-r--r--gcc/ada/libgnat/a-chahan.ads3
-rw-r--r--gcc/ada/libgnat/a-chlat9.ads2
-rw-r--r--gcc/ada/libgnat/a-chtgbk.adb11
-rw-r--r--gcc/ada/libgnat/a-chtgbk.ads2
-rw-r--r--gcc/ada/libgnat/a-chtgbo.adb2
-rw-r--r--gcc/ada/libgnat/a-chtgbo.ads2
-rw-r--r--gcc/ada/libgnat/a-chtgke.adb4
-rw-r--r--gcc/ada/libgnat/a-chtgke.ads2
-rw-r--r--gcc/ada/libgnat/a-chtgop.adb2
-rw-r--r--gcc/ada/libgnat/a-chtgop.ads2
-rw-r--r--gcc/ada/libgnat/a-chzla1.ads2
-rw-r--r--gcc/ada/libgnat/a-chzla9.ads2
-rw-r--r--gcc/ada/libgnat/a-cidlli.adb48
-rw-r--r--gcc/ada/libgnat/a-cidlli.ads6
-rw-r--r--gcc/ada/libgnat/a-cihama.adb18
-rw-r--r--gcc/ada/libgnat/a-cihama.ads6
-rw-r--r--gcc/ada/libgnat/a-cihase.adb18
-rw-r--r--gcc/ada/libgnat/a-cihase.ads6
-rw-r--r--gcc/ada/libgnat/a-cimutr.adb62
-rw-r--r--gcc/ada/libgnat/a-cimutr.ads6
-rw-r--r--gcc/ada/libgnat/a-ciorma.adb14
-rw-r--r--gcc/ada/libgnat/a-ciorma.ads6
-rw-r--r--gcc/ada/libgnat/a-ciormu.adb6
-rw-r--r--gcc/ada/libgnat/a-ciormu.ads6
-rw-r--r--gcc/ada/libgnat/a-ciorse.adb14
-rw-r--r--gcc/ada/libgnat/a-ciorse.ads6
-rw-r--r--gcc/ada/libgnat/a-clrefi.adb2
-rw-r--r--gcc/ada/libgnat/a-clrefi.ads2
-rw-r--r--gcc/ada/libgnat/a-coboho.adb2
-rw-r--r--gcc/ada/libgnat/a-coboho.ads2
-rw-r--r--gcc/ada/libgnat/a-cobove.adb73
-rw-r--r--gcc/ada/libgnat/a-cobove.ads2
-rw-r--r--gcc/ada/libgnat/a-cofove.adb6
-rw-r--r--gcc/ada/libgnat/a-cofove.ads2
-rw-r--r--gcc/ada/libgnat/a-cofuba.adb2
-rw-r--r--gcc/ada/libgnat/a-cofuba.ads2
-rw-r--r--gcc/ada/libgnat/a-cofuma.adb2
-rw-r--r--gcc/ada/libgnat/a-cofuma.ads2
-rw-r--r--gcc/ada/libgnat/a-cofuse.adb2
-rw-r--r--gcc/ada/libgnat/a-cofuse.ads2
-rw-r--r--gcc/ada/libgnat/a-cofuve.adb2
-rw-r--r--gcc/ada/libgnat/a-cofuve.ads5
-rw-r--r--gcc/ada/libgnat/a-cogeso.adb2
-rw-r--r--gcc/ada/libgnat/a-cogeso.ads2
-rw-r--r--gcc/ada/libgnat/a-cohama.adb18
-rw-r--r--gcc/ada/libgnat/a-cohama.ads6
-rw-r--r--gcc/ada/libgnat/a-cohase.adb14
-rw-r--r--gcc/ada/libgnat/a-cohase.ads6
-rw-r--r--gcc/ada/libgnat/a-cohata.ads2
-rw-r--r--gcc/ada/libgnat/a-coinho.adb26
-rw-r--r--gcc/ada/libgnat/a-coinho.ads4
-rw-r--r--gcc/ada/libgnat/a-coinho__shared.adb26
-rw-r--r--gcc/ada/libgnat/a-coinho__shared.ads4
-rw-r--r--gcc/ada/libgnat/a-coinve.adb70
-rw-r--r--gcc/ada/libgnat/a-coinve.ads6
-rw-r--r--gcc/ada/libgnat/a-colien.adb2
-rw-r--r--gcc/ada/libgnat/a-colien.ads2
-rw-r--r--gcc/ada/libgnat/a-colire.adb2
-rw-r--r--gcc/ada/libgnat/a-colire.ads2
-rw-r--r--gcc/ada/libgnat/a-comlin.adb2
-rw-r--r--gcc/ada/libgnat/a-comlin.ads2
-rw-r--r--gcc/ada/libgnat/a-comutr.adb66
-rw-r--r--gcc/ada/libgnat/a-comutr.ads6
-rw-r--r--gcc/ada/libgnat/a-conhel.adb2
-rw-r--r--gcc/ada/libgnat/a-conhel.ads2
-rw-r--r--gcc/ada/libgnat/a-convec.adb102
-rw-r--r--gcc/ada/libgnat/a-convec.ads12
-rw-r--r--gcc/ada/libgnat/a-coorma.adb14
-rw-r--r--gcc/ada/libgnat/a-coorma.ads6
-rw-r--r--gcc/ada/libgnat/a-coormu.adb6
-rw-r--r--gcc/ada/libgnat/a-coormu.ads6
-rw-r--r--gcc/ada/libgnat/a-coorse.adb14
-rw-r--r--gcc/ada/libgnat/a-coorse.ads6
-rw-r--r--gcc/ada/libgnat/a-coprnu.adb2
-rw-r--r--gcc/ada/libgnat/a-coprnu.ads2
-rw-r--r--gcc/ada/libgnat/a-crbltr.ads2
-rw-r--r--gcc/ada/libgnat/a-crbtgk.adb6
-rw-r--r--gcc/ada/libgnat/a-crbtgk.ads2
-rw-r--r--gcc/ada/libgnat/a-crbtgo.adb6
-rw-r--r--gcc/ada/libgnat/a-crbtgo.ads2
-rw-r--r--gcc/ada/libgnat/a-crdlli.adb2
-rw-r--r--gcc/ada/libgnat/a-crdlli.ads2
-rw-r--r--gcc/ada/libgnat/a-csquin.ads2
-rw-r--r--gcc/ada/libgnat/a-cuprqu.adb2
-rw-r--r--gcc/ada/libgnat/a-cuprqu.ads2
-rw-r--r--gcc/ada/libgnat/a-cusyqu.adb2
-rw-r--r--gcc/ada/libgnat/a-cusyqu.ads2
-rw-r--r--gcc/ada/libgnat/a-cwila1.ads2
-rw-r--r--gcc/ada/libgnat/a-cwila9.ads2
-rw-r--r--gcc/ada/libgnat/a-decima.adb2
-rw-r--r--gcc/ada/libgnat/a-decima.ads2
-rw-r--r--gcc/ada/libgnat/a-dhfina.adb2
-rw-r--r--gcc/ada/libgnat/a-dhfina.ads2
-rw-r--r--gcc/ada/libgnat/a-diocst.adb2
-rw-r--r--gcc/ada/libgnat/a-diocst.ads2
-rw-r--r--gcc/ada/libgnat/a-direct.adb2
-rw-r--r--gcc/ada/libgnat/a-direct.ads2
-rw-r--r--gcc/ada/libgnat/a-direio.adb2
-rw-r--r--gcc/ada/libgnat/a-direio.ads2
-rw-r--r--gcc/ada/libgnat/a-dirval.adb2
-rw-r--r--gcc/ada/libgnat/a-dirval.ads2
-rw-r--r--gcc/ada/libgnat/a-dirval__mingw.adb2
-rw-r--r--gcc/ada/libgnat/a-einuoc.adb2
-rw-r--r--gcc/ada/libgnat/a-einuoc.ads2
-rw-r--r--gcc/ada/libgnat/a-elchha.adb2
-rw-r--r--gcc/ada/libgnat/a-elchha.ads2
-rw-r--r--gcc/ada/libgnat/a-elchha__vxworks-ppc-full.adb2
-rw-r--r--gcc/ada/libgnat/a-envvar.adb2
-rw-r--r--gcc/ada/libgnat/a-excach.adb2
-rw-r--r--gcc/ada/libgnat/a-except.adb6
-rw-r--r--gcc/ada/libgnat/a-except.ads2
-rw-r--r--gcc/ada/libgnat/a-excpol.adb2
-rw-r--r--gcc/ada/libgnat/a-excpol__abort.adb2
-rw-r--r--gcc/ada/libgnat/a-exctra.adb2
-rw-r--r--gcc/ada/libgnat/a-exctra.ads2
-rw-r--r--gcc/ada/libgnat/a-exexda.adb2
-rw-r--r--gcc/ada/libgnat/a-exexpr.adb2
-rw-r--r--gcc/ada/libgnat/a-exextr.adb26
-rw-r--r--gcc/ada/libgnat/a-exstat.adb2
-rw-r--r--gcc/ada/libgnat/a-finali.adb2
-rw-r--r--gcc/ada/libgnat/a-finali.ads2
-rw-r--r--gcc/ada/libgnat/a-locale.adb2
-rw-r--r--gcc/ada/libgnat/a-locale.ads2
-rw-r--r--gcc/ada/libgnat/a-nbnbin.adb183
-rw-r--r--gcc/ada/libgnat/a-nbnbin.ads150
-rw-r--r--gcc/ada/libgnat/a-nbnbin__gmp.adb118
-rw-r--r--gcc/ada/libgnat/a-nbnbre.adb88
-rw-r--r--gcc/ada/libgnat/a-nbnbre.ads154
-rw-r--r--gcc/ada/libgnat/a-ngcefu.adb2
-rw-r--r--gcc/ada/libgnat/a-ngcoar.adb2
-rw-r--r--gcc/ada/libgnat/a-ngcoty.adb12
-rw-r--r--gcc/ada/libgnat/a-ngcoty.ads2
-rw-r--r--gcc/ada/libgnat/a-ngelfu.adb4
-rw-r--r--gcc/ada/libgnat/a-ngelfu.ads2
-rw-r--r--gcc/ada/libgnat/a-ngrear.adb4
-rw-r--r--gcc/ada/libgnat/a-ngrear.ads2
-rw-r--r--gcc/ada/libgnat/a-nubinu.ads4
-rw-r--r--gcc/ada/libgnat/a-nudira.adb13
-rw-r--r--gcc/ada/libgnat/a-nudira.ads8
-rw-r--r--gcc/ada/libgnat/a-nuflra.adb2
-rw-r--r--gcc/ada/libgnat/a-nuflra.ads2
-rw-r--r--gcc/ada/libgnat/a-numaux.ads2
-rw-r--r--gcc/ada/libgnat/a-numaux__darwin.adb2
-rw-r--r--gcc/ada/libgnat/a-numaux__darwin.ads2
-rw-r--r--gcc/ada/libgnat/a-numaux__dummy.adb32
-rw-r--r--gcc/ada/libgnat/a-numaux__libc-x86.ads2
-rw-r--r--gcc/ada/libgnat/a-numaux__vxworks.ads2
-rw-r--r--gcc/ada/libgnat/a-numaux__x86.adb577
-rw-r--r--gcc/ada/libgnat/a-rbtgbk.adb2
-rw-r--r--gcc/ada/libgnat/a-rbtgbk.ads2
-rw-r--r--gcc/ada/libgnat/a-rbtgbo.adb2
-rw-r--r--gcc/ada/libgnat/a-rbtgbo.ads2
-rw-r--r--gcc/ada/libgnat/a-rbtgso.adb8
-rw-r--r--gcc/ada/libgnat/a-rbtgso.ads2
-rw-r--r--gcc/ada/libgnat/a-sbecin.adb2
-rw-r--r--gcc/ada/libgnat/a-sbecin.ads2
-rw-r--r--gcc/ada/libgnat/a-sbhcin.adb2
-rw-r--r--gcc/ada/libgnat/a-sbhcin.ads2
-rw-r--r--gcc/ada/libgnat/a-sblcin.adb2
-rw-r--r--gcc/ada/libgnat/a-sblcin.ads2
-rw-r--r--gcc/ada/libgnat/a-secain.adb2
-rw-r--r--gcc/ada/libgnat/a-secain.ads2
-rw-r--r--gcc/ada/libgnat/a-sequio.adb4
-rw-r--r--gcc/ada/libgnat/a-sequio.ads2
-rw-r--r--gcc/ada/libgnat/a-sfecin.ads2
-rw-r--r--gcc/ada/libgnat/a-sfhcin.ads2
-rw-r--r--gcc/ada/libgnat/a-sflcin.ads2
-rw-r--r--gcc/ada/libgnat/a-shcain.adb2
-rw-r--r--gcc/ada/libgnat/a-shcain.ads2
-rw-r--r--gcc/ada/libgnat/a-siocst.adb2
-rw-r--r--gcc/ada/libgnat/a-siocst.ads2
-rw-r--r--gcc/ada/libgnat/a-slcain.adb2
-rw-r--r--gcc/ada/libgnat/a-slcain.ads2
-rw-r--r--gcc/ada/libgnat/a-ssicst.adb2
-rw-r--r--gcc/ada/libgnat/a-ssicst.ads2
-rw-r--r--gcc/ada/libgnat/a-stboha.adb2
-rw-r--r--gcc/ada/libgnat/a-stmaco.ads2
-rw-r--r--gcc/ada/libgnat/a-stobbu.adb53
-rw-r--r--gcc/ada/libgnat/a-stobbu.ads34
-rw-r--r--gcc/ada/libgnat/a-stobfi.adb118
-rw-r--r--gcc/ada/libgnat/a-stobfi.ads66
-rw-r--r--gcc/ada/libgnat/a-storio.adb2
-rw-r--r--gcc/ada/libgnat/a-stoubu.adb138
-rw-r--r--gcc/ada/libgnat/a-stoubu.ads73
-rw-r--r--gcc/ada/libgnat/a-stoufi.adb123
-rw-r--r--gcc/ada/libgnat/a-stoufi.ads72
-rw-r--r--gcc/ada/libgnat/a-stoufo.adb155
-rw-r--r--gcc/ada/libgnat/a-stoufo.ads72
-rw-r--r--gcc/ada/libgnat/a-stouut.adb271
-rw-r--r--gcc/ada/libgnat/a-stouut.ads106
-rw-r--r--gcc/ada/libgnat/a-strbou.adb2
-rw-r--r--gcc/ada/libgnat/a-strbou.ads2
-rw-r--r--gcc/ada/libgnat/a-stream.adb2
-rw-r--r--gcc/ada/libgnat/a-stream.ads2
-rw-r--r--gcc/ada/libgnat/a-strfix.adb6
-rw-r--r--gcc/ada/libgnat/a-strhas.adb2
-rw-r--r--gcc/ada/libgnat/a-strmap.adb2
-rw-r--r--gcc/ada/libgnat/a-strmap.ads2
-rw-r--r--gcc/ada/libgnat/a-strsea.adb2
-rw-r--r--gcc/ada/libgnat/a-strsea.ads2
-rw-r--r--gcc/ada/libgnat/a-strsto.ads44
-rw-r--r--gcc/ada/libgnat/a-strsup.adb2
-rw-r--r--gcc/ada/libgnat/a-strsup.ads2
-rw-r--r--gcc/ada/libgnat/a-strunb.adb85
-rw-r--r--gcc/ada/libgnat/a-strunb.ads2
-rw-r--r--gcc/ada/libgnat/a-strunb__shared.adb156
-rw-r--r--gcc/ada/libgnat/a-strunb__shared.ads8
-rw-r--r--gcc/ada/libgnat/a-ststbo.adb117
-rw-r--r--gcc/ada/libgnat/a-ststbo.ads73
-rw-r--r--gcc/ada/libgnat/a-ststio.adb2
-rw-r--r--gcc/ada/libgnat/a-ststio.ads2
-rw-r--r--gcc/ada/libgnat/a-ststun.adb151
-rw-r--r--gcc/ada/libgnat/a-ststun.ads91
-rw-r--r--gcc/ada/libgnat/a-stteou.ads191
-rw-r--r--gcc/ada/libgnat/a-stunau.adb2
-rw-r--r--gcc/ada/libgnat/a-stunau.ads2
-rw-r--r--gcc/ada/libgnat/a-stunau__shared.adb2
-rw-r--r--gcc/ada/libgnat/a-stunha.adb2
-rw-r--r--gcc/ada/libgnat/a-stuten.adb2
-rw-r--r--gcc/ada/libgnat/a-stwibo.adb2
-rw-r--r--gcc/ada/libgnat/a-stwibo.ads2
-rw-r--r--gcc/ada/libgnat/a-stwifi.adb2
-rw-r--r--gcc/ada/libgnat/a-stwiha.adb2
-rw-r--r--gcc/ada/libgnat/a-stwima.adb2
-rw-r--r--gcc/ada/libgnat/a-stwima.ads2
-rw-r--r--gcc/ada/libgnat/a-stwise.adb2
-rw-r--r--gcc/ada/libgnat/a-stwise.ads2
-rw-r--r--gcc/ada/libgnat/a-stwisu.adb2
-rw-r--r--gcc/ada/libgnat/a-stwisu.ads2
-rw-r--r--gcc/ada/libgnat/a-stwiun.adb2
-rw-r--r--gcc/ada/libgnat/a-stwiun.ads2
-rw-r--r--gcc/ada/libgnat/a-stwiun__shared.adb2
-rw-r--r--gcc/ada/libgnat/a-stwiun__shared.ads2
-rw-r--r--gcc/ada/libgnat/a-stzbou.adb2
-rw-r--r--gcc/ada/libgnat/a-stzbou.ads2
-rw-r--r--gcc/ada/libgnat/a-stzfix.adb2
-rw-r--r--gcc/ada/libgnat/a-stzhas.adb2
-rw-r--r--gcc/ada/libgnat/a-stzmap.adb2
-rw-r--r--gcc/ada/libgnat/a-stzmap.ads2
-rw-r--r--gcc/ada/libgnat/a-stzsea.adb2
-rw-r--r--gcc/ada/libgnat/a-stzsea.ads2
-rw-r--r--gcc/ada/libgnat/a-stzsup.adb2
-rw-r--r--gcc/ada/libgnat/a-stzsup.ads2
-rw-r--r--gcc/ada/libgnat/a-stzunb.adb2
-rw-r--r--gcc/ada/libgnat/a-stzunb.ads2
-rw-r--r--gcc/ada/libgnat/a-stzunb__shared.adb2
-rw-r--r--gcc/ada/libgnat/a-stzunb__shared.ads2
-rw-r--r--gcc/ada/libgnat/a-suecin.adb2
-rw-r--r--gcc/ada/libgnat/a-suecin.ads2
-rw-r--r--gcc/ada/libgnat/a-suenco.adb2
-rw-r--r--gcc/ada/libgnat/a-suenst.adb2
-rw-r--r--gcc/ada/libgnat/a-suewst.adb2
-rw-r--r--gcc/ada/libgnat/a-suezst.adb2
-rw-r--r--gcc/ada/libgnat/a-suhcin.adb2
-rw-r--r--gcc/ada/libgnat/a-suhcin.ads2
-rw-r--r--gcc/ada/libgnat/a-sulcin.adb2
-rw-r--r--gcc/ada/libgnat/a-sulcin.ads2
-rw-r--r--gcc/ada/libgnat/a-suteio.adb2
-rw-r--r--gcc/ada/libgnat/a-suteio.ads2
-rw-r--r--gcc/ada/libgnat/a-suteio__shared.adb2
-rw-r--r--gcc/ada/libgnat/a-swbwha.adb2
-rw-r--r--gcc/ada/libgnat/a-swmwco.ads2
-rw-r--r--gcc/ada/libgnat/a-swunau.adb2
-rw-r--r--gcc/ada/libgnat/a-swunau.ads2
-rw-r--r--gcc/ada/libgnat/a-swunau__shared.adb2
-rw-r--r--gcc/ada/libgnat/a-swuwha.adb2
-rw-r--r--gcc/ada/libgnat/a-swuwti.adb2
-rw-r--r--gcc/ada/libgnat/a-swuwti.ads2
-rw-r--r--gcc/ada/libgnat/a-swuwti__shared.adb2
-rw-r--r--gcc/ada/libgnat/a-szbzha.adb2
-rw-r--r--gcc/ada/libgnat/a-szmzco.ads2
-rw-r--r--gcc/ada/libgnat/a-szunau.adb2
-rw-r--r--gcc/ada/libgnat/a-szunau.ads2
-rw-r--r--gcc/ada/libgnat/a-szunau__shared.adb2
-rw-r--r--gcc/ada/libgnat/a-szuzha.adb2
-rw-r--r--gcc/ada/libgnat/a-szuzti.adb2
-rw-r--r--gcc/ada/libgnat/a-szuzti.ads2
-rw-r--r--gcc/ada/libgnat/a-szuzti__shared.adb2
-rw-r--r--gcc/ada/libgnat/a-tags.adb7
-rw-r--r--gcc/ada/libgnat/a-tags.ads21
-rw-r--r--gcc/ada/libgnat/a-teioed.adb2
-rw-r--r--gcc/ada/libgnat/a-teioed.ads2
-rw-r--r--gcc/ada/libgnat/a-textio.adb2
-rw-r--r--gcc/ada/libgnat/a-textio.ads4
-rw-r--r--gcc/ada/libgnat/a-tiboio.adb2
-rw-r--r--gcc/ada/libgnat/a-ticoau.adb2
-rw-r--r--gcc/ada/libgnat/a-ticoau.ads2
-rw-r--r--gcc/ada/libgnat/a-ticoio.adb2
-rw-r--r--gcc/ada/libgnat/a-ticoio.ads2
-rw-r--r--gcc/ada/libgnat/a-tideau.adb2
-rw-r--r--gcc/ada/libgnat/a-tideau.ads2
-rw-r--r--gcc/ada/libgnat/a-tideio.adb2
-rw-r--r--gcc/ada/libgnat/a-tideio.ads2
-rw-r--r--gcc/ada/libgnat/a-tienau.adb2
-rw-r--r--gcc/ada/libgnat/a-tienau.ads2
-rw-r--r--gcc/ada/libgnat/a-tienio.adb2
-rw-r--r--gcc/ada/libgnat/a-tifiio.adb2
-rw-r--r--gcc/ada/libgnat/a-tiflau.adb6
-rw-r--r--gcc/ada/libgnat/a-tiflau.ads2
-rw-r--r--gcc/ada/libgnat/a-tiflio.adb2
-rw-r--r--gcc/ada/libgnat/a-tiflio.ads2
-rw-r--r--gcc/ada/libgnat/a-tigeau.adb2
-rw-r--r--gcc/ada/libgnat/a-tigeau.ads2
-rw-r--r--gcc/ada/libgnat/a-tigeli.adb2
-rw-r--r--gcc/ada/libgnat/a-tiinau.adb2
-rw-r--r--gcc/ada/libgnat/a-tiinau.ads2
-rw-r--r--gcc/ada/libgnat/a-tiinio.adb2
-rw-r--r--gcc/ada/libgnat/a-tiinio.ads2
-rw-r--r--gcc/ada/libgnat/a-timoau.adb2
-rw-r--r--gcc/ada/libgnat/a-timoau.ads2
-rw-r--r--gcc/ada/libgnat/a-timoio.adb2
-rw-r--r--gcc/ada/libgnat/a-timoio.ads2
-rw-r--r--gcc/ada/libgnat/a-tiocst.adb2
-rw-r--r--gcc/ada/libgnat/a-tiocst.ads2
-rw-r--r--gcc/ada/libgnat/a-tirsfi.adb2
-rw-r--r--gcc/ada/libgnat/a-tirsfi.ads2
-rw-r--r--gcc/ada/libgnat/a-titest.adb2
-rw-r--r--gcc/ada/libgnat/a-undesu.adb2
-rw-r--r--gcc/ada/libgnat/a-wichha.adb34
-rw-r--r--gcc/ada/libgnat/a-wichha.ads24
-rw-r--r--gcc/ada/libgnat/a-wichun.adb40
-rw-r--r--gcc/ada/libgnat/a-wichun.ads22
-rw-r--r--gcc/ada/libgnat/a-witeio.adb2
-rw-r--r--gcc/ada/libgnat/a-witeio.ads2
-rw-r--r--gcc/ada/libgnat/a-wrstfi.adb2
-rw-r--r--gcc/ada/libgnat/a-wrstfi.ads2
-rw-r--r--gcc/ada/libgnat/a-wtcoau.adb2
-rw-r--r--gcc/ada/libgnat/a-wtcoau.ads2
-rw-r--r--gcc/ada/libgnat/a-wtcoio.adb2
-rw-r--r--gcc/ada/libgnat/a-wtcstr.adb2
-rw-r--r--gcc/ada/libgnat/a-wtcstr.ads2
-rw-r--r--gcc/ada/libgnat/a-wtdeau.adb2
-rw-r--r--gcc/ada/libgnat/a-wtdeau.ads2
-rw-r--r--gcc/ada/libgnat/a-wtdeio.adb2
-rw-r--r--gcc/ada/libgnat/a-wtedit.adb2
-rw-r--r--gcc/ada/libgnat/a-wtedit.ads2
-rw-r--r--gcc/ada/libgnat/a-wtenau.adb2
-rw-r--r--gcc/ada/libgnat/a-wtenau.ads2
-rw-r--r--gcc/ada/libgnat/a-wtenio.adb2
-rw-r--r--gcc/ada/libgnat/a-wtfiio.adb2
-rw-r--r--gcc/ada/libgnat/a-wtflau.adb2
-rw-r--r--gcc/ada/libgnat/a-wtflau.ads2
-rw-r--r--gcc/ada/libgnat/a-wtflio.adb2
-rw-r--r--gcc/ada/libgnat/a-wtgeau.adb2
-rw-r--r--gcc/ada/libgnat/a-wtgeau.ads2
-rw-r--r--gcc/ada/libgnat/a-wtinau.adb2
-rw-r--r--gcc/ada/libgnat/a-wtinau.ads2
-rw-r--r--gcc/ada/libgnat/a-wtinio.adb2
-rw-r--r--gcc/ada/libgnat/a-wtmoau.adb2
-rw-r--r--gcc/ada/libgnat/a-wtmoau.ads2
-rw-r--r--gcc/ada/libgnat/a-wtmoio.adb2
-rw-r--r--gcc/ada/libgnat/a-wtmoio.ads2
-rw-r--r--gcc/ada/libgnat/a-wttest.adb2
-rw-r--r--gcc/ada/libgnat/a-wwboio.adb2
-rw-r--r--gcc/ada/libgnat/a-zchhan.adb9
-rw-r--r--gcc/ada/libgnat/a-zchhan.ads6
-rw-r--r--gcc/ada/libgnat/a-zchuni.adb11
-rw-r--r--gcc/ada/libgnat/a-zchuni.ads8
-rw-r--r--gcc/ada/libgnat/a-zrstfi.adb2
-rw-r--r--gcc/ada/libgnat/a-zrstfi.ads2
-rw-r--r--gcc/ada/libgnat/a-ztcoau.adb2
-rw-r--r--gcc/ada/libgnat/a-ztcoio.adb2
-rw-r--r--gcc/ada/libgnat/a-ztcstr.adb2
-rw-r--r--gcc/ada/libgnat/a-ztcstr.ads2
-rw-r--r--gcc/ada/libgnat/a-ztdeau.adb2
-rw-r--r--gcc/ada/libgnat/a-ztdeau.ads2
-rw-r--r--gcc/ada/libgnat/a-ztdeio.adb2
-rw-r--r--gcc/ada/libgnat/a-ztedit.adb2
-rw-r--r--gcc/ada/libgnat/a-ztedit.ads2
-rw-r--r--gcc/ada/libgnat/a-ztenau.adb2
-rw-r--r--gcc/ada/libgnat/a-ztenau.ads2
-rw-r--r--gcc/ada/libgnat/a-ztenio.adb2
-rw-r--r--gcc/ada/libgnat/a-ztexio.adb2
-rw-r--r--gcc/ada/libgnat/a-ztexio.ads2
-rw-r--r--gcc/ada/libgnat/a-ztfiio.adb2
-rw-r--r--gcc/ada/libgnat/a-ztflau.adb2
-rw-r--r--gcc/ada/libgnat/a-ztflau.ads2
-rw-r--r--gcc/ada/libgnat/a-ztflio.adb2
-rw-r--r--gcc/ada/libgnat/a-ztgeau.adb2
-rw-r--r--gcc/ada/libgnat/a-ztgeau.ads2
-rw-r--r--gcc/ada/libgnat/a-ztinau.adb2
-rw-r--r--gcc/ada/libgnat/a-ztinau.ads2
-rw-r--r--gcc/ada/libgnat/a-ztinio.adb2
-rw-r--r--gcc/ada/libgnat/a-ztmoau.adb2
-rw-r--r--gcc/ada/libgnat/a-ztmoau.ads2
-rw-r--r--gcc/ada/libgnat/a-ztmoio.adb2
-rw-r--r--gcc/ada/libgnat/a-zttest.adb2
-rw-r--r--gcc/ada/libgnat/a-zzboio.adb2
-rw-r--r--gcc/ada/libgnat/g-allein.ads2
-rw-r--r--gcc/ada/libgnat/g-alleve.adb2
-rw-r--r--gcc/ada/libgnat/g-alleve.ads2
-rw-r--r--gcc/ada/libgnat/g-alleve__hard.adb2
-rw-r--r--gcc/ada/libgnat/g-alleve__hard.ads2
-rw-r--r--gcc/ada/libgnat/g-altcon.adb2
-rw-r--r--gcc/ada/libgnat/g-altcon.ads2
-rw-r--r--gcc/ada/libgnat/g-altive.ads2
-rw-r--r--gcc/ada/libgnat/g-alveop.adb2
-rw-r--r--gcc/ada/libgnat/g-alveop.ads2
-rw-r--r--gcc/ada/libgnat/g-alvety.ads2
-rw-r--r--gcc/ada/libgnat/g-alvevi.ads2
-rw-r--r--gcc/ada/libgnat/g-arrspl.adb2
-rw-r--r--gcc/ada/libgnat/g-arrspl.ads2
-rw-r--r--gcc/ada/libgnat/g-awk.adb2
-rw-r--r--gcc/ada/libgnat/g-awk.ads2
-rw-r--r--gcc/ada/libgnat/g-binenv.adb2
-rw-r--r--gcc/ada/libgnat/g-binenv.ads2
-rw-r--r--gcc/ada/libgnat/g-brapre.ads2
-rw-r--r--gcc/ada/libgnat/g-bubsor.adb2
-rw-r--r--gcc/ada/libgnat/g-bubsor.ads2
-rw-r--r--gcc/ada/libgnat/g-busora.adb2
-rw-r--r--gcc/ada/libgnat/g-busora.ads2
-rw-r--r--gcc/ada/libgnat/g-busorg.adb2
-rw-r--r--gcc/ada/libgnat/g-busorg.ads2
-rw-r--r--gcc/ada/libgnat/g-byorma.adb2
-rw-r--r--gcc/ada/libgnat/g-byorma.ads2
-rw-r--r--gcc/ada/libgnat/g-bytswa.adb8
-rw-r--r--gcc/ada/libgnat/g-bytswa.ads2
-rw-r--r--gcc/ada/libgnat/g-calend.adb11
-rw-r--r--gcc/ada/libgnat/g-calend.ads2
-rw-r--r--gcc/ada/libgnat/g-casuti.adb2
-rw-r--r--gcc/ada/libgnat/g-casuti.ads2
-rw-r--r--gcc/ada/libgnat/g-catiio.adb315
-rw-r--r--gcc/ada/libgnat/g-catiio.ads29
-rw-r--r--gcc/ada/libgnat/g-cgi.adb2
-rw-r--r--gcc/ada/libgnat/g-cgi.ads2
-rw-r--r--gcc/ada/libgnat/g-cgicoo.adb2
-rw-r--r--gcc/ada/libgnat/g-cgicoo.ads2
-rw-r--r--gcc/ada/libgnat/g-cgideb.adb2
-rw-r--r--gcc/ada/libgnat/g-cgideb.ads2
-rw-r--r--gcc/ada/libgnat/g-comlin.adb3
-rw-r--r--gcc/ada/libgnat/g-comlin.ads2
-rw-r--r--gcc/ada/libgnat/g-comver.adb2
-rw-r--r--gcc/ada/libgnat/g-comver.ads2
-rw-r--r--gcc/ada/libgnat/g-cppexc.adb2
-rw-r--r--gcc/ada/libgnat/g-cppexc.ads2
-rw-r--r--gcc/ada/libgnat/g-crc32.adb2
-rw-r--r--gcc/ada/libgnat/g-crc32.ads2
-rw-r--r--gcc/ada/libgnat/g-ctrl_c.adb2
-rw-r--r--gcc/ada/libgnat/g-ctrl_c.ads2
-rw-r--r--gcc/ada/libgnat/g-curexc.ads2
-rw-r--r--gcc/ada/libgnat/g-debpoo.adb3
-rw-r--r--gcc/ada/libgnat/g-debpoo.ads2
-rw-r--r--gcc/ada/libgnat/g-debuti.adb2
-rw-r--r--gcc/ada/libgnat/g-debuti.ads2
-rw-r--r--gcc/ada/libgnat/g-decstr.adb2
-rw-r--r--gcc/ada/libgnat/g-decstr.ads2
-rw-r--r--gcc/ada/libgnat/g-deutst.ads2
-rw-r--r--gcc/ada/libgnat/g-diopit.adb2
-rw-r--r--gcc/ada/libgnat/g-diopit.ads2
-rw-r--r--gcc/ada/libgnat/g-dirope.adb4
-rw-r--r--gcc/ada/libgnat/g-dirope.ads2
-rw-r--r--gcc/ada/libgnat/g-dynhta.adb2
-rw-r--r--gcc/ada/libgnat/g-dynhta.ads2
-rw-r--r--gcc/ada/libgnat/g-dyntab.adb2
-rw-r--r--gcc/ada/libgnat/g-dyntab.ads2
-rw-r--r--gcc/ada/libgnat/g-eacodu.adb2
-rw-r--r--gcc/ada/libgnat/g-encstr.adb2
-rw-r--r--gcc/ada/libgnat/g-encstr.ads2
-rw-r--r--gcc/ada/libgnat/g-enutst.ads2
-rw-r--r--gcc/ada/libgnat/g-excact.adb27
-rw-r--r--gcc/ada/libgnat/g-excact.ads7
-rw-r--r--gcc/ada/libgnat/g-except.ads2
-rw-r--r--gcc/ada/libgnat/g-exctra.adb2
-rw-r--r--gcc/ada/libgnat/g-exctra.ads2
-rw-r--r--gcc/ada/libgnat/g-expect.adb2
-rw-r--r--gcc/ada/libgnat/g-expect.ads2
-rw-r--r--gcc/ada/libgnat/g-exptty.adb8
-rw-r--r--gcc/ada/libgnat/g-exptty.ads8
-rw-r--r--gcc/ada/libgnat/g-flocon.ads2
-rw-r--r--gcc/ada/libgnat/g-forstr.adb2
-rw-r--r--gcc/ada/libgnat/g-forstr.ads2
-rw-r--r--gcc/ada/libgnat/g-graphs.adb2
-rw-r--r--gcc/ada/libgnat/g-graphs.ads2
-rw-r--r--gcc/ada/libgnat/g-heasor.adb2
-rw-r--r--gcc/ada/libgnat/g-heasor.ads2
-rw-r--r--gcc/ada/libgnat/g-hesora.adb2
-rw-r--r--gcc/ada/libgnat/g-hesora.ads2
-rw-r--r--gcc/ada/libgnat/g-hesorg.adb4
-rw-r--r--gcc/ada/libgnat/g-hesorg.ads2
-rw-r--r--gcc/ada/libgnat/g-htable.adb2
-rw-r--r--gcc/ada/libgnat/g-htable.ads2
-rw-r--r--gcc/ada/libgnat/g-io-put__vxworks.adb2
-rw-r--r--gcc/ada/libgnat/g-io.adb14
-rw-r--r--gcc/ada/libgnat/g-io.ads2
-rw-r--r--gcc/ada/libgnat/g-io_aux.adb2
-rw-r--r--gcc/ada/libgnat/g-io_aux.ads2
-rw-r--r--gcc/ada/libgnat/g-lists.adb2
-rw-r--r--gcc/ada/libgnat/g-lists.ads2
-rw-r--r--gcc/ada/libgnat/g-locfil.adb2
-rw-r--r--gcc/ada/libgnat/g-locfil.ads2
-rw-r--r--gcc/ada/libgnat/g-mbdira.adb2
-rw-r--r--gcc/ada/libgnat/g-mbdira.ads2
-rw-r--r--gcc/ada/libgnat/g-mbflra.adb2
-rw-r--r--gcc/ada/libgnat/g-mbflra.ads2
-rw-r--r--gcc/ada/libgnat/g-md5.adb2
-rw-r--r--gcc/ada/libgnat/g-md5.ads2
-rw-r--r--gcc/ada/libgnat/g-memdum.adb2
-rw-r--r--gcc/ada/libgnat/g-memdum.ads2
-rw-r--r--gcc/ada/libgnat/g-moreex.adb2
-rw-r--r--gcc/ada/libgnat/g-moreex.ads2
-rw-r--r--gcc/ada/libgnat/g-os_lib.adb2
-rw-r--r--gcc/ada/libgnat/g-os_lib.ads2
-rw-r--r--gcc/ada/libgnat/g-pehage.adb11
-rw-r--r--gcc/ada/libgnat/g-pehage.ads2
-rw-r--r--gcc/ada/libgnat/g-rannum.adb2
-rw-r--r--gcc/ada/libgnat/g-rannum.ads2
-rw-r--r--gcc/ada/libgnat/g-regexp.adb2
-rw-r--r--gcc/ada/libgnat/g-regexp.ads2
-rw-r--r--gcc/ada/libgnat/g-regist.adb2
-rw-r--r--gcc/ada/libgnat/g-regist.ads2
-rw-r--r--gcc/ada/libgnat/g-regpat.adb2
-rw-r--r--gcc/ada/libgnat/g-regpat.ads2
-rw-r--r--gcc/ada/libgnat/g-rewdat.adb2
-rw-r--r--gcc/ada/libgnat/g-rewdat.ads2
-rw-r--r--gcc/ada/libgnat/g-sechas.adb130
-rw-r--r--gcc/ada/libgnat/g-sechas.ads30
-rw-r--r--gcc/ada/libgnat/g-sehamd.adb2
-rw-r--r--gcc/ada/libgnat/g-sehamd.ads2
-rw-r--r--gcc/ada/libgnat/g-sehash.adb2
-rw-r--r--gcc/ada/libgnat/g-sehash.ads2
-rw-r--r--gcc/ada/libgnat/g-sercom.adb2
-rw-r--r--gcc/ada/libgnat/g-sercom.ads2
-rw-r--r--gcc/ada/libgnat/g-sercom__linux.adb2
-rw-r--r--gcc/ada/libgnat/g-sercom__mingw.adb2
-rw-r--r--gcc/ada/libgnat/g-sestin.ads2
-rw-r--r--gcc/ada/libgnat/g-sets.adb2
-rw-r--r--gcc/ada/libgnat/g-sets.ads2
-rw-r--r--gcc/ada/libgnat/g-sha1.adb2
-rw-r--r--gcc/ada/libgnat/g-sha1.ads2
-rw-r--r--gcc/ada/libgnat/g-sha224.ads2
-rw-r--r--gcc/ada/libgnat/g-sha256.ads2
-rw-r--r--gcc/ada/libgnat/g-sha384.ads2
-rw-r--r--gcc/ada/libgnat/g-sha512.ads2
-rw-r--r--gcc/ada/libgnat/g-shsh32.adb2
-rw-r--r--gcc/ada/libgnat/g-shsh32.ads2
-rw-r--r--gcc/ada/libgnat/g-shsh64.adb2
-rw-r--r--gcc/ada/libgnat/g-shsh64.ads2
-rw-r--r--gcc/ada/libgnat/g-shshco.adb5
-rw-r--r--gcc/ada/libgnat/g-shshco.ads2
-rw-r--r--gcc/ada/libgnat/g-soccon.ads2
-rw-r--r--gcc/ada/libgnat/g-socket.adb68
-rw-r--r--gcc/ada/libgnat/g-socket.ads2
-rw-r--r--gcc/ada/libgnat/g-socket__dummy.adb2
-rw-r--r--gcc/ada/libgnat/g-socket__dummy.ads2
-rw-r--r--gcc/ada/libgnat/g-socthi.adb26
-rw-r--r--gcc/ada/libgnat/g-socthi.ads10
-rw-r--r--gcc/ada/libgnat/g-socthi__dummy.adb2
-rw-r--r--gcc/ada/libgnat/g-socthi__dummy.ads2
-rw-r--r--gcc/ada/libgnat/g-socthi__mingw.adb2
-rw-r--r--gcc/ada/libgnat/g-socthi__mingw.ads2
-rw-r--r--gcc/ada/libgnat/g-socthi__vxworks.adb24
-rw-r--r--gcc/ada/libgnat/g-socthi__vxworks.ads10
-rw-r--r--gcc/ada/libgnat/g-soliop.ads2
-rw-r--r--gcc/ada/libgnat/g-soliop__lynxos.ads2
-rw-r--r--gcc/ada/libgnat/g-soliop__mingw.ads2
-rw-r--r--gcc/ada/libgnat/g-soliop__qnx.ads2
-rw-r--r--gcc/ada/libgnat/g-soliop__solaris.ads2
-rw-r--r--gcc/ada/libgnat/g-sothco.adb2
-rw-r--r--gcc/ada/libgnat/g-sothco.ads23
-rw-r--r--gcc/ada/libgnat/g-sothco__dummy.adb2
-rw-r--r--gcc/ada/libgnat/g-sothco__dummy.ads2
-rw-r--r--gcc/ada/libgnat/g-souinf.ads2
-rw-r--r--gcc/ada/libgnat/g-spchge.adb2
-rw-r--r--gcc/ada/libgnat/g-spchge.ads2
-rw-r--r--gcc/ada/libgnat/g-speche.adb2
-rw-r--r--gcc/ada/libgnat/g-speche.ads2
-rw-r--r--gcc/ada/libgnat/g-spipat.adb2
-rw-r--r--gcc/ada/libgnat/g-spipat.ads2
-rw-r--r--gcc/ada/libgnat/g-spitbo.adb2
-rw-r--r--gcc/ada/libgnat/g-spitbo.ads6
-rw-r--r--gcc/ada/libgnat/g-sptabo.ads2
-rw-r--r--gcc/ada/libgnat/g-sptain.ads2
-rw-r--r--gcc/ada/libgnat/g-sptavs.ads2
-rw-r--r--gcc/ada/libgnat/g-sse.ads2
-rw-r--r--gcc/ada/libgnat/g-ssvety.ads2
-rw-r--r--gcc/ada/libgnat/g-sthcso.adb2
-rw-r--r--gcc/ada/libgnat/g-stheme.adb2
-rw-r--r--gcc/ada/libgnat/g-strhas.ads2
-rw-r--r--gcc/ada/libgnat/g-string.adb2
-rw-r--r--gcc/ada/libgnat/g-string.ads2
-rw-r--r--gcc/ada/libgnat/g-strspl.ads2
-rw-r--r--gcc/ada/libgnat/g-stseme.adb2
-rw-r--r--gcc/ada/libgnat/g-stsifd__sockets.adb2
-rw-r--r--gcc/ada/libgnat/g-table.adb2
-rw-r--r--gcc/ada/libgnat/g-table.ads2
-rw-r--r--gcc/ada/libgnat/g-tasloc.adb2
-rw-r--r--gcc/ada/libgnat/g-tasloc.ads2
-rw-r--r--gcc/ada/libgnat/g-timsta.adb2
-rw-r--r--gcc/ada/libgnat/g-timsta.ads2
-rw-r--r--gcc/ada/libgnat/g-traceb.adb2
-rw-r--r--gcc/ada/libgnat/g-traceb.ads2
-rw-r--r--gcc/ada/libgnat/g-trasym.adb2
-rw-r--r--gcc/ada/libgnat/g-trasym.ads2
-rw-r--r--gcc/ada/libgnat/g-tty.adb2
-rw-r--r--gcc/ada/libgnat/g-tty.ads2
-rw-r--r--gcc/ada/libgnat/g-u3spch.adb2
-rw-r--r--gcc/ada/libgnat/g-u3spch.ads2
-rw-r--r--gcc/ada/libgnat/g-utf_32.adb2
-rw-r--r--gcc/ada/libgnat/g-utf_32.ads2
-rw-r--r--gcc/ada/libgnat/g-wispch.adb2
-rw-r--r--gcc/ada/libgnat/g-wispch.ads2
-rw-r--r--gcc/ada/libgnat/g-wistsp.ads2
-rw-r--r--gcc/ada/libgnat/g-zspche.adb2
-rw-r--r--gcc/ada/libgnat/g-zspche.ads2
-rw-r--r--gcc/ada/libgnat/g-zstspl.ads2
-rw-r--r--gcc/ada/libgnat/gnat.ads2
-rw-r--r--gcc/ada/libgnat/i-c.adb2
-rw-r--r--gcc/ada/libgnat/i-c.ads8
-rw-r--r--gcc/ada/libgnat/i-cexten.ads6
-rw-r--r--gcc/ada/libgnat/i-cobol.adb7
-rw-r--r--gcc/ada/libgnat/i-cobol.ads2
-rw-r--r--gcc/ada/libgnat/i-cpoint.adb2
-rw-r--r--gcc/ada/libgnat/i-cpoint.ads2
-rw-r--r--gcc/ada/libgnat/i-cstrea.adb2
-rw-r--r--gcc/ada/libgnat/i-cstrea.ads2
-rw-r--r--gcc/ada/libgnat/i-cstrin.adb2
-rw-r--r--gcc/ada/libgnat/i-cstrin.ads2
-rw-r--r--gcc/ada/libgnat/i-fortra.adb2
-rw-r--r--gcc/ada/libgnat/i-pacdec.adb2
-rw-r--r--gcc/ada/libgnat/i-pacdec.ads2
-rw-r--r--gcc/ada/libgnat/i-vxwoio.adb2
-rw-r--r--gcc/ada/libgnat/i-vxwoio.ads2
-rw-r--r--gcc/ada/libgnat/i-vxwork.ads2
-rw-r--r--gcc/ada/libgnat/i-vxwork__x86.ads2
-rw-r--r--gcc/ada/libgnat/interfac.ads2
-rw-r--r--gcc/ada/libgnat/libada.gpr77
-rw-r--r--gcc/ada/libgnat/libgnat.gpr69
-rw-r--r--gcc/ada/libgnat/libgnat_common.gpr19
-rw-r--r--gcc/ada/libgnat/memtrack.adb2
-rw-r--r--gcc/ada/libgnat/s-addima.adb2
-rw-r--r--gcc/ada/libgnat/s-addima.ads2
-rw-r--r--gcc/ada/libgnat/s-addope.adb2
-rw-r--r--gcc/ada/libgnat/s-addope.ads2
-rw-r--r--gcc/ada/libgnat/s-aoinar.adb (renamed from gcc/ada/libgnat/s-atopar.adb)100
-rw-r--r--gcc/ada/libgnat/s-aoinar.ads (renamed from gcc/ada/libgnat/s-atopar.ads)15
-rw-r--r--gcc/ada/libgnat/s-aomoar.adb215
-rw-r--r--gcc/ada/libgnat/s-aomoar.ads66
-rw-r--r--gcc/ada/libgnat/s-aotase.adb2
-rw-r--r--gcc/ada/libgnat/s-aotase.ads7
-rw-r--r--gcc/ada/libgnat/s-arit64.adb2
-rw-r--r--gcc/ada/libgnat/s-arit64.ads2
-rw-r--r--gcc/ada/libgnat/s-assert.adb2
-rw-r--r--gcc/ada/libgnat/s-assert.ads2
-rw-r--r--gcc/ada/libgnat/s-atacco.adb2
-rw-r--r--gcc/ada/libgnat/s-atacco.ads2
-rw-r--r--gcc/ada/libgnat/s-atocou.adb2
-rw-r--r--gcc/ada/libgnat/s-atocou.ads2
-rw-r--r--gcc/ada/libgnat/s-atocou__builtin.adb2
-rw-r--r--gcc/ada/libgnat/s-atocou__x86.adb2
-rw-r--r--gcc/ada/libgnat/s-atoope.ads6
-rw-r--r--gcc/ada/libgnat/s-atopex.adb9
-rw-r--r--gcc/ada/libgnat/s-atopex.ads9
-rw-r--r--gcc/ada/libgnat/s-atopri.adb2
-rw-r--r--gcc/ada/libgnat/s-atopri.ads2
-rw-r--r--gcc/ada/libgnat/s-auxdec.adb2
-rw-r--r--gcc/ada/libgnat/s-auxdec.ads4
-rw-r--r--gcc/ada/libgnat/s-bignum.adb143
-rw-r--r--gcc/ada/libgnat/s-bignum.ads8
-rw-r--r--gcc/ada/libgnat/s-bitfie.ads2
-rw-r--r--gcc/ada/libgnat/s-bitops.adb2
-rw-r--r--gcc/ada/libgnat/s-bitops.ads2
-rw-r--r--gcc/ada/libgnat/s-bituti.adb2
-rw-r--r--gcc/ada/libgnat/s-bituti.ads2
-rw-r--r--gcc/ada/libgnat/s-boarop.ads2
-rw-r--r--gcc/ada/libgnat/s-boustr.adb2
-rw-r--r--gcc/ada/libgnat/s-boustr.ads2
-rw-r--r--gcc/ada/libgnat/s-bytswa.ads2
-rw-r--r--gcc/ada/libgnat/s-carsi8.adb2
-rw-r--r--gcc/ada/libgnat/s-carsi8.ads2
-rw-r--r--gcc/ada/libgnat/s-carun8.adb2
-rw-r--r--gcc/ada/libgnat/s-carun8.ads2
-rw-r--r--gcc/ada/libgnat/s-casi16.adb2
-rw-r--r--gcc/ada/libgnat/s-casi16.ads2
-rw-r--r--gcc/ada/libgnat/s-casi32.adb2
-rw-r--r--gcc/ada/libgnat/s-casi32.ads2
-rw-r--r--gcc/ada/libgnat/s-casi64.adb2
-rw-r--r--gcc/ada/libgnat/s-casi64.ads2
-rw-r--r--gcc/ada/libgnat/s-casuti.adb2
-rw-r--r--gcc/ada/libgnat/s-casuti.ads2
-rw-r--r--gcc/ada/libgnat/s-caun16.adb2
-rw-r--r--gcc/ada/libgnat/s-caun16.ads2
-rw-r--r--gcc/ada/libgnat/s-caun32.adb2
-rw-r--r--gcc/ada/libgnat/s-caun32.ads2
-rw-r--r--gcc/ada/libgnat/s-caun64.adb2
-rw-r--r--gcc/ada/libgnat/s-caun64.ads2
-rw-r--r--gcc/ada/libgnat/s-chepoo.ads2
-rw-r--r--gcc/ada/libgnat/s-commun.adb2
-rw-r--r--gcc/ada/libgnat/s-commun.ads2
-rw-r--r--gcc/ada/libgnat/s-conca2.adb2
-rw-r--r--gcc/ada/libgnat/s-conca2.ads2
-rw-r--r--gcc/ada/libgnat/s-conca3.adb2
-rw-r--r--gcc/ada/libgnat/s-conca3.ads2
-rw-r--r--gcc/ada/libgnat/s-conca4.adb2
-rw-r--r--gcc/ada/libgnat/s-conca4.ads2
-rw-r--r--gcc/ada/libgnat/s-conca5.adb2
-rw-r--r--gcc/ada/libgnat/s-conca5.ads2
-rw-r--r--gcc/ada/libgnat/s-conca6.adb2
-rw-r--r--gcc/ada/libgnat/s-conca6.ads2
-rw-r--r--gcc/ada/libgnat/s-conca7.adb2
-rw-r--r--gcc/ada/libgnat/s-conca7.ads2
-rw-r--r--gcc/ada/libgnat/s-conca8.adb2
-rw-r--r--gcc/ada/libgnat/s-conca8.ads2
-rw-r--r--gcc/ada/libgnat/s-conca9.adb2
-rw-r--r--gcc/ada/libgnat/s-conca9.ads2
-rw-r--r--gcc/ada/libgnat/s-crc32.adb2
-rw-r--r--gcc/ada/libgnat/s-crc32.ads2
-rw-r--r--gcc/ada/libgnat/s-crtl.ads2
-rw-r--r--gcc/ada/libgnat/s-dfmkio.ads2
-rw-r--r--gcc/ada/libgnat/s-dfmopr.ads2
-rw-r--r--gcc/ada/libgnat/s-dgmgop.ads2
-rw-r--r--gcc/ada/libgnat/s-diflio.adb2
-rw-r--r--gcc/ada/libgnat/s-diflio.ads2
-rw-r--r--gcc/ada/libgnat/s-diflmk.ads2
-rw-r--r--gcc/ada/libgnat/s-digemk.ads2
-rw-r--r--gcc/ada/libgnat/s-diinio.adb2
-rw-r--r--gcc/ada/libgnat/s-diinio.ads2
-rw-r--r--gcc/ada/libgnat/s-dilomk.ads2
-rw-r--r--gcc/ada/libgnat/s-dim.ads2
-rw-r--r--gcc/ada/libgnat/s-dimkio.ads2
-rw-r--r--gcc/ada/libgnat/s-dimmks.ads2
-rw-r--r--gcc/ada/libgnat/s-direio.adb2
-rw-r--r--gcc/ada/libgnat/s-direio.ads2
-rw-r--r--gcc/ada/libgnat/s-dlmkio.ads2
-rw-r--r--gcc/ada/libgnat/s-dlmopr.ads2
-rw-r--r--gcc/ada/libgnat/s-dmotpr.ads2
-rw-r--r--gcc/ada/libgnat/s-dsaser.ads2
-rw-r--r--gcc/ada/libgnat/s-dwalin.adb19
-rw-r--r--gcc/ada/libgnat/s-dwalin.ads4
-rw-r--r--gcc/ada/libgnat/s-elaall.adb2
-rw-r--r--gcc/ada/libgnat/s-elaall.ads2
-rw-r--r--gcc/ada/libgnat/s-excdeb.adb2
-rw-r--r--gcc/ada/libgnat/s-excdeb.ads2
-rw-r--r--gcc/ada/libgnat/s-except.adb2
-rw-r--r--gcc/ada/libgnat/s-except.ads2
-rw-r--r--gcc/ada/libgnat/s-excmac__arm.adb2
-rw-r--r--gcc/ada/libgnat/s-excmac__arm.ads2
-rw-r--r--gcc/ada/libgnat/s-excmac__gcc.adb2
-rw-r--r--gcc/ada/libgnat/s-excmac__gcc.ads2
-rw-r--r--gcc/ada/libgnat/s-exctab.adb2
-rw-r--r--gcc/ada/libgnat/s-exctab.ads2
-rw-r--r--gcc/ada/libgnat/s-exctra.adb2
-rw-r--r--gcc/ada/libgnat/s-exctra.ads2
-rw-r--r--gcc/ada/libgnat/s-exnint.adb2
-rw-r--r--gcc/ada/libgnat/s-exnint.ads2
-rw-r--r--gcc/ada/libgnat/s-exnllf.adb2
-rw-r--r--gcc/ada/libgnat/s-exnllf.ads2
-rw-r--r--gcc/ada/libgnat/s-exnlli.adb2
-rw-r--r--gcc/ada/libgnat/s-exnlli.ads2
-rw-r--r--gcc/ada/libgnat/s-expint.adb2
-rw-r--r--gcc/ada/libgnat/s-expint.ads2
-rw-r--r--gcc/ada/libgnat/s-explli.adb2
-rw-r--r--gcc/ada/libgnat/s-explli.ads2
-rw-r--r--gcc/ada/libgnat/s-expllu.adb2
-rw-r--r--gcc/ada/libgnat/s-expllu.ads2
-rw-r--r--gcc/ada/libgnat/s-expmod.adb2
-rw-r--r--gcc/ada/libgnat/s-expmod.ads2
-rw-r--r--gcc/ada/libgnat/s-expuns.adb2
-rw-r--r--gcc/ada/libgnat/s-expuns.ads2
-rw-r--r--gcc/ada/libgnat/s-fatflt.ads2
-rw-r--r--gcc/ada/libgnat/s-fatgen.adb6
-rw-r--r--gcc/ada/libgnat/s-fatgen.ads2
-rw-r--r--gcc/ada/libgnat/s-fatlfl.ads2
-rw-r--r--gcc/ada/libgnat/s-fatllf.ads2
-rw-r--r--gcc/ada/libgnat/s-fatsfl.ads2
-rw-r--r--gcc/ada/libgnat/s-ficobl.ads2
-rw-r--r--gcc/ada/libgnat/s-filatt.ads2
-rw-r--r--gcc/ada/libgnat/s-fileio.adb2
-rw-r--r--gcc/ada/libgnat/s-fileio.ads2
-rw-r--r--gcc/ada/libgnat/s-finmas.adb2
-rw-r--r--gcc/ada/libgnat/s-finmas.ads2
-rw-r--r--gcc/ada/libgnat/s-finroo.adb2
-rw-r--r--gcc/ada/libgnat/s-finroo.ads2
-rw-r--r--gcc/ada/libgnat/s-flocon.adb2
-rw-r--r--gcc/ada/libgnat/s-flocon.ads2
-rw-r--r--gcc/ada/libgnat/s-flocon__none.adb2
-rw-r--r--gcc/ada/libgnat/s-fore.adb2
-rw-r--r--gcc/ada/libgnat/s-fore.ads2
-rw-r--r--gcc/ada/libgnat/s-gearop.adb9
-rw-r--r--gcc/ada/libgnat/s-gearop.ads2
-rw-r--r--gcc/ada/libgnat/s-genbig.adb557
-rw-r--r--gcc/ada/libgnat/s-genbig.ads106
-rw-r--r--gcc/ada/libgnat/s-geveop.adb2
-rw-r--r--gcc/ada/libgnat/s-geveop.ads2
-rw-r--r--gcc/ada/libgnat/s-gloloc.adb2
-rw-r--r--gcc/ada/libgnat/s-gloloc.ads2
-rw-r--r--gcc/ada/libgnat/s-gloloc__mingw.adb2
-rw-r--r--gcc/ada/libgnat/s-htable.adb2
-rw-r--r--gcc/ada/libgnat/s-htable.ads2
-rw-r--r--gcc/ada/libgnat/s-imenne.adb2
-rw-r--r--gcc/ada/libgnat/s-imenne.ads2
-rw-r--r--gcc/ada/libgnat/s-imgbiu.adb2
-rw-r--r--gcc/ada/libgnat/s-imgbiu.ads2
-rw-r--r--gcc/ada/libgnat/s-imgboo.adb2
-rw-r--r--gcc/ada/libgnat/s-imgboo.ads2
-rw-r--r--gcc/ada/libgnat/s-imgcha.adb2
-rw-r--r--gcc/ada/libgnat/s-imgcha.ads2
-rw-r--r--gcc/ada/libgnat/s-imgdec.adb2
-rw-r--r--gcc/ada/libgnat/s-imgdec.ads2
-rw-r--r--gcc/ada/libgnat/s-imgenu.adb2
-rw-r--r--gcc/ada/libgnat/s-imgenu.ads2
-rw-r--r--gcc/ada/libgnat/s-imgint.adb2
-rw-r--r--gcc/ada/libgnat/s-imgint.ads2
-rw-r--r--gcc/ada/libgnat/s-imgllb.adb2
-rw-r--r--gcc/ada/libgnat/s-imgllb.ads2
-rw-r--r--gcc/ada/libgnat/s-imglld.adb2
-rw-r--r--gcc/ada/libgnat/s-imglld.ads2
-rw-r--r--gcc/ada/libgnat/s-imglli.adb2
-rw-r--r--gcc/ada/libgnat/s-imglli.ads2
-rw-r--r--gcc/ada/libgnat/s-imgllu.adb2
-rw-r--r--gcc/ada/libgnat/s-imgllu.ads2
-rw-r--r--gcc/ada/libgnat/s-imgllw.adb2
-rw-r--r--gcc/ada/libgnat/s-imgllw.ads2
-rw-r--r--gcc/ada/libgnat/s-imgrea.adb18
-rw-r--r--gcc/ada/libgnat/s-imgrea.ads7
-rw-r--r--gcc/ada/libgnat/s-imguns.adb2
-rw-r--r--gcc/ada/libgnat/s-imguns.ads2
-rw-r--r--gcc/ada/libgnat/s-imgwch.adb2
-rw-r--r--gcc/ada/libgnat/s-imgwch.ads2
-rw-r--r--gcc/ada/libgnat/s-imgwiu.adb2
-rw-r--r--gcc/ada/libgnat/s-imgwiu.ads2
-rw-r--r--gcc/ada/libgnat/s-io.adb10
-rw-r--r--gcc/ada/libgnat/s-io.ads2
-rw-r--r--gcc/ada/libgnat/s-llflex.ads2
-rw-r--r--gcc/ada/libgnat/s-maccod.ads2
-rw-r--r--gcc/ada/libgnat/s-mantis.adb2
-rw-r--r--gcc/ada/libgnat/s-mantis.ads2
-rw-r--r--gcc/ada/libgnat/s-mastop.adb2
-rw-r--r--gcc/ada/libgnat/s-mastop.ads2
-rw-r--r--gcc/ada/libgnat/s-memcop.ads2
-rw-r--r--gcc/ada/libgnat/s-memory.adb2
-rw-r--r--gcc/ada/libgnat/s-memory.ads2
-rw-r--r--gcc/ada/libgnat/s-mmap.adb2
-rw-r--r--gcc/ada/libgnat/s-mmap.ads4
-rw-r--r--gcc/ada/libgnat/s-mmauni__long.ads2
-rw-r--r--gcc/ada/libgnat/s-mmosin__mingw.adb2
-rw-r--r--gcc/ada/libgnat/s-mmosin__mingw.ads2
-rw-r--r--gcc/ada/libgnat/s-mmosin__unix.adb2
-rw-r--r--gcc/ada/libgnat/s-mmosin__unix.ads2
-rw-r--r--gcc/ada/libgnat/s-multip.adb2
-rw-r--r--gcc/ada/libgnat/s-objrea.adb2
-rw-r--r--gcc/ada/libgnat/s-objrea.ads2
-rw-r--r--gcc/ada/libgnat/s-optide.adb2
-rw-r--r--gcc/ada/libgnat/s-os_lib.adb273
-rw-r--r--gcc/ada/libgnat/s-os_lib.ads2
-rw-r--r--gcc/ada/libgnat/s-osprim.ads2
-rw-r--r--gcc/ada/libgnat/s-osprim__darwin.adb2
-rw-r--r--gcc/ada/libgnat/s-osprim__lynxos.ads2
-rw-r--r--gcc/ada/libgnat/s-osprim__mingw.adb2
-rw-r--r--gcc/ada/libgnat/s-osprim__posix.adb2
-rw-r--r--gcc/ada/libgnat/s-osprim__posix2008.adb2
-rw-r--r--gcc/ada/libgnat/s-osprim__rtems.adb2
-rw-r--r--gcc/ada/libgnat/s-osprim__solaris.adb2
-rw-r--r--gcc/ada/libgnat/s-osprim__unix.adb2
-rw-r--r--gcc/ada/libgnat/s-osprim__vxworks.adb2
-rw-r--r--gcc/ada/libgnat/s-osprim__x32.adb2
-rw-r--r--gcc/ada/libgnat/s-osvers__vxworks-653.ads2
-rw-r--r--gcc/ada/libgnat/s-pack03.adb2
-rw-r--r--gcc/ada/libgnat/s-pack03.ads2
-rw-r--r--gcc/ada/libgnat/s-pack05.adb2
-rw-r--r--gcc/ada/libgnat/s-pack05.ads2
-rw-r--r--gcc/ada/libgnat/s-pack06.adb2
-rw-r--r--gcc/ada/libgnat/s-pack06.ads2
-rw-r--r--gcc/ada/libgnat/s-pack07.adb2
-rw-r--r--gcc/ada/libgnat/s-pack07.ads2
-rw-r--r--gcc/ada/libgnat/s-pack09.adb2
-rw-r--r--gcc/ada/libgnat/s-pack09.ads2
-rw-r--r--gcc/ada/libgnat/s-pack10.adb2
-rw-r--r--gcc/ada/libgnat/s-pack10.ads2
-rw-r--r--gcc/ada/libgnat/s-pack11.adb2
-rw-r--r--gcc/ada/libgnat/s-pack11.ads2
-rw-r--r--gcc/ada/libgnat/s-pack12.adb2
-rw-r--r--gcc/ada/libgnat/s-pack12.ads2
-rw-r--r--gcc/ada/libgnat/s-pack13.adb2
-rw-r--r--gcc/ada/libgnat/s-pack13.ads2
-rw-r--r--gcc/ada/libgnat/s-pack14.adb2
-rw-r--r--gcc/ada/libgnat/s-pack14.ads2
-rw-r--r--gcc/ada/libgnat/s-pack15.adb2
-rw-r--r--gcc/ada/libgnat/s-pack15.ads2
-rw-r--r--gcc/ada/libgnat/s-pack17.adb2
-rw-r--r--gcc/ada/libgnat/s-pack17.ads2
-rw-r--r--gcc/ada/libgnat/s-pack18.adb2
-rw-r--r--gcc/ada/libgnat/s-pack18.ads2
-rw-r--r--gcc/ada/libgnat/s-pack19.adb2
-rw-r--r--gcc/ada/libgnat/s-pack19.ads2
-rw-r--r--gcc/ada/libgnat/s-pack20.adb2
-rw-r--r--gcc/ada/libgnat/s-pack20.ads2
-rw-r--r--gcc/ada/libgnat/s-pack21.adb2
-rw-r--r--gcc/ada/libgnat/s-pack21.ads2
-rw-r--r--gcc/ada/libgnat/s-pack22.adb2
-rw-r--r--gcc/ada/libgnat/s-pack22.ads2
-rw-r--r--gcc/ada/libgnat/s-pack23.adb2
-rw-r--r--gcc/ada/libgnat/s-pack23.ads2
-rw-r--r--gcc/ada/libgnat/s-pack24.adb2
-rw-r--r--gcc/ada/libgnat/s-pack24.ads2
-rw-r--r--gcc/ada/libgnat/s-pack25.adb2
-rw-r--r--gcc/ada/libgnat/s-pack25.ads2
-rw-r--r--gcc/ada/libgnat/s-pack26.adb2
-rw-r--r--gcc/ada/libgnat/s-pack26.ads2
-rw-r--r--gcc/ada/libgnat/s-pack27.adb2
-rw-r--r--gcc/ada/libgnat/s-pack27.ads2
-rw-r--r--gcc/ada/libgnat/s-pack28.adb2
-rw-r--r--gcc/ada/libgnat/s-pack28.ads2
-rw-r--r--gcc/ada/libgnat/s-pack29.adb2
-rw-r--r--gcc/ada/libgnat/s-pack29.ads2
-rw-r--r--gcc/ada/libgnat/s-pack30.adb2
-rw-r--r--gcc/ada/libgnat/s-pack30.ads2
-rw-r--r--gcc/ada/libgnat/s-pack31.adb2
-rw-r--r--gcc/ada/libgnat/s-pack31.ads2
-rw-r--r--gcc/ada/libgnat/s-pack33.adb2
-rw-r--r--gcc/ada/libgnat/s-pack33.ads2
-rw-r--r--gcc/ada/libgnat/s-pack34.adb2
-rw-r--r--gcc/ada/libgnat/s-pack34.ads2
-rw-r--r--gcc/ada/libgnat/s-pack35.adb2
-rw-r--r--gcc/ada/libgnat/s-pack35.ads2
-rw-r--r--gcc/ada/libgnat/s-pack36.adb2
-rw-r--r--gcc/ada/libgnat/s-pack36.ads2
-rw-r--r--gcc/ada/libgnat/s-pack37.adb2
-rw-r--r--gcc/ada/libgnat/s-pack37.ads2
-rw-r--r--gcc/ada/libgnat/s-pack38.adb2
-rw-r--r--gcc/ada/libgnat/s-pack38.ads2
-rw-r--r--gcc/ada/libgnat/s-pack39.adb2
-rw-r--r--gcc/ada/libgnat/s-pack39.ads2
-rw-r--r--gcc/ada/libgnat/s-pack40.adb2
-rw-r--r--gcc/ada/libgnat/s-pack40.ads2
-rw-r--r--gcc/ada/libgnat/s-pack41.adb2
-rw-r--r--gcc/ada/libgnat/s-pack41.ads2
-rw-r--r--gcc/ada/libgnat/s-pack42.adb2
-rw-r--r--gcc/ada/libgnat/s-pack42.ads2
-rw-r--r--gcc/ada/libgnat/s-pack43.adb2
-rw-r--r--gcc/ada/libgnat/s-pack43.ads2
-rw-r--r--gcc/ada/libgnat/s-pack44.adb2
-rw-r--r--gcc/ada/libgnat/s-pack44.ads2
-rw-r--r--gcc/ada/libgnat/s-pack45.adb2
-rw-r--r--gcc/ada/libgnat/s-pack45.ads2
-rw-r--r--gcc/ada/libgnat/s-pack46.adb2
-rw-r--r--gcc/ada/libgnat/s-pack46.ads2
-rw-r--r--gcc/ada/libgnat/s-pack47.adb2
-rw-r--r--gcc/ada/libgnat/s-pack47.ads2
-rw-r--r--gcc/ada/libgnat/s-pack48.adb2
-rw-r--r--gcc/ada/libgnat/s-pack48.ads2
-rw-r--r--gcc/ada/libgnat/s-pack49.adb2
-rw-r--r--gcc/ada/libgnat/s-pack49.ads2
-rw-r--r--gcc/ada/libgnat/s-pack50.adb2
-rw-r--r--gcc/ada/libgnat/s-pack50.ads2
-rw-r--r--gcc/ada/libgnat/s-pack51.adb2
-rw-r--r--gcc/ada/libgnat/s-pack51.ads2
-rw-r--r--gcc/ada/libgnat/s-pack52.adb2
-rw-r--r--gcc/ada/libgnat/s-pack52.ads2
-rw-r--r--gcc/ada/libgnat/s-pack53.adb2
-rw-r--r--gcc/ada/libgnat/s-pack53.ads2
-rw-r--r--gcc/ada/libgnat/s-pack54.adb2
-rw-r--r--gcc/ada/libgnat/s-pack54.ads2
-rw-r--r--gcc/ada/libgnat/s-pack55.adb2
-rw-r--r--gcc/ada/libgnat/s-pack55.ads2
-rw-r--r--gcc/ada/libgnat/s-pack56.adb2
-rw-r--r--gcc/ada/libgnat/s-pack56.ads2
-rw-r--r--gcc/ada/libgnat/s-pack57.adb2
-rw-r--r--gcc/ada/libgnat/s-pack57.ads2
-rw-r--r--gcc/ada/libgnat/s-pack58.adb2
-rw-r--r--gcc/ada/libgnat/s-pack58.ads2
-rw-r--r--gcc/ada/libgnat/s-pack59.adb2
-rw-r--r--gcc/ada/libgnat/s-pack59.ads2
-rw-r--r--gcc/ada/libgnat/s-pack60.adb2
-rw-r--r--gcc/ada/libgnat/s-pack60.ads2
-rw-r--r--gcc/ada/libgnat/s-pack61.adb2
-rw-r--r--gcc/ada/libgnat/s-pack61.ads2
-rw-r--r--gcc/ada/libgnat/s-pack62.adb2
-rw-r--r--gcc/ada/libgnat/s-pack62.ads2
-rw-r--r--gcc/ada/libgnat/s-pack63.adb2
-rw-r--r--gcc/ada/libgnat/s-pack63.ads2
-rw-r--r--gcc/ada/libgnat/s-parame.adb2
-rw-r--r--gcc/ada/libgnat/s-parame.ads17
-rw-r--r--gcc/ada/libgnat/s-parame__ae653.ads17
-rw-r--r--gcc/ada/libgnat/s-parame__hpux.ads17
-rw-r--r--gcc/ada/libgnat/s-parame__rtems.adb2
-rw-r--r--gcc/ada/libgnat/s-parame__vxworks.adb2
-rw-r--r--gcc/ada/libgnat/s-parame__vxworks.ads15
-rw-r--r--gcc/ada/libgnat/s-parint.adb2
-rw-r--r--gcc/ada/libgnat/s-parint.ads2
-rw-r--r--gcc/ada/libgnat/s-pooglo.adb2
-rw-r--r--gcc/ada/libgnat/s-pooglo.ads2
-rw-r--r--gcc/ada/libgnat/s-pooloc.adb2
-rw-r--r--gcc/ada/libgnat/s-pooloc.ads2
-rw-r--r--gcc/ada/libgnat/s-poosiz.adb2
-rw-r--r--gcc/ada/libgnat/s-poosiz.ads2
-rw-r--r--gcc/ada/libgnat/s-powtab.ads2
-rw-r--r--gcc/ada/libgnat/s-purexc.ads2
-rw-r--r--gcc/ada/libgnat/s-putaim.adb51
-rw-r--r--gcc/ada/libgnat/s-putaim.ads (renamed from gcc/ada/libgnat/a-numaux__x86.ads)56
-rw-r--r--gcc/ada/libgnat/s-putima.adb260
-rw-r--r--gcc/ada/libgnat/s-putima.ads102
-rw-r--r--gcc/ada/libgnat/s-rannum.adb29
-rw-r--r--gcc/ada/libgnat/s-rannum.ads9
-rw-r--r--gcc/ada/libgnat/s-ransee.adb2
-rw-r--r--gcc/ada/libgnat/s-ransee.ads2
-rw-r--r--gcc/ada/libgnat/s-regexp.adb2
-rw-r--r--gcc/ada/libgnat/s-regexp.ads8
-rw-r--r--gcc/ada/libgnat/s-regpat.adb33
-rw-r--r--gcc/ada/libgnat/s-regpat.ads2
-rw-r--r--gcc/ada/libgnat/s-resfil.adb2
-rw-r--r--gcc/ada/libgnat/s-resfil.ads2
-rw-r--r--gcc/ada/libgnat/s-restri.adb2
-rw-r--r--gcc/ada/libgnat/s-restri.ads2
-rw-r--r--gcc/ada/libgnat/s-rident.ads81
-rw-r--r--gcc/ada/libgnat/s-rpc.adb2
-rw-r--r--gcc/ada/libgnat/s-rpc.ads2
-rw-r--r--gcc/ada/libgnat/s-scaval.adb2
-rw-r--r--gcc/ada/libgnat/s-scaval.ads2
-rw-r--r--gcc/ada/libgnat/s-secsta.adb6
-rw-r--r--gcc/ada/libgnat/s-secsta.ads21
-rw-r--r--gcc/ada/libgnat/s-sequio.adb2
-rw-r--r--gcc/ada/libgnat/s-sequio.ads2
-rw-r--r--gcc/ada/libgnat/s-shabig.ads80
-rw-r--r--gcc/ada/libgnat/s-shasto.adb2
-rw-r--r--gcc/ada/libgnat/s-shasto.ads2
-rw-r--r--gcc/ada/libgnat/s-soflin.adb2
-rw-r--r--gcc/ada/libgnat/s-soflin.ads2
-rw-r--r--gcc/ada/libgnat/s-soliin.adb2
-rw-r--r--gcc/ada/libgnat/s-soliin.ads2
-rw-r--r--gcc/ada/libgnat/s-sopco3.adb2
-rw-r--r--gcc/ada/libgnat/s-sopco3.ads2
-rw-r--r--gcc/ada/libgnat/s-sopco4.adb2
-rw-r--r--gcc/ada/libgnat/s-sopco4.ads2
-rw-r--r--gcc/ada/libgnat/s-sopco5.adb2
-rw-r--r--gcc/ada/libgnat/s-sopco5.ads2
-rw-r--r--gcc/ada/libgnat/s-spsufi.adb2
-rw-r--r--gcc/ada/libgnat/s-spsufi.ads2
-rw-r--r--gcc/ada/libgnat/s-stache.adb2
-rw-r--r--gcc/ada/libgnat/s-stache.ads2
-rw-r--r--gcc/ada/libgnat/s-stalib.adb2
-rw-r--r--gcc/ada/libgnat/s-stalib.ads3
-rw-r--r--gcc/ada/libgnat/s-statxd.adb (renamed from gcc/ada/libgnat/s-stratt__xdr.adb)233
-rw-r--r--gcc/ada/libgnat/s-statxd.ads117
-rw-r--r--gcc/ada/libgnat/s-stausa.adb2
-rw-r--r--gcc/ada/libgnat/s-stausa.ads2
-rw-r--r--gcc/ada/libgnat/s-stchop.adb2
-rw-r--r--gcc/ada/libgnat/s-stchop.ads2
-rw-r--r--gcc/ada/libgnat/s-stchop__limit.ads2
-rw-r--r--gcc/ada/libgnat/s-stchop__rtems.adb2
-rw-r--r--gcc/ada/libgnat/s-stchop__vxworks.adb2
-rw-r--r--gcc/ada/libgnat/s-stoele.adb2
-rw-r--r--gcc/ada/libgnat/s-stoele.ads2
-rw-r--r--gcc/ada/libgnat/s-stopoo.adb2
-rw-r--r--gcc/ada/libgnat/s-stopoo.ads8
-rw-r--r--gcc/ada/libgnat/s-stposu.adb17
-rw-r--r--gcc/ada/libgnat/s-stposu.ads4
-rw-r--r--gcc/ada/libgnat/s-stratt.adb342
-rw-r--r--gcc/ada/libgnat/s-stratt.ads19
-rw-r--r--gcc/ada/libgnat/s-strcom.adb2
-rw-r--r--gcc/ada/libgnat/s-strcom.ads2
-rw-r--r--gcc/ada/libgnat/s-strhas.adb2
-rw-r--r--gcc/ada/libgnat/s-strhas.ads2
-rw-r--r--gcc/ada/libgnat/s-string.adb2
-rw-r--r--gcc/ada/libgnat/s-string.ads2
-rw-r--r--gcc/ada/libgnat/s-strops.adb2
-rw-r--r--gcc/ada/libgnat/s-strops.ads2
-rw-r--r--gcc/ada/libgnat/s-ststop.adb29
-rw-r--r--gcc/ada/libgnat/s-ststop.ads8
-rw-r--r--gcc/ada/libgnat/s-tasloc.adb2
-rw-r--r--gcc/ada/libgnat/s-tasloc.ads2
-rw-r--r--gcc/ada/libgnat/s-thread.ads2
-rw-r--r--gcc/ada/libgnat/s-thread__ae653.adb57
-rw-r--r--gcc/ada/libgnat/s-traceb.adb2
-rw-r--r--gcc/ada/libgnat/s-traceb.ads2
-rw-r--r--gcc/ada/libgnat/s-traceb__hpux.adb2
-rw-r--r--gcc/ada/libgnat/s-traceb__mastop.adb2
-rw-r--r--gcc/ada/libgnat/s-traent.adb2
-rw-r--r--gcc/ada/libgnat/s-traent.ads2
-rw-r--r--gcc/ada/libgnat/s-trasym.adb2
-rw-r--r--gcc/ada/libgnat/s-trasym.ads2
-rw-r--r--gcc/ada/libgnat/s-trasym__dwarf.adb4
-rw-r--r--gcc/ada/libgnat/s-tsmona.adb2
-rw-r--r--gcc/ada/libgnat/s-tsmona__linux.adb2
-rw-r--r--gcc/ada/libgnat/s-tsmona__mingw.adb2
-rw-r--r--gcc/ada/libgnat/s-unstyp.ads22
-rw-r--r--gcc/ada/libgnat/s-utf_32.adb6229
-rw-r--r--gcc/ada/libgnat/s-utf_32.ads19
-rw-r--r--gcc/ada/libgnat/s-valboo.adb2
-rw-r--r--gcc/ada/libgnat/s-valboo.ads2
-rw-r--r--gcc/ada/libgnat/s-valcha.adb2
-rw-r--r--gcc/ada/libgnat/s-valcha.ads2
-rw-r--r--gcc/ada/libgnat/s-valdec.adb2
-rw-r--r--gcc/ada/libgnat/s-valdec.ads2
-rw-r--r--gcc/ada/libgnat/s-valenu.adb2
-rw-r--r--gcc/ada/libgnat/s-valenu.ads2
-rw-r--r--gcc/ada/libgnat/s-valint.adb2
-rw-r--r--gcc/ada/libgnat/s-valint.ads2
-rw-r--r--gcc/ada/libgnat/s-vallld.adb2
-rw-r--r--gcc/ada/libgnat/s-vallld.ads2
-rw-r--r--gcc/ada/libgnat/s-vallli.adb2
-rw-r--r--gcc/ada/libgnat/s-vallli.ads2
-rw-r--r--gcc/ada/libgnat/s-valllu.adb2
-rw-r--r--gcc/ada/libgnat/s-valllu.ads2
-rw-r--r--gcc/ada/libgnat/s-valrea.adb14
-rw-r--r--gcc/ada/libgnat/s-valrea.ads2
-rw-r--r--gcc/ada/libgnat/s-valuns.adb2
-rw-r--r--gcc/ada/libgnat/s-valuns.ads2
-rw-r--r--gcc/ada/libgnat/s-valuti.adb2
-rw-r--r--gcc/ada/libgnat/s-valuti.ads2
-rw-r--r--gcc/ada/libgnat/s-valwch.adb2
-rw-r--r--gcc/ada/libgnat/s-valwch.ads2
-rw-r--r--gcc/ada/libgnat/s-veboop.adb2
-rw-r--r--gcc/ada/libgnat/s-veboop.ads2
-rw-r--r--gcc/ada/libgnat/s-vector.ads2
-rw-r--r--gcc/ada/libgnat/s-vercon.adb2
-rw-r--r--gcc/ada/libgnat/s-vercon.ads2
-rw-r--r--gcc/ada/libgnat/s-wchcnv.adb2
-rw-r--r--gcc/ada/libgnat/s-wchcnv.ads2
-rw-r--r--gcc/ada/libgnat/s-wchcon.adb2
-rw-r--r--gcc/ada/libgnat/s-wchcon.ads2
-rw-r--r--gcc/ada/libgnat/s-wchjis.adb2
-rw-r--r--gcc/ada/libgnat/s-wchjis.ads2
-rw-r--r--gcc/ada/libgnat/s-wchstw.adb2
-rw-r--r--gcc/ada/libgnat/s-wchstw.ads2
-rw-r--r--gcc/ada/libgnat/s-wchwts.adb2
-rw-r--r--gcc/ada/libgnat/s-wchwts.ads2
-rw-r--r--gcc/ada/libgnat/s-widboo.adb2
-rw-r--r--gcc/ada/libgnat/s-widboo.ads2
-rw-r--r--gcc/ada/libgnat/s-widcha.adb2
-rw-r--r--gcc/ada/libgnat/s-widcha.ads2
-rw-r--r--gcc/ada/libgnat/s-widenu.adb2
-rw-r--r--gcc/ada/libgnat/s-widenu.ads2
-rw-r--r--gcc/ada/libgnat/s-widlli.adb2
-rw-r--r--gcc/ada/libgnat/s-widlli.ads2
-rw-r--r--gcc/ada/libgnat/s-widllu.adb2
-rw-r--r--gcc/ada/libgnat/s-widllu.ads2
-rw-r--r--gcc/ada/libgnat/s-widwch.adb2
-rw-r--r--gcc/ada/libgnat/s-widwch.ads2
-rw-r--r--gcc/ada/libgnat/s-win32.ads2
-rw-r--r--gcc/ada/libgnat/s-winext.ads2
-rw-r--r--gcc/ada/libgnat/s-wwdcha.adb2
-rw-r--r--gcc/ada/libgnat/s-wwdcha.ads2
-rw-r--r--gcc/ada/libgnat/s-wwdenu.adb2
-rw-r--r--gcc/ada/libgnat/s-wwdenu.ads2
-rw-r--r--gcc/ada/libgnat/s-wwdwch.adb2
-rw-r--r--gcc/ada/libgnat/s-wwdwch.ads2
-rw-r--r--gcc/ada/libgnat/system-aix.ads2
-rw-r--r--gcc/ada/libgnat/system-darwin-arm.ads2
-rw-r--r--gcc/ada/libgnat/system-darwin-ppc.ads2
-rw-r--r--gcc/ada/libgnat/system-darwin-x86.ads2
-rw-r--r--gcc/ada/libgnat/system-djgpp.ads2
-rw-r--r--gcc/ada/libgnat/system-dragonfly-x86_64.ads2
-rw-r--r--gcc/ada/libgnat/system-freebsd.ads2
-rw-r--r--gcc/ada/libgnat/system-hpux-ia64.ads2
-rw-r--r--gcc/ada/libgnat/system-hpux.ads2
-rw-r--r--gcc/ada/libgnat/system-linux-alpha.ads2
-rw-r--r--gcc/ada/libgnat/system-linux-arm.ads2
-rw-r--r--gcc/ada/libgnat/system-linux-hppa.ads2
-rw-r--r--gcc/ada/libgnat/system-linux-ia64.ads2
-rw-r--r--gcc/ada/libgnat/system-linux-m68k.ads2
-rw-r--r--gcc/ada/libgnat/system-linux-mips.ads2
-rw-r--r--gcc/ada/libgnat/system-linux-ppc.ads2
-rw-r--r--gcc/ada/libgnat/system-linux-riscv.ads2
-rw-r--r--gcc/ada/libgnat/system-linux-s390.ads2
-rw-r--r--gcc/ada/libgnat/system-linux-sh4.ads2
-rw-r--r--gcc/ada/libgnat/system-linux-sparc.ads2
-rw-r--r--gcc/ada/libgnat/system-linux-x86.ads2
-rw-r--r--gcc/ada/libgnat/system-lynxos178-ppc.ads2
-rw-r--r--gcc/ada/libgnat/system-lynxos178-x86.ads2
-rw-r--r--gcc/ada/libgnat/system-mingw.ads7
-rw-r--r--gcc/ada/libgnat/system-qnx-aarch64.ads2
-rw-r--r--gcc/ada/libgnat/system-rtems.ads2
-rw-r--r--gcc/ada/libgnat/system-solaris-sparc.ads2
-rw-r--r--gcc/ada/libgnat/system-solaris-x86.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-arm-rtp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-arm.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-e500-kernel.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-e500-rtp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-e500-vthread.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-ppc-kernel.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-ppc-rtp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-ppc-vthread.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-ppc.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-x86-kernel.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-x86-rtp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-x86-vthread.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks-x86.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-aarch64.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-arm.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-e500-kernel.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-e500-rtp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-x86-kernel.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-x86-rtp.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads2
-rw-r--r--gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads2
-rw-r--r--gcc/ada/libgnat/system.ads2
-rw-r--r--gcc/ada/link.c2
-rw-r--r--gcc/ada/live.adb2
-rw-r--r--gcc/ada/live.ads2
-rw-r--r--gcc/ada/locales.c2
-rw-r--r--gcc/ada/make.adb4
-rw-r--r--gcc/ada/make.ads2
-rw-r--r--gcc/ada/make_util.adb2
-rw-r--r--gcc/ada/make_util.ads2
-rw-r--r--gcc/ada/makeusg.adb2
-rw-r--r--gcc/ada/makeusg.ads2
-rw-r--r--gcc/ada/mdll-fil.adb2
-rw-r--r--gcc/ada/mdll-fil.ads2
-rw-r--r--gcc/ada/mdll-utl.adb2
-rw-r--r--gcc/ada/mdll-utl.ads2
-rw-r--r--gcc/ada/mdll.adb2
-rw-r--r--gcc/ada/mdll.ads2
-rw-r--r--gcc/ada/mingw32.h2
-rw-r--r--gcc/ada/mkdir.c2
-rw-r--r--gcc/ada/namet-sp.adb2
-rw-r--r--gcc/ada/namet-sp.ads2
-rw-r--r--gcc/ada/namet.adb274
-rw-r--r--gcc/ada/namet.ads139
-rw-r--r--gcc/ada/namet.h2
-rw-r--r--gcc/ada/nlists.adb46
-rw-r--r--gcc/ada/nlists.ads14
-rw-r--r--gcc/ada/nlists.h2
-rw-r--r--gcc/ada/opt.adb132
-rw-r--r--gcc/ada/opt.ads173
-rw-r--r--gcc/ada/osint-b.adb2
-rw-r--r--gcc/ada/osint-b.ads2
-rw-r--r--gcc/ada/osint-c.adb85
-rw-r--r--gcc/ada/osint-c.ads14
-rw-r--r--gcc/ada/osint-l.adb2
-rw-r--r--gcc/ada/osint-l.ads2
-rw-r--r--gcc/ada/osint-m.adb2
-rw-r--r--gcc/ada/osint-m.ads2
-rw-r--r--gcc/ada/osint.adb77
-rw-r--r--gcc/ada/osint.ads2
-rw-r--r--gcc/ada/output.adb31
-rw-r--r--gcc/ada/output.ads11
-rw-r--r--gcc/ada/par-ch10.adb47
-rw-r--r--gcc/ada/par-ch11.adb44
-rw-r--r--gcc/ada/par-ch12.adb10
-rw-r--r--gcc/ada/par-ch13.adb2
-rw-r--r--gcc/ada/par-ch2.adb7
-rw-r--r--gcc/ada/par-ch3.adb88
-rw-r--r--gcc/ada/par-ch4.adb212
-rw-r--r--gcc/ada/par-ch5.adb32
-rw-r--r--gcc/ada/par-ch6.adb40
-rw-r--r--gcc/ada/par-ch7.adb54
-rw-r--r--gcc/ada/par-ch8.adb2
-rw-r--r--gcc/ada/par-ch9.adb2
-rw-r--r--gcc/ada/par-endh.adb2
-rw-r--r--gcc/ada/par-labl.adb2
-rw-r--r--gcc/ada/par-load.adb2
-rw-r--r--gcc/ada/par-prag.adb95
-rw-r--r--gcc/ada/par-sync.adb2
-rw-r--r--gcc/ada/par-tchk.adb2
-rw-r--r--gcc/ada/par-util.adb6
-rw-r--r--gcc/ada/par.adb22
-rw-r--r--gcc/ada/par.ads2
-rw-r--r--gcc/ada/par_sco.adb18
-rw-r--r--gcc/ada/par_sco.ads2
-rw-r--r--gcc/ada/pprint.adb15
-rw-r--r--gcc/ada/pprint.ads2
-rw-r--r--gcc/ada/prep.adb2
-rw-r--r--gcc/ada/prep.ads2
-rw-r--r--gcc/ada/prepcomp.adb2
-rw-r--r--gcc/ada/prepcomp.ads2
-rw-r--r--gcc/ada/put_scos.adb2
-rw-r--r--gcc/ada/put_scos.ads2
-rw-r--r--gcc/ada/raise-gcc.c4
-rw-r--r--gcc/ada/raise.c2
-rw-r--r--gcc/ada/raise.h2
-rw-r--r--gcc/ada/repinfo-input.adb23
-rw-r--r--gcc/ada/repinfo-input.ads16
-rw-r--r--gcc/ada/repinfo.adb172
-rw-r--r--gcc/ada/repinfo.ads56
-rw-r--r--gcc/ada/repinfo.h2
-rw-r--r--gcc/ada/restrict.adb278
-rw-r--r--gcc/ada/restrict.ads69
-rw-r--r--gcc/ada/rident.ads2
-rw-r--r--gcc/ada/rtfinal.c2
-rw-r--r--gcc/ada/rtinit.c2
-rw-r--r--gcc/ada/rtsfind.adb176
-rw-r--r--gcc/ada/rtsfind.ads215
-rw-r--r--gcc/ada/runtime.h2
-rw-r--r--gcc/ada/s-oscons-tmplt.c2
-rw-r--r--gcc/ada/sa_messages.adb2
-rw-r--r--gcc/ada/sa_messages.ads2
-rw-r--r--gcc/ada/scans.adb2
-rw-r--r--gcc/ada/scans.ads7
-rw-r--r--gcc/ada/scil_ll.adb9
-rw-r--r--gcc/ada/scil_ll.ads2
-rw-r--r--gcc/ada/scn.adb162
-rw-r--r--gcc/ada/scn.ads2
-rw-r--r--gcc/ada/scng.adb405
-rw-r--r--gcc/ada/scng.ads2
-rw-r--r--gcc/ada/scos.adb2
-rw-r--r--gcc/ada/scos.ads4
-rw-r--r--gcc/ada/scos.h2
-rw-r--r--gcc/ada/sdefault.ads2
-rw-r--r--gcc/ada/seh_init.c2
-rw-r--r--gcc/ada/sem.adb80
-rw-r--r--gcc/ada/sem.ads33
-rw-r--r--gcc/ada/sem_aggr.adb733
-rw-r--r--gcc/ada/sem_aggr.ads6
-rw-r--r--gcc/ada/sem_attr.adb1052
-rw-r--r--gcc/ada/sem_attr.ads39
-rw-r--r--gcc/ada/sem_aux.adb108
-rw-r--r--gcc/ada/sem_aux.ads22
-rw-r--r--gcc/ada/sem_case.adb15
-rw-r--r--gcc/ada/sem_case.ads14
-rw-r--r--gcc/ada/sem_cat.adb30
-rw-r--r--gcc/ada/sem_cat.ads6
-rw-r--r--gcc/ada/sem_ch10.adb236
-rw-r--r--gcc/ada/sem_ch10.ads2
-rw-r--r--gcc/ada/sem_ch11.adb24
-rw-r--r--gcc/ada/sem_ch11.ads2
-rw-r--r--gcc/ada/sem_ch12.adb1248
-rw-r--r--gcc/ada/sem_ch12.ads2
-rw-r--r--gcc/ada/sem_ch13.adb3025
-rw-r--r--gcc/ada/sem_ch13.ads35
-rw-r--r--gcc/ada/sem_ch2.adb2
-rw-r--r--gcc/ada/sem_ch2.ads2
-rw-r--r--gcc/ada/sem_ch3.adb1760
-rw-r--r--gcc/ada/sem_ch3.ads19
-rw-r--r--gcc/ada/sem_ch4.adb1048
-rw-r--r--gcc/ada/sem_ch4.ads2
-rw-r--r--gcc/ada/sem_ch5.adb266
-rw-r--r--gcc/ada/sem_ch5.ads2
-rw-r--r--gcc/ada/sem_ch6.adb1174
-rw-r--r--gcc/ada/sem_ch6.ads12
-rw-r--r--gcc/ada/sem_ch7.adb174
-rw-r--r--gcc/ada/sem_ch7.ads2
-rw-r--r--gcc/ada/sem_ch8.adb843
-rw-r--r--gcc/ada/sem_ch8.ads2
-rw-r--r--gcc/ada/sem_ch9.adb68
-rw-r--r--gcc/ada/sem_ch9.ads2
-rw-r--r--gcc/ada/sem_dim.adb147
-rw-r--r--gcc/ada/sem_dim.ads2
-rw-r--r--gcc/ada/sem_disp.adb84
-rw-r--r--gcc/ada/sem_disp.ads12
-rw-r--r--gcc/ada/sem_dist.adb11
-rw-r--r--gcc/ada/sem_dist.ads2
-rw-r--r--gcc/ada/sem_elab.adb458
-rw-r--r--gcc/ada/sem_elab.ads2
-rw-r--r--gcc/ada/sem_elim.adb4
-rw-r--r--gcc/ada/sem_elim.ads2
-rw-r--r--gcc/ada/sem_eval.adb668
-rw-r--r--gcc/ada/sem_eval.ads47
-rw-r--r--gcc/ada/sem_intr.adb47
-rw-r--r--gcc/ada/sem_intr.ads2
-rw-r--r--gcc/ada/sem_mech.adb11
-rw-r--r--gcc/ada/sem_mech.ads2
-rw-r--r--gcc/ada/sem_prag.adb2326
-rw-r--r--gcc/ada/sem_prag.ads10
-rw-r--r--gcc/ada/sem_res.adb1563
-rw-r--r--gcc/ada/sem_res.ads2
-rw-r--r--gcc/ada/sem_scil.adb14
-rw-r--r--gcc/ada/sem_scil.ads2
-rw-r--r--gcc/ada/sem_smem.adb6
-rw-r--r--gcc/ada/sem_smem.ads2
-rw-r--r--gcc/ada/sem_type.adb208
-rw-r--r--gcc/ada/sem_type.ads4
-rw-r--r--gcc/ada/sem_util.adb4158
-rw-r--r--gcc/ada/sem_util.ads309
-rw-r--r--gcc/ada/sem_warn.adb321
-rw-r--r--gcc/ada/sem_warn.ads2
-rw-r--r--gcc/ada/set_targ.adb2
-rw-r--r--gcc/ada/set_targ.ads2
-rw-r--r--gcc/ada/sfn_scan.adb2
-rw-r--r--gcc/ada/sfn_scan.ads2
-rw-r--r--gcc/ada/sigtramp-armdroid.c2
-rw-r--r--gcc/ada/sigtramp-ios.c2
-rw-r--r--gcc/ada/sigtramp-qnx.c2
-rw-r--r--gcc/ada/sigtramp-vxworks.c2
-rw-r--r--gcc/ada/sigtramp.h2
-rw-r--r--gcc/ada/sinfo-cn.adb2
-rw-r--r--gcc/ada/sinfo-cn.ads2
-rw-r--r--gcc/ada/sinfo.adb376
-rw-r--r--gcc/ada/sinfo.ads482
-rw-r--r--gcc/ada/sinput-c.adb2
-rw-r--r--gcc/ada/sinput-c.ads2
-rw-r--r--gcc/ada/sinput-d.adb2
-rw-r--r--gcc/ada/sinput-d.ads2
-rw-r--r--gcc/ada/sinput-l.adb2
-rw-r--r--gcc/ada/sinput-l.ads2
-rw-r--r--gcc/ada/sinput.adb167
-rw-r--r--gcc/ada/sinput.ads10
-rw-r--r--gcc/ada/snames.adb-tmpl45
-rw-r--r--gcc/ada/snames.ads-tmpl193
-rw-r--r--gcc/ada/socket.c46
-rw-r--r--gcc/ada/spark_xrefs.adb2
-rw-r--r--gcc/ada/spark_xrefs.ads2
-rw-r--r--gcc/ada/sprint.adb114
-rw-r--r--gcc/ada/sprint.ads6
-rw-r--r--gcc/ada/stand.adb190
-rw-r--r--gcc/ada/stand.ads23
-rw-r--r--gcc/ada/stringt.adb22
-rw-r--r--gcc/ada/stringt.ads16
-rw-r--r--gcc/ada/stringt.h2
-rw-r--r--gcc/ada/style.adb2
-rw-r--r--gcc/ada/style.ads2
-rw-r--r--gcc/ada/styleg.adb8
-rw-r--r--gcc/ada/styleg.ads2
-rw-r--r--gcc/ada/stylesw.adb2
-rw-r--r--gcc/ada/stylesw.ads2
-rw-r--r--gcc/ada/switch-b.adb2
-rw-r--r--gcc/ada/switch-b.ads2
-rw-r--r--gcc/ada/switch-c.adb11
-rw-r--r--gcc/ada/switch-c.ads2
-rw-r--r--gcc/ada/switch-m.adb2
-rw-r--r--gcc/ada/switch-m.ads2
-rw-r--r--gcc/ada/switch.adb6
-rw-r--r--gcc/ada/switch.ads4
-rw-r--r--gcc/ada/symbols.adb2
-rw-r--r--gcc/ada/symbols.ads2
-rw-r--r--gcc/ada/sysdep.c4
-rw-r--r--gcc/ada/table.adb61
-rw-r--r--gcc/ada/table.ads9
-rw-r--r--gcc/ada/targext.c2
-rw-r--r--gcc/ada/targparm.adb10
-rw-r--r--gcc/ada/targparm.ads2
-rw-r--r--gcc/ada/tb-gcc.c125
-rw-r--r--gcc/ada/tbuild.adb51
-rw-r--r--gcc/ada/tbuild.ads11
-rw-r--r--gcc/ada/tempdir.adb2
-rw-r--r--gcc/ada/tempdir.ads2
-rw-r--r--gcc/ada/terminals.c99
-rw-r--r--gcc/ada/tracebak.c101
-rw-r--r--gcc/ada/tree_gen.adb72
-rw-r--r--gcc/ada/tree_gen.ads28
-rw-r--r--gcc/ada/tree_io.adb661
-rw-r--r--gcc/ada/tree_io.ads128
-rw-r--r--gcc/ada/treepr.adb23
-rw-r--r--gcc/ada/treepr.ads2
-rw-r--r--gcc/ada/ttypes.ads2
-rw-r--r--gcc/ada/types.adb2
-rw-r--r--gcc/ada/types.ads54
-rw-r--r--gcc/ada/types.h9
-rw-r--r--gcc/ada/uintp.adb58
-rw-r--r--gcc/ada/uintp.ads14
-rw-r--r--gcc/ada/uintp.h2
-rw-r--r--gcc/ada/uname.adb2
-rw-r--r--gcc/ada/uname.ads2
-rw-r--r--gcc/ada/urealp.adb66
-rw-r--r--gcc/ada/urealp.ads14
-rw-r--r--gcc/ada/urealp.h2
-rw-r--r--gcc/ada/usage.adb13
-rw-r--r--gcc/ada/usage.ads2
-rw-r--r--gcc/ada/validsw.adb2
-rw-r--r--gcc/ada/validsw.ads2
-rw-r--r--gcc/ada/vast.adb (renamed from gcc/ada/tree_in.adb)53
-rw-r--r--gcc/ada/vast.ads (renamed from gcc/ada/tree_in.ads)22
-rw-r--r--gcc/ada/warnsw.adb2
-rw-r--r--gcc/ada/warnsw.ads6
-rw-r--r--gcc/ada/widechar.adb24
-rw-r--r--gcc/ada/widechar.ads6
-rw-r--r--gcc/ada/xeinfo.adb46
-rw-r--r--gcc/ada/xnmake.adb2
-rw-r--r--gcc/ada/xoscons.adb7
-rw-r--r--gcc/ada/xr_tabls.adb6
-rw-r--r--gcc/ada/xr_tabls.ads2
-rw-r--r--gcc/ada/xref_lib.adb34
-rw-r--r--gcc/ada/xref_lib.ads2
-rw-r--r--gcc/ada/xsinfo.adb2
-rw-r--r--gcc/ada/xsnamest.adb28
-rw-r--r--gcc/ada/xtreeprs.adb2
-rw-r--r--gcc/ada/xutil.adb2
-rw-r--r--gcc/ada/xutil.ads2
2012 files changed, 54175 insertions, 35749 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index eacc976..304b19a 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,8056 @@
+2020-07-27 Alexandre Oliva <oliva@adacore.com>
+
+ * switch.adb (Is_Internal_GCC_Switch): Revert accidental
+ reintroduction of auxbase and auxbase-strip.
+
+2020-07-27 Javier Miranda <miranda@adacore.com>
+
+ * sem_res.adb (Resolve_Actuals): Restrict the check on matching
+ aliased components to view conversions of array types that are
+ not placed in an instance. In such case at runtime an object is
+ created.
+ * sem_util.ads (Is_Actual_In_Out_Parameter, Is_View_Conversion):
+ New subprograms.
+ * sem_util.adb (Is_Actual_In_Out_Parameter, Is_View_Conversion):
+ New subprograms.
+
+2020-07-27 Arnaud Charlet <charlet@adacore.com>
+
+ * lib-xref.adb (Generate_Reference): Protect against malformed
+ tree in case of severe errors.
+ * sem_ch8.adb (Add_Implicit_Operator): Ditto.
+
+2020-07-27 Arnaud Charlet <charlet@adacore.com>
+
+ * opt.ads (Ada_Version_Runtime): Set to Ada_2020.
+ * sem_ch3.adb (Analyze_Subtype_Declaration): Propagate
+ Is_Independent flag to subtypes.
+ * libgnarl/s-taprop__linux.adb: Adapt to Ada 2020 warning.
+ * libgnat/a-nbnbin.adb, libgnat/a-nbnbin.ads,
+ libgnat/a-nbnbin__gmp.adb, libgnat/a-nbnbre.adb,
+ libgnat/a-nbnbre.ads, libgnat/a-stobbu.adb,
+ libgnat/a-stobbu.ads, libgnat/a-stobfi.adb,
+ libgnat/a-stobfi.ads, libgnat/a-stoubu.adb,
+ libgnat/a-stoubu.ads, libgnat/a-stoufi.adb,
+ libgnat/a-stoufi.ads, libgnat/a-stoufo.adb,
+ libgnat/a-stoufo.ads, libgnat/a-stouut.adb,
+ libgnat/a-stouut.ads, libgnat/a-strsto.ads,
+ libgnat/a-ststbo.adb, libgnat/a-ststbo.ads,
+ libgnat/a-ststun.adb, libgnat/a-ststun.ads,
+ libgnat/a-stteou.ads, libgnat/s-aoinar.ads,
+ libgnat/s-aomoar.ads, libgnat/s-atopex.ads,
+ libgnat/s-putaim.adb, libgnat/s-putaim.ads,
+ libgnat/s-putima.adb, libgnat/s-putima.ads: Remove pragma
+ Ada_2020, now redundant.
+
+2020-07-27 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch6.adb (Expand_Call_Helper): Modify addition of the extra
+ accessibility parameter to take into account the extra
+ accessibility of formals within the calling subprogram.
+
+2020-07-27 Bob Duff <duff@adacore.com>
+
+ * exp_imgv.adb (Expand_Image_Attribute): Add Root_Type, so
+ constrained subtypes work.
+
+2020-07-27 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * exp_prag.adb (Arg1, Arg2, Arg3): Removed.
+ (Arg_N): New function.
+
+2020-07-27 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch8.adb (Analyze_Object_Renaming): Allow values in Ada
+ 2020 mode.
+
+2020-07-27 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_res.adb (Resolve_Actuals): Refine 6.4.1 rules as per
+ AI12-0377.
+
+2020-07-27 Bob Duff <duff@adacore.com>
+
+ * errout.ads, errout.adb (Error_Msg_Ada_2020_Feature): New
+ procedure analogous to Error_Msg_Ada_2012_Feature.
+ * sem_attr.adb (Analyze_Image_Attribute): Use
+ Error_Msg_Ada_2012_Feature and Error_Msg_Ada_2020_Feature to
+ indicate that Object'Image is allowed in Ada 2012, and that
+ 'Image is allowed for any type in Ada 2020.
+
+2020-07-27 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * libgnat/a-strunb.adb (Sum, Mul, Saturated_Sum, Saturated_Mul):
+ New routines. Use them when resulting string size more that
+ length of the strings in parameters.
+ (Unbounded_Slice): Use "- 1" instead of "+ 1" in opposite side
+ of condition to avoid overflow.
+ * libgnat/a-strunb__shared.adb (Sum, Mul): New routines.
+ (Allocate): New routine with 2 parameters. Use routine above
+ when resulting string size more that length of the strings in
+ parameters.
+ (Aligned_Max_Length): Do not try to align to more than Natural'Last.
+ (Unbounded_Slice): Use "- 1" instead of "+ 1" in opposite side
+ of condition to avoid overflow.
+
+2020-07-27 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_attr.adb (Resolve_Attribute): Remove dead code.
+
+2020-07-27 Arnaud Charlet <charlet@adacore.com>
+
+ * aspects.adb, atree.adb, atree.ads, checks.adb, contracts.adb,
+ einfo.adb, errout.adb, exp_aggr.adb, exp_attr.adb, exp_cg.adb,
+ exp_ch11.adb, exp_ch2.adb, exp_ch3.adb, exp_ch4.adb,
+ exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_ch8.adb, exp_ch9.adb,
+ exp_dbug.adb, exp_disp.adb, exp_intr.adb, exp_pakd.adb,
+ exp_prag.adb, exp_put_image.adb, exp_smem.adb, exp_tss.adb,
+ exp_unst.adb, exp_util.adb, freeze.adb, ghost.adb, gnat1drv.adb,
+ inline.adb, lib-writ.adb, lib-xref-spark_specific.adb,
+ lib-xref.adb, namet.adb, namet.ads, nlists.adb, par-ch10.adb,
+ par-ch2.adb, par-ch3.adb, par-ch4.adb, par-ch5.adb, par-ch6.adb,
+ par-prag.adb, par-util.adb, par_sco.adb, pprint.adb,
+ repinfo.adb, restrict.adb, rtsfind.adb, scil_ll.adb, sem.adb,
+ sem_aggr.adb, sem_attr.adb, sem_aux.adb, sem_cat.adb,
+ sem_ch10.adb, sem_ch11.adb, sem_ch12.adb, sem_ch13.adb,
+ sem_ch3.adb, sem_ch4.adb, sem_ch5.adb, sem_ch6.adb, sem_ch7.adb,
+ sem_ch8.adb, sem_ch9.adb, sem_dim.adb, sem_disp.adb,
+ sem_dist.adb, sem_elab.adb, sem_elim.adb, sem_eval.adb,
+ sem_intr.adb, sem_mech.adb, sem_prag.adb, sem_res.adb,
+ sem_scil.adb, sem_type.adb, sem_util.adb, sem_warn.adb,
+ sinfo.adb, sinfo.ads, sprint.adb, styleg.adb, tbuild.adb,
+ treepr.adb (Nkind_In, Nam_In, Ekind_In): Removed, replaced by
+ membership tests.
+
+2020-07-27 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma, Pragma_Max_Entry_Queue_Length):
+ Refine error message to indicate that the pragma must apply to
+ an entry declaration, not just an entry.
+
+2020-07-27 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch6.adb (Make_Build_In_Place_Iface_Call_In_Allocator):
+ Revert previous patch, and add a missing type conversion to
+ displace the pointer to the allocated object to reference the
+ target dispatch table.
+
+2020-07-27 Javier Miranda <miranda@adacore.com>
+
+ * sem_res.adb (Resolve_Actuals): Restore restrictive check on
+ view conversions which required matching value of
+ Has_Aliased_Components of formals and actuals. Required to avoid
+ the regression of ACATS b460005.
+
+2020-07-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch12.adb (Instantiate_Package_Body): Add commentary for a
+ nesting issue with parent handling and private view switching.
+ (Switch_View): Do not skip specific private-dependent subtypes.
+
+2020-07-27 Patrick Bernardi <bernardi@adacore.com>
+
+ * Makefile.rtl: Remove X86_TARGET_PAIRS for x86-lynx178elf.
+
+2020-07-27 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Analyze_Address_Specification_Clause): Do not
+ emit a warning when a constant declaration in a generic unit
+ overlays a generic In_Parameter.
+
+2020-07-27 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch3.adb (Check_Abstract_Overriding): Remove Scope
+ comparison test from test related to initial implementation of
+ AI12-0042, plus remove the related ??? comment.
+ (Derive_Subprogram): Add test requiring that the type extension
+ appear in the visible part of its enclosing package when
+ checking the overriding requirement of 7.3.2(6.1/4), as
+ clarified by AI12-0382.
+
+2020-07-27 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_N_Attribute_Reference) Extend
+ existing workaround to 'Pos.
+
+2020-07-27 Bob Duff <duff@adacore.com>
+
+ * libgnat/s-rannum.ads, libgnat/s-rannum.adb: Add Put_Image.
+ This will be inherited by the language-defined packages
+ Ada.Numerics.Discrete_Random and Ada.Numerics.Float_Random.
+ * libgnat/a-convec.ads, libgnat/a-convec.adb: Add Put_Image.
+ * libgnat/s-putima.ads: Add pragma Preelaborate, so this can be
+ imported into containers packages.
+ * libgnat/s-putima.adb: Move Digit to private part; otherwise
+ reference to Base is illegal in Preelaborate generic.
+ * exp_put_image.adb (Build_Record_Put_Image_Procedure): Use the
+ base type.
+
+2020-07-23 Arnaud Charlet <charlet@adacore.com>
+
+ * aspects.ads: Declare CUDA_Global as aspect.
+ * einfo.ads: Use Flag118 for the Is_CUDA_Kernel flag.
+ (Set_Is_CUDA_Kernel): New function.
+ (Is_CUDA_Kernel): New function.
+ * einfo.adb (Set_Is_CUDA_Kernel): New function.
+ (Is_CUDA_Kernel): New function.
+ * par-prag.adb (Prag): Ignore Pragma_CUDA_Execute and
+ Pragma_CUDA_global.
+ * rtsfind.ads: Define CUDA.Driver_Types.Stream_T and
+ CUDA.Vector_Types.Dim3 entities
+ * rtsfind.adb: Define CUDA_Descendant subtype.
+ (Get_Unit_Name): Handle CUDA_Descendant packages.
+ * sem_prag.ads: Mark CUDA_Global as aspect-specifying pragma.
+ * sem_prag.adb (Analyze_Pragma): Validate Pragma_CUDA_Execute and
+ Pragma_CUDA_Global.
+ * snames.ads-tmpl: Define Name_CUDA_Execute and Name_CUDA_Global.
+
+2020-07-23 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch13.ads (Same_Representation): Renamed as
+ Has_Compatible_Representation because now the order of the arguments
+ are taken into account; its formals are also renamed as Target_Type
+ and Operand_Type.
+ * sem_ch13.adb (Same_Representation): Renamed and moved to place the
+ routine in alphabetic order.
+ * sem_attr.adb (Prefix_With_Safe_Accessibility_Level): New subprogram.
+ (Resolve_Attribute): Check that the prefix of attribute Access
+ does not have a value conversion of an array type.
+ * sem_res.adb (Resolve_Actuals): Remove restrictive check on view
+ conversions which required matching value of Has_Aliased_Components of
+ formals and actuals.
+ * exp_ch4.adb (Handle_Changed_Representation): Update call to
+ Same_Representation.
+ (Expand_N_Type_Conversion): Update call to Same_Representation.
+ * exp_ch5.adb (Change_Of_Representation): Update call to
+ Same_Representation.
+ * exp_ch6.adb (Add_Call_By_Copy_Code): Update call to
+ Same_Representation.
+ (Expand_Actuals): Update call to Same_Representation.
+ (Expand_Call_Helper): Update call to Same_Representation.
+
+2020-07-23 Arnaud Charlet <charlet@adacore.com>
+
+ * output.ads (Push_Output, Pop_Output): New procedures.
+ * output.adb (FD_Array, FD_Stack, FD_Stack_Idx): New type and vars.
+ (Push_Output, Pop_Output): New procedures.
+
+2020-07-16 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch3.adb (Expand_N_Full_Type_Declaration): Ensure a _master
+ declaration on limited types that might have tasks.
+ * exp_ch9.adb (Build_Master_Renaming): For private types, if we
+ are processing declarations in the private part, ensure that
+ master is inserted before its full declaration; otherwise the
+ master renaming may be inserted in the public part of the
+ package (and hence before the declaration of its _master
+ variable).
+
+2020-07-16 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch8.adb (Analyze_Subprogram_Renaming): A renames-as-body
+ freezes the expression of any expression function that it
+ renames.
+
+2020-07-16 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Container_Aggregate): Add semantic
+ checks for indexed aggregates, including component associations
+ and iterated component associations.
+ * exp_aggr.adb (Expand_Iterated_Component): New subprogram,
+ subsidiary of Expand_Container_Aggreggate, used for positional,
+ named, and indexed aggregates.
+ (Aggregate_Size): New subprogram to precompute the size of an
+ indexed aggregate prior to call to allocate it.
+ (Expand_Range_Component): New subprogram so generate loop for a
+ component association given by a range or a subtype name in an
+ indexed aggregate.
+
+2020-07-16 Bob Duff <duff@adacore.com>
+
+ * bindo-diagnostics.adb (Output_Invocation_Related_Suggestions):
+ Use Cumulative_Restrictions.Set, because Restriction_Active only
+ works at compile time.
+
+2020-07-16 Bob Duff <duff@adacore.com>
+
+ * gnatbind.adb (Gnatbind): For No_Tasks_Unassigned_To_CPU, check
+ that CPU has been set on the main subprogram.
+ (Restriction_Could_Be_Set): Don't print
+ No_Tasks_Unassigned_To_CPU if it would violate the
+ above-mentioned rule. Up to now, all restrictions were checked
+ by the compiler, with the binder just checking for consistency.
+ But the compiler can't know which subprogram is the main, so
+ it's impossible to check this one at compile time.
+ * restrict.ads, restrict.adb: Misc refactoring. Change Warning
+ to Warn, for consistency, since most already use Warn.
+ (Set_Restriction): New convenience routine.
+ * sem_ch13.adb (Attribute_CPU): Check
+ No_Tasks_Unassigned_To_CPU.
+ * sem_prag.adb (Pragma_CPU): Check No_Tasks_Unassigned_To_CPU.
+ Misc refactoring.
+ * tbuild.ads, tbuild.adb (Sel_Comp): New functions for building
+ selected components.
+
+2020-07-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * impunit.adb (Non_Imp_File_Names_95): Remove duplicate entry.
+
+2020-07-16 Arnaud Charlet <charlet@adacore.com>
+
+ * Makefile.rtl: replace a-numaux__x86.ads by
+ a-numaux__libc-x86.ads and a-numaux__x86.adb by
+ a-numaux__dummy.adb.
+ * libgnat/a-numaux__x86.ads, libgnat/a-numaux__x86.adb: Removed.
+ * libgnat/a-numaux__dummy.adb: New.
+
+2020-07-16 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Load_Parent_Of_Generic): If an ancestor is an
+ instance whose source appears within a formal package of the
+ current unit, there is no body of the ancestor needed to
+ complete the current generic compilation.
+
+2020-07-16 Doug Rupp <rupp@adacore.com>
+
+ * libgnat/s-thread__ae653.adb (taskVarAdd): Defunct, so remove.
+ (Current_ATSD): Make it a TLS variable.
+ (OK): Move to package scope.
+ (System.Storage_Elements): Import and Use.
+
+2020-07-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch9.adb (Expand_N_Accept_Statement): Set Parent of the
+ created block entity to the created block statement.
+
+2020-07-16 Arnaud Charlet <charlet@adacore.com>
+
+ * scng.adb (Scan): Detect wide characters not in NFKC.
+ * libgnat/a-chahan.adb, libgnat/a-chahan.ads,
+ libgnat/a-wichha.adb, libgnat/a-wichha.ads,
+ libgnat/a-wichun.adb, libgnat/a-wichun.ads,
+ libgnat/a-zchhan.adb, libgnat/a-zchhan.ads,
+ libgnat/a-zchuni.adb, libgnat/a-zchuni.ads (Is_NFKC): New.
+ * libgnat/s-utf_32.ads, libgnat/s-utf_32.adb (Is_UTF_32_NFKC):
+ New.
+
+2020-07-16 Bob Duff <duff@adacore.com>
+
+ * libgnat/s-rident.ads (Restriction_Id): Add
+ No_Tasks_Unassigned_To_CPU.
+
+2020-07-16 Bob Duff <duff@adacore.com>
+
+ * exp_aggr.adb (Max_Aggregate_Size): Use the small size of 64
+ when copying is needed (for example, for the initialization of a
+ local variable, and for assignment statements). Use the larger
+ size when static allocation can be done without copying.
+
+2020-07-16 Bob Duff <duff@adacore.com>
+
+ * libgnat/s-rident.ads (No_Dynamic_CPU_Assignment): New
+ restriction. Add it to all relevant profiles.
+ * sem_ch13.adb (Attribute_CPU): Check No_Dynamic_CPU_Assignment
+ restriction.
+ (Attribute_CPU, Attribute_Dispatching_Domain,
+ Attribute_Interrupt_Priority): Remove error checks -- these are
+ checked in the parser.
+ * sem_prag.adb (Pragma_CPU): Check No_Dynamic_CPU_Assignment
+ restriction. We've got a little violation of DRY here.
+ * sem.ads, sem_ch3.ads: Minor comment fix.
+
+2020-07-16 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch4.adb (Try_Container_Indexing): When the prefix type is
+ an access type, change it to the designated type, change the
+ prefix to an explicit dereference, and emit a ?d? warning for
+ the implicit dereference. Include a ??? comment questioning
+ whether this is the right context in which to perform the
+ implicit dereferencing.
+
+2020-07-16 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch13.adb (Validate_Literal_Aspect): Ensure that the
+ parameter is not aliased. Minor reformatting.
+ * sem_util.adb (Statically_Names_Object): Update comment.
+
+2020-07-16 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_case.adb (Build_Choice): Set Is_Static_Expression flag.
+ (Lit_Of): Update specification to mention Is_Static_Expression
+ flag.
+ * sem_ch13.adb (Membership_Entry): Check for N_Others_Choice.
+
+2020-07-16 Bob Duff <duff@adacore.com>
+
+ * sem_ch6.adb (Null_Exclusions_Match): New function to check
+ that the null exclusions match, including in the case addressed
+ by this AI.
+ (Check_Conformance): Remove calls to Comes_From_Source
+ when calling Null_Exclusions_Match. These are not
+ needed, as indicated by an ancient "???" comment.
+
+2020-07-16 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Type_Conversion): Remove flawed test for
+ whether "statically deeper" accessibility rules apply to a given
+ target type and instead use the new routine
+ Statically_Deeper_Relation_Applies.
+ (Statically_Deeper_Relation_Applies): Created to centralize the
+ calculation of whether a target type within a conversion must
+ have static accessibility checks.
+ * sem_ch13.adb (Check_One_Function): Minor comment revision.
+
+2020-07-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * fe.h (Is_OK_Static_Expression): Delete.
+ * sem_eval.ads (Is_OK_Static_Expression): Remove WARNING note.
+
+2020-07-16 Justin Squirek <squirek@adacore.com>
+
+ * einfo.adb, einfo.ads (Is_Named_Access_Type): Created for
+ readability.
+ * sem_ch6.adb (Check_Return_Construct_Accessibility): Add
+ special cases for formals.
+ * sem_util.adb (Object_Access_Level): Add handling of access
+ attributes and named access types in the general case.
+
+2020-07-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_case.adb (Build_Choice): Simplify.
+
+2020-07-16 Arnaud Charlet <charlet@adacore.com>
+
+ * frontend.adb: Disable Initialize_Scalars on runtime files.
+
+2020-07-16 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): Add
+ Comes_From_Source call.
+
+2020-07-16 Javier Miranda <miranda@adacore.com>
+
+ * exp_attr.adb (Expand_Access_To_Protected_Op): Initialize
+ variable Sub to Empty to avoid false positive reported by
+ Codepeer.
+
+2020-07-16 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch8.adb (Note_Redundant_Use): Add missing warning tag.
+ Do not check for redundant use clauses in predefined units to avoid
+ misleading warnings that may occur as part of a rtsfind load.
+
+2020-07-16 Javier Miranda <miranda@adacore.com>
+
+ * exp_attr.adb (Has_By_Protected_Procedure_Prefixed_View): New
+ subprogram.
+ (Expand_Access_To_Protected_Op): Adding support for prefixed
+ class-wide view with By_Protected_Procedure convention.
+ * sem_attr.adb (Get_Convention): New subprogram.
+ (Get_Kind): Adapted to use Get_Convention.
+ * sem_ch4.adb (Try_By_Protected_Procedure_Prefixed_View): New
+ subprogram.
+ (Analyze_Selected_Component): Invoke
+ Try_By_Protected_Procedure_Prefixed_View.
+ * sem_util.ads (Is_By_Protected_Procedure): New subprogram.
+ * sem_util.adb (Is_By_Protected_Procedure): New subprogram.
+
+2020-07-16 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-ststop.ads: Fix typo.
+ * libgnat/s-ststop.adb (Read, Write): Fix block number
+ computation to avoid overflows in case of large strings.
+
+2020-07-16 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-genbig.adb ("**"): Remove capacity limit check.
+ Improve code by using an extended return.
+ (Normalize): Perform capacity limit check here instead which is
+ the centralized place where (potentially large) big integers are
+ allocated.
+
+2020-07-16 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Type_Conversion): Handle the case of
+ applying an invariant check for a conversion to a class-wide
+ type whose root type has a type invariant, when the conversion
+ appears within the immediate scope of the type and the
+ expression is of a specific tagged type.
+ * sem_ch3.adb (Is_Private_Primitive): New function to determine
+ whether a primitive subprogram is a private operation.
+ (Check_Abstract_Overriding): Enforce the restriction imposed by
+ AI12-0042 of requiring overriding of an inherited nonabstract
+ private operation when the ancestor has a class-wide type
+ invariant and the ancestor's private operation is visible.
+ (Derive_Subprogram): Set Requires_Overriding on a subprogram
+ inherited from a visible private operation of an ancestor to
+ which a Type_Invariant'Class expression applies.
+
+2020-07-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Find_Overlaid_Entity): Fix style in comment.
+ (Note_Possible_Modification): Simplify repeated calls to Ekind.
+
+2020-07-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_aggr.adb (Flatten): Adjust description.
+ (Convert_To_Positional): Remove obsolete ??? comment and use
+ Compile_Time_Known_Value in the final test.
+
+2020-07-15 Arnaud Charlet <charlet@adacore.com>
+
+ * par-ch4.adb (P_Iterated_Component_Association): Extended to
+ recognzize the similar Iterated_Element_Association. This node
+ is only generated when an explicit Key_Expression is given.
+ Otherwise the distinction between the two iterated forms is done
+ during semantic analysis.
+ * sinfo.ads: New node N_Iterated_Element_Association, for
+ Ada202x container aggregates. New field Key_Expression.
+ * sinfo.adb: Subprograms for new node and newn field.
+ * sem_aggr.adb (Resolve_Iterated_Component_Association): Handle
+ the case where the Iteration_Scheme is an
+ Iterator_Specification.
+ * exp_aggr.adb (Wxpand_Iterated_Component): Handle a component
+ with an Iterated_Component_Association, generate proper loop
+ using given Iterator_Specification.
+ * exp_util.adb (Insert_Axtions): Handle new node as other
+ aggregate components.
+ * sem.adb, sprint.adb: Handle new node.
+ * tbuild.adb (Make_Implicit_Loop_Statement): Handle properly a
+ loop with an Iterator_ specification.
+
+2020-07-15 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-stposu.adb (Allocate_Any_Controlled): Fix logic in
+ lock/unlock.
+
+2020-07-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Is_Object_Reference): Return True on
+ N_Target_Name.
+
+2020-07-15 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch13.adb (Check_Aspect_At_End_Of_Declarations): Add proper
+ handling of Aspect_Predicate_Failure, consistent with
+ Check_Aspect_At_Freeze_Point.
+
+2020-07-15 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch13.adb (Check_Aspect_Too_Late): Mention -gnat2020 switch
+ in error message.
+
+2020-07-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (Delayed Freezing and Elaboration): Adjust description.
+ * freeze.adb (Freeze_Object_Declaration): Likewise.
+ * sem_ch3.adb (Delayed_Aspect_Present): Likewise. Do not return
+ true for Alignment.
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Do not always delay
+ for Alignment. Moreover, for Alignment and various Size aspects,
+ do not delay if the expression is an attribute whose prefix is the
+ Standard package.
+
+2020-07-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch6.adb (Requires_Atomic_Or_Volatile_Copy): Return false
+ inside an initialization procedure.
+
+2020-07-15 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_util.adb (Is_Renaming): Add ekind checks.
+
+2020-07-15 Arnaud Charlet <charlet@adacore.com>
+
+ * doc/gnat_ugn/gnat_utility_programs.rst: Remove doc on obsolete
+ tools.
+ * gnat_ugn.texi: Regenerate.
+
+2020-07-15 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_res.adb (Resolve_Type_Conversion): Protect against null
+ entity. Add proper tag for -gnatwr warning.
+
+2020-07-15 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch6.adb (Analyze_Procedure_Call): Detect use of operators
+ in a procedure call.
+ * sem_util.adb: Minor edit.
+
+2020-07-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_Delta_Or_Update): Apply scalar
+ range checks against the base type of an index type, not against
+ the index type itself.
+
+2020-07-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (Delayed Freezing and Elaboration): Minor tweaks.
+ Document the discrepancy between the aspect and the non-aspect
+ cases for alignment settings in object declarations.
+
+2020-07-15 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch3.adb (Freeze_Type): Remove warning in expander,
+ replaced by a corresponding error in sem_ch13.adb. Replace
+ RTE_Available by RTU_Loaded to avoid adding unnecessary
+ dependencies.
+ * sem_ch13.adb (Associate_Storage_Pool): New procedure.
+ (Analyze_Attribute_Definition_Clause
+ [Attribute_Simple_Storage_Pool| Attribute_Storage_Pool]): Call
+ Associate_Storage_Pool to add proper legality checks on
+ subpools.
+
+2020-07-15 Yannick Moy <moy@adacore.com>
+
+ * libgnat/a-cbdlli.adb, libgnat/a-cbdlli.ads,
+ libgnat/a-cbhama.adb, libgnat/a-cbhama.ads,
+ libgnat/a-cbhase.adb, libgnat/a-cbhase.ads,
+ libgnat/a-cbmutr.adb, libgnat/a-cbmutr.ads,
+ libgnat/a-cborma.adb, libgnat/a-cborma.ads,
+ libgnat/a-cborse.adb, libgnat/a-cborse.ads,
+ libgnat/a-cbprqu.adb, libgnat/a-cbprqu.ads,
+ libgnat/a-cbsyqu.adb, libgnat/a-cbsyqu.ads,
+ libgnat/a-cdlili.adb, libgnat/a-cdlili.ads,
+ libgnat/a-cidlli.adb, libgnat/a-cidlli.ads,
+ libgnat/a-cihama.adb, libgnat/a-cihama.ads,
+ libgnat/a-cihase.adb, libgnat/a-cihase.ads,
+ libgnat/a-cimutr.adb, libgnat/a-cimutr.ads,
+ libgnat/a-ciorma.adb, libgnat/a-ciorma.ads,
+ libgnat/a-ciormu.adb, libgnat/a-ciormu.ads,
+ libgnat/a-ciorse.adb, libgnat/a-ciorse.ads,
+ libgnat/a-cohama.adb, libgnat/a-cohama.ads,
+ libgnat/a-cohase.adb, libgnat/a-cohase.ads,
+ libgnat/a-coinve.adb, libgnat/a-coinve.ads,
+ libgnat/a-comutr.adb, libgnat/a-comutr.ads,
+ libgnat/a-convec.adb, libgnat/a-convec.ads,
+ libgnat/a-coorma.adb, libgnat/a-coorma.ads,
+ libgnat/a-coormu.adb, libgnat/a-coormu.ads,
+ libgnat/a-coorse.adb, libgnat/a-coorse.ads: Add SPARK_Mode =>
+ Off.
+
+2020-07-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch3.adb (Delayed_Aspect_Present): Fix oversight in loop.
+ * freeze.adb (Freeze_Object_Declaration): Use Declaration_Node
+ instead of Parent for the sake of consistency.
+
+2020-07-15 Javier Miranda <miranda@adacore.com>
+
+ * sem_attr.adb (Resolve_Attribute): Resolve overloaded
+ N_Selected_Component prefix of 'Access. Required to handle
+ overloaded prefixed view of protected subprograms.
+
+2020-07-15 Arnaud Charlet <charlet@adacore.com>
+
+ * doc/gnat_ugn/about_this_guide.rst: Remove old section and
+ update for Ada 202x.
+ * doc/gnat_ugn/getting_started_with_gnat.rst: Add a system
+ requirements section. Remove obsolete section and minimal
+ rewording on the getting started section.
+ * gnat_ugn.texi: Regenerate.
+
+2020-07-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch5.adb (Expand_Assign_Array): Use short-circuit operator
+ (style).
+ * sem_res.adb (Resolve_Indexed_Component): Fix style in comment.
+ * sem_util.adb (Is_Effectively_Volatile_Object): Handle slices
+ just like indexed components; handle qualified expressions and
+ type conversions lie in Is_OK_Volatile_Context.
+ (Is_OK_Volatile_Context): Handle qualified expressions just like
+ type conversions.
+
+2020-07-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Atomic_Components): Simplify with Ekind_In.
+ (Complex_Representation): Fix type of E_Id, which just like when
+ for pragma Atomic_Components will hold an N_Identifier node, not
+ an entity.
+ * sem_util.adb (Is_Effectively_Volatile): Refactor to avoid
+ unnecessary computation.
+
+2020-07-15 Arnaud Charlet <charlet@adacore.com>
+
+ * inline.adb, inline.ads
+ (Inline_Static_Expression_Function_Call): Renamed
+ Inline_Static_Function_Call.
+ * sem_ch13.adb (Analyze_Aspect_Static): Allow static intrinsic
+ imported functions under -gnatX.
+ * sem_util.ads, sem_util.adb (Is_Static_Expression_Function):
+ Renamed Is_Static_Function.
+ (Is_Static_Expression_Function_Call): Renamed
+ Is_Static_Function_Call.
+ * sem_ch6.adb, sem_elab.adb, sem_res.adb: Update calls to
+ Is_Static_Function*.
+ * sem_eval.adb (Fold_Dummy, Eval_Intrinsic_Call, Fold_Shift):
+ New.
+ (Eval_Call): Add support for intrinsic calls, code refactoring.
+ (Eval_Entity_Name): Code refactoring.
+ (Eval_Logical_Op): Update comment.
+ (Eval_Shift): Call Fold_Shift. Update comments.
+ * par-prag.adb (Par [Pragma_Extensions_Allowed]): Set
+ Ada_Version to Ada_Version_Type'Last to handle
+ Extensions_Allowed (On) consistently.
+ * opt.ads (Extensions_Allowed): Update documentation.
+ * sem_attr.adb: Update comment.
+ * doc/gnat_rm/implementation_defined_pragmas.rst: Update
+ documentation of Extensions_Allowed.
+ * gnat_rm.texi: Regenerate.
+
+2020-07-15 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_aggr.adb (Resolve_Iterated_Component_Association): Ensure
+ Typ is never accessed uninitialized.
+
+2020-07-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * doc/gnat_rm/representation_clauses_and_pragmas.rst: Fix typo.
+ * gnat_rm.texi: Regenerate.
+ * libgnat/s-secsta.ads (Memory_Alignment): Likewise.
+
+2020-07-15 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch6.adb: Add a comma and fix a typo (machinary =>
+ machinery) in comment.
+ * exp_aggr.adb: Reformat, fix capitalization, and add a couple
+ of commas in a comment. Adjust columns in several code
+ fragments.
+ * sem_aggr.adb: Reformat and add a comma in a comment.
+
+2020-07-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch9.adb (Expand_N_Timed_Entry_Call): Use the Sloc of
+ the delay statement in the expansion.
+
+2020-07-15 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Iterated_Component_Association): New
+ procedure, internal to Resolve_Container_Aggregate, to complete
+ semantic analysis of Iterated_Component_Associations.
+ * exp_aggr.adb (Expand_Iterated_Component): New procedure,
+ internal to Expand_Container_Aggregate, to expand the construct
+ into an implicit loop that performs individual insertions into
+ the target aggregate.
+
+2020-07-15 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch6.adb (Make_Build_In_Place_Call_Allocator): Normalize
+ the associated node for internally generated objects to be like
+ their SOAAT counter-parts.
+
+2020-07-15 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/g-socket.adb (Wait_On_Socket): Fix potentially
+ uninitialized variable.
+
+2020-07-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch8.adb (Find_Direct_Name): Fix code to match the comment.
+
+2020-07-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause) <Address>:
+ Issue an unconditional warning for an overlay that changes the
+ scalar storage order.
+
+2020-07-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch8.adb (Is_Actual_Parameter): Fix processing when parent
+ is a procedure call statement; extend comment.
+
+2020-07-10 Bob Duff <duff@adacore.com>
+
+ * sem_res.adb (Resolve_Expression_With_Actions): Check the rules
+ of AI12-0368, and mark the declare expression as static or known
+ at compile time as appropriate.
+ * sem_ch4.adb: Minor reformatting.
+ * libgnat/a-stoufo.ads, libgnat/a-stoufo.adb: Allow up to 9
+ replacement parameters. I'm planning to use this in the test
+ case for this ticket.
+
+2020-07-10 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch3.adb (Build_Access_Subprogram_Wrapper_Body): Create a
+ proper signature when the access type denotes a parameterless
+ subprogram.
+ * exp_ch6.adb (Expand_Call): Handle properly a parameterless
+ indirect call when the corresponding access type has contracts.
+
+2020-07-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_aggr.adb
+ (Convert_To_Positional): Add Dims local variable
+ and pass it in calls to Is_Flat and Flatten.
+ (Check_Static_Components): Pass Dims in call to
+ Is_Static_Element.
+ (Nonflattenable_Next_Aggr): New predicate.
+ (Flatten): Add Dims parameter and Expr local variable. Call
+ Nonflattenable_Next_Aggr in a couple of places. In the case
+ when an Others choice is present, check that the element is
+ either static or a nested aggregate that can be flattened,
+ before disregarding the replication limit for elaboration
+ purposes. Check that a nested array is flattenable in the case
+ of a multidimensional array in any position. Remove redundant
+ check in the Others case and pass Dims in call to
+ Is_Static_Element. Use Expr variable.
+ (Is_Flat): Change type of Dims parameter from Int to Nat.
+ (Is_Static_Element): Add Dims parameter. Replace tests on
+ literals with call to Compile_Time_Known_Value. If everything
+ else failed and the dimension is 1, preanalyze the expression
+ before calling again Compile_Time_Known_Value on it. Return
+ true for null.
+ (Late_Expansion): Do not expand further if the assignment to the
+ target can be done directly by the back end.
+
+2020-07-10 Arnaud Charlet <charlet@adacore.com>
+
+ * osint-c.adb (Set_File_Name): Preserve casing of file.
+ * osint.adb (File_Names_Equal): New.
+ (Executable_Name): Use File_Equal instead of
+ Canonical_Case_File_Name.
+
+2020-07-10 Pascal Obry <obry@adacore.com>
+
+ * libgnat/g-socket.adb (Wait_On_Socket): Fix memory leaks and
+ file descriptor leaks. A memory leak was created each time the
+ routine was called without a selector (Selector = Null). Also,
+ in case of exception in the routine a memory leak and descriptor
+ leak was created as the created file selector was not closed.
+
+2020-07-10 Pascal Obry <obry@adacore.com>
+
+ * libgnat/g-socket.adb: Minor style fixes.
+
+2020-07-10 Javier Miranda <miranda@adacore.com>
+
+ * sem_util.adb
+ (Immediate_Context_Implies_Is_Potentially_Unevaluated): New
+ subprogram.
+ (Is_Potentially_Unevaluated): Do not stop climbing the tree on
+ the first candidate subexpression; required to handle nested
+ expressions.
+
+2020-07-10 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_aggr.adb, exp_spark.adb, sem_ch13.ads, sem_ch13.adb,
+ snames.ads-tmpl: Minor reformatting and typo fixes.
+
+2020-07-10 Yannick Moy <moy@adacore.com>
+
+ * sem_util.adb (Has_Enabled_Property): Add handling of
+ non-variable objects.
+
+2020-07-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch3.adb (Check_Completion): Refactor chained
+ if-then-elsif-... statement to be more like a case
+ statement (note: we can't simply use case statement because of
+ Is_Intrinsic_Subprogram in the first condition).
+
+2020-07-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * einfo.ads (E_Protected_Object): Enumeration literal removed.
+ * lib-xref.ads (Xref_Entity_Letters): Remove reference to
+ removed literal.
+ * sem_ch3.adb (Check_Completion): Likewise.
+ * sem_util.adb (Has_Enabled_Property): Likewise.
+
+2020-07-10 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_aggr.adb (Max_Aggregate_Size): Use small limit for
+ aggregate inside subprograms.
+ * sprint.adb (Sprint_Node_Actual [N_Object_Declaration]): Do not
+ print the initialization expression if the No_Initialization
+ flag is set.
+ * sem_util.ads, sem_util.adb (Predicate_Enabled): New.
+ * exp_ch4.adb (Expand_N_Type_Conversion): Code cleanup and apply
+ predicate check consistently.
+ * exp_ch6.adb (Expand_Actuals.By_Ref_Predicate_Check): Ditto.
+ * sem_ch3.adb (Analyze_Object_Declaration): Ditto.
+ * exp_ch3.adb (Build_Assignment): Revert handling of predicate
+ check for allocators with qualified expressions, now handled in
+ Freeze_Expression directly.
+ * sem_aggr.adb: Fix typos.
+ * checks.adb: Code refactoring: use Predicate_Enabled.
+ (Apply_Predicate_Check): Code cleanup.
+ * freeze.adb (Freeze_Expression): Freeze the subtype mark before
+ a qualified expression on an allocator.
+ * exp_util.ads, exp_util.adb (Within_Internal_Subprogram):
+ Renamed Predicate_Check_In_Scope to clarify usage, refine
+ handling of predicates within init procs which should be enabled
+ when the node comes from source.
+ * sem_ch13.adb (Freeze_Entity_Checks): Update call to
+ Predicate_Check_In_Scope.
+
+2020-07-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Expand_Array_Comparison): Reformat.
+ (Expand_Concatenate): Use standard size values directly and use
+ Standard_Long_Long_Unsigned instead of RE_Long_Long_Unsigned.
+ (Expand_Modular_Op): Use Standard_Long_Long_Integer in case the
+ modulus is larger than Integer.
+ (Expand_N_Op_Expon): Use standard size value directly.
+ (Narrow_Large_Operation): Use Uint instead of Nat for sizes and
+ use a local variable for the size of the type.
+ (Get_Size_For_Range): Return Uint instead of Nat.
+ (Is_OK_For_Range): Take Uint instead of Nat.
+
+2020-07-10 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch6.adb (Make_Build_In_Place_Iface_Call_In_Allocator):
+ Build the internal anonymous access type using as a reference
+ the designated type imposed by the context (instead of using the
+ return type of the called function).
+
+2020-07-10 Yannick Moy <moy@adacore.com>
+
+ * sem_res.adb (Resolve_Actuals): Protect call to
+ Is_Valued_Procedure.
+
+2020-07-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch3.adb (Process_Discriminants): Revert recent change to
+ location of Set_Ekind; detect effectively volatile discriminants
+ by their type only.
+
+2020-07-10 Joffrey Huguet <huguet@adacore.com>
+
+ * libgnat/a-nbnbin.ads, libgnat/a-nbnbre.ads: Add global
+ contract (Global => null) to all functions.
+
+2020-07-10 Ed Schonberg <schonberg@adacore.com>
+
+ * aspects.ads: Add Aspect_Aggregate.
+ * exp_aggr.adb (Expand_Container_Aggregate): Expand positional
+ container aggregates into separate initialization and insertion
+ operations.
+ * sem_aggr.ads (Resolve_Container_Aggregate): New subprogram.
+ * sem_aggr.adb (Resolve_Container_Aggregate): Parse aspect
+ aggregate, establish element types and key types if present, and
+ resolve aggregate components.
+ * sem_ch13.ads (Parse_Aspect_Aggregate): Public subprogram used
+ in validation, resolution and expansion of container aggregates
+ * sem_ch13.adb
+ (Parse_Aspect_Aggregate): Retrieve names of primitives specified
+ in aspect specification.
+ (Validate_Aspect_Aggregate): Check legality of specified
+ operations given in aspect specification, before nane
+ resolution.
+ (Resolve_Aspect_Aggregate): At freeze point resolve operations
+ and verify that given operations have the required profile.
+ * sem_res.adb (Resolve): Call Resolve_Aspect_Aggregate if aspect
+ is present for type.
+ * snames.ads-tmpl: Add names used in aspect Aggregate: Empty,
+ Add_Named, Add_Unnamed, New_Indexed, Assign_Indexed.
+
+2020-07-10 Arnaud Charlet <charlet@adacore.com>
+
+ * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add s-shabig.o.
+ * libgnat/s-shabig.ads: New file to share definitions.
+ * libgnat/s-genbig.ads, libgnat/s-genbig.adb: Reorganized to
+ make it more generic and flexible in terms of memory allocation
+ and data structure returned.
+ (To_String): Moved to System.Generic_Bignums to allow sharing
+ this code.
+ (Big_And, Big_Or, Big_Shift_Left, Big_Shift_Right): New.
+ * libgnat/s-bignum.adb, libgnat/s-bignum.ads: Adapt to new
+ System.Generic_Bignums spec.
+ * libgnat/a-nbnbin.adb: Likewise.
+ (To_String): Moved to System.Generic_Bignums to allow sharing
+ this code.
+ * libgnat/a-nbnbre.adb (Normalize): Fix handling of Num = 0
+ leading to an exception.
+
+2020-07-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * freeze.adb (Freeze_Expr_Types): Replace call to Find_Aspect
+ with call to Find_Value_Of_Aspect and adjust accordingly.
+
+2020-07-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.adb (Write_Field24_Name): Handle E_Loop_Parameter.
+ * freeze.adb (Freeze_Expr_Types): Freeze the iterator type used as
+ Default_Iterator of the name of an N_Iterator_Specification node.
+
+2020-07-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * checks.adb (Determine_Range): Deal with Min and Max attributes.
+ * exp_ch6.adb (Expand_Call_Helper): When generating code to pass
+ the accessibility level to the caller in the case of an actual
+ which is an if-expression, also remove the nodes created after
+ the declaration of the dummy temporary.
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Use Natural as
+ the type of the minimum accessibility level object.
+
+2020-07-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch3.adb (Process_Discriminants): Set Ekind of the
+ processed discriminant entity before passing to
+ Is_Effectively_Volatile, which was crashing on a failed
+ assertion.
+ * sem_prag.adb (Analyze_External_Property_In_Decl_Part): Prevent
+ call to No_Caching_Enabled with entities other than variables,
+ which was crashing on a failed assertion.
+ (Analyze_Pragma): Style cleanups.
+ * sem_util.adb (Is_Effectively_Volatile): Enforce comment with
+ an assertion; prevent call to No_Caching_Enabled with entities
+ other than variables.
+ (Is_Effectively_Volatile_Object): Only call
+ Is_Effectively_Volatile on objects, not on types.
+ (No_Caching_Enabled): Enforce comment with an assertion.
+
+2020-07-10 Yannick Moy <moy@adacore.com>
+
+ * debug.adb: Update comments to free usage of -gnatdF.
+
+2020-07-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_Delta_Or_Update): Refactored from
+ Expand_SPARK_N_Attribute_Reference; rewrite into N_Aggregate or
+ N_Delta_Aggregate depending on what is being rewritten.
+ (Expand_SPARK_N_Delta_Aggregate): New routine to expand
+ delta_aggregate.
+ (Expand_SPARK_N_Attribute_Reference): Call the refactored
+ routine.
+
+2020-07-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_N_Attribute_Reference): Fix
+ expansion of attribute Update.
+
+2020-07-10 Arnaud Charlet <charlet@adacore.com>
+
+ * sem.adb (Walk_Library_Items): Fix handling of Ghost units.
+
+2020-07-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * tracebak.c [generic implementation]: Add pragma GCC diagnostic
+ to disable warning about __builtin_frame_address.
+
+2020-07-08 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * socket.c [_WIN32] (__gnat_minus_500ms): Parentheses around &&
+ operations. Remove notes about TN in comment.
+
+2020-07-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * adaint.h (__gnat_expect_portable_execvp): Fix prototype.
+ (__gnat_expect_poll): Likewise.
+ * expect.c [_WIN32]: Include adaint.h file.
+ (__gnat_waitpid): Remove useless variable.
+ (__gnat_expect_portable_execvp): Add ATTRIBUTE_UNUSED on parameter.
+ * raise-gcc.c [SEH] (__gnat_personality_v0): Add ATTRIBUTE_UNUSED.
+ * socket.c [_WIN32] (__gnat_getservbyport): Add ATTRIBUTE_UNUSED on
+ a couple of parameters.
+ (__gnat_gethostbyname): Likewise.
+ (__gnat_gethostbyaddr): Likewise.
+ (__gnat_getservbyname): Likewise.
+ (__gnat_last_socket_in_set): Use variables local to loops.
+ (__gnat_socket_ioctl): Cast 3rd parameter to proper type if _WIN32.
+ (__gnat_inet_pton): Cast 2nd parameter to proper type if _WIN32.
+ * sysdep.c (__gnat_localtime_tzoff): Remove superfluous test.
+ * terminals.c [_WIN32]: Include io.h file.
+ (is_gui_app): Remove useless variables and fix unsigned comparison.
+ (nt_spawnve): Add ATTRIBUTE_UNUSED on first parameter. Initialize a
+ local variable and remove others that are useless. Add missing cast
+ (__gnat_setup_child_communication): Remove useless variable and call
+ Use proper formatting string in call to sprintf.
+ (__gnat_setup_parent_communication): Cast to proper type.
+ (find_child_console): Fix prototype and remove useless variable.
+ (find_process_handle): Likewise.
+ (_gnat_interrupt_process): Move to after __gnat_interrupt_pid.
+ (__gnat_reset_tty): Add ATTRIBUTE_UNUSED on parameter, remove return
+ (__gnat_setup_winsize): Add ATTRIBUTE_UNUSED on all parameters.
+
+2020-07-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Allocator): In the subtype mark case, do
+ not apply constraint checks if the No_Initialization flag is set.
+
+2020-07-08 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch9.adb
+ (Build_Class_Wide_Master): Insert the declaration of _Master
+ before its use; required to avoid assertion failure in the
+ backend.
+
+2020-07-08 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/i-cexten.ads (long_long, unsigned_long_long): Now
+ subtypes of Interfaces.C types.
+ * libgnat/a-calcon.ads, libgnat/a-calcon.adb
+ (To_Unix_Nano_Time): Use Interfaces.C.long_long instead of
+ Interfaces.C.Extensions.long_long.
+
+2020-07-08 Vasiliy Fofanov <fofanov@adacore.com>
+
+ * debug.adb: Document new switch.
+ * exp_ch6.adb (Warn_BIP): New function that warns if the switch
+ is on. Call it from Make_Build_In_Place_* functions. Warn_BIP
+ is not needed in Make_Build_In_Place_Iface_*, because those call
+ Make_Build_In_Place_Call_In_Object_Declaration or similar.
+
+2020-07-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * erroutc.adb (Matches): Fix comments.
+
+2020-07-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * freeze.adb (Has_Decl_In_List): New predicate to check that an
+ entity is declared in a list of nodes.
+ (Freeze_Expression): Use it to deal with Expression_With_Actions,
+ short-circuit expression, if- and case-expression and ensure that
+ the freeze node is put onto their Actions list if the entity is
+ declared locally.
+
+2020-07-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * freeze.adb (In_Expanded_Body): Return true for the body of a
+ generated predicate function.
+
+2020-07-08 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_attr.adb: Remove hyphens in comments, plus minor code
+ reformatting.
+ * sem_ch13.adb: Fix typo (that => than).
+ * sem_util.adb: Add hyphen in comment ("class-wide").
+
+2020-07-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * freeze.adb (Freeze_Array_Type): Add comment on implementation
+ choice for byte-packed array types.
+
+2020-07-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Correct prefix of 'Result
+ this prefix is a generic function but the enclosing aspect or
+ pragma is attached to its instance.
+ * sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): Analyze
+ generic subprogram formal parameters (including the implicit
+ result of a generic function) and only then analyse its aspects,
+ because with Relaxed_Initialization the aspect expression might
+ refer to those formal parameters.
+ * sem_ch13.adb (Analyze_Aspect_Relaxed_Initialization): Accept
+ aspect on generic subprograms; install formal parameters of a
+ generic subprogram but not formal parameters of the generic unit
+ itself (the previous code was inspired by aspects Post and
+ Depends, where both kinds of formals are allowed).
+ * sem_util.ads (Enter_Name): Fix name of a subprogram referenced
+ in comment.
+
+2020-07-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): Call
+ Analyze_Aspect_Specifications after setting Ekind of the
+ analyzed entity.
+ * sem_ch13.adb (Analyze_Aspect_Yield): Remove minimal decoration
+ of generic subprograms.
+
+2020-07-08 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_prag.adb (Process_Inline): Check for duplicate
+ pragma+aspect Inline. Minor code cleanup.
+ (Check_Duplicate_Pragma): Add warning for duplicate
+ pragma [No_]Inline under -gnatwr.
+ * sinfo.ads, sinfo.adb (Next_Rep_Item): Allow N_Null_Statement
+ which can appear when a pragma is rewritten.
+ * sem_util.ads, sem_util.adb, bindo-writers.adb: Fix bad
+ copy/paste now flagged.
+ * libgnat/s-mmap.ads: Remove redundant pragma Inline.
+
+2020-07-08 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (Build_Class_Wide_Clone_Body): Update entities to
+ refer to the right spec.
+
+2020-07-08 Bob Duff <duff@adacore.com>
+
+ * sem_ch13.adb (Predicate_Failure): Check that the type has
+ predicates. Remove the setting of Has_Delayed_Aspects and
+ Freeze_Node, because (if the code is legal) it should have
+ already been done by the predicate aspect.
+
+2020-07-08 Gary Dismukes <dismukes@adacore.com>
+
+ * par-ch4.adb (P_Iterated_Component_Association): Typo
+ corrections.
+
+2020-07-08 Ed Schonberg <schonberg@adacore.com>
+
+ * par.adb (P_Iterator_Specification): Make public for use in
+ other parser subprograms.
+ * par-ch4.adb (P_Iterated_Component_Association): In Ada_2020,
+ recognize use of Iterator_Specification in an element iterator.
+ To simplify disambiguation between the two iterator forms, mark
+ the component association as carrying an Iterator_Specification
+ only when the element iterator (using "OF") is used.
+ * par-ch5.adb (P_Loop_Parameter_Specification): In Ada_2020,
+ parse iterator filter when present.
+ (P_Iterator_Specification): Ditto. Remove declaration of
+ P_Iterator_Specification, now in parent unit.
+ * exp_ch5.adb (Expand_N_Loop_Statement): Apply Iterator filter
+ when present.
+ (Expand_Iterator_Loop_Over_Array): Ditto.
+ (Expand_Iterator_Loop_Over_Container): Ditto.
+ * sem_aggr.adb (Resolve_Array_Aggregate): Emit error nessage if
+ an iterated component association includes a iterator
+ specificcation with an element iterator, i.e. one that uses the
+ OF keyword.
+ * sem_ch5.adb (Analyze_Iterator_Specification): Analyze Iterator
+ filter when present.
+ (Analyze_Loop_Parameter_Specification): Ditto.
+ * sinfo.adb: Suprogram bodies for new syntactic element
+ Iterator_Filter.
+ * sinfo.ads: Add Iterator_Filter to relevant nodes. Structure
+ of Component_Association and Iteroted_Component_Association
+ nodes is modified to take into account the possible presence of
+ an iterator specification in the latter.
+
+2020-07-08 Yannick Moy <moy@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Is_Attribute_Loop_Entry): New
+ function for GNATProve.
+
+2020-07-08 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_ch13.adb (Analyze_Record_Representation_Clause,
+ Check_Record_Representation_Clause): Add expected and actual
+ size to error message.
+
+2020-07-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Safe_To_Capture_Value): Return
+ True for in-parameters.
+
+2020-07-08 Justin Squirek <squirek@adacore.com>
+
+ * exp_attr.adb (Expand_Attribute): Set
+ Stores_Attribute_Old_Prefix to generated renamings of 'Old
+ constants for later use in generating finalization routines.
+ * exp_ch7.adb (Build_Finalizer): Minor reformatting. Use "or
+ else" operators.
+
+2020-07-08 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch6.adb (Expand_Simple_Function_Return): Remove ugly code
+ that was copying the return expression, resetting Analyzed
+ flags, etc. for the return expression of static expression
+ functions.
+ * inline.adb (Inline_Static_Expression_Function_Call): Set the
+ Parent of the copied expression to that of the call. This avoids
+ a blowup in Insert_Actions when GNATprove_Mode is set and there
+ are nested SEF calls. Add ??? comment.
+ * sem_ch6.adb (Analyze_Expression_Function): In the case of a
+ static expression function, create a new copy of the expression
+ and replace the function's expression with the copy; the
+ original expression is used in the expression function's body
+ and will be analyzed and rewritten, and we need to save a clean
+ copy for later use in processing static calls to the function.
+ This allows removing the kludgy code that was in
+ Expand_Simple_Function_Return.
+ * sem_eval.adb (Eval_Qualified_Expression): Return immediately
+ if any errors have been posted on the qualified expression, to
+ avoid blowups when GNATprove_Mode is enabled (or with -gnatd.F),
+ since illegal static expressions are handled differently in that
+ case and attempting to fold such expressions would fail.
+
+2020-07-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * repinfo.adb (Compute_Max_Length): Skip hidden discriminants.
+ (List_Record_Layout): Likewise.
+ (List_Structural_Record_Layout): Use First_Discriminant instead
+ of First_Stored_Discriminant and Next_Discriminant instead of
+ Next_Stored_Discriminant to walk the list of discriminants.
+
+2020-07-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Relaxed_Initialization): Analyze
+ optional boolean expressions.
+ * sem_util.ads, sem_util.adb (Has_Relaxed_Initialization): Adapt
+ query; update comment.
+
+2020-07-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * einfo.ads (Current_Value): Fix typo in comment.
+ * exp_ch2.adb (Expand_Current_Value): Remove unnecessary "Start
+ of processing ..." comment.
+ * exp_util.adb (Set_Entity_Current_Value): Fix unbalanced paren
+ in comment.
+ (Get_Current_Value_Condition): Fix layout in comment.
+ * sem_ch5.adb (Analyze_Cond_Then): Replace commented condition
+ with pragma Assert.
+
+2020-07-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch5.adb (Expand_N_If_Statement): Detect True/False
+ prefixed with Standard.
+
+2020-07-08 Bob Duff <duff@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Add freeze node
+ for the Underlying_Full_View if it exists. The freeze node is
+ what triggers the generation of the predicate function.
+ * freeze.adb: Minor reformatting.
+
+2020-07-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Narrow_Large_Operation): Use the base type instead
+ of the first subtype of standard integer types as narrower type.
+
+2020-07-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * freeze.adb (Freeze_Array_Type): Use Ctyp more consistently.
+ Move code setting the alignment in the non-packed case to...
+ * layout.adb (Layout_Type): ...here.
+
+2020-07-07 Bob Duff <duff@adacore.com>
+
+ * treepr.adb (Print_Node): Add code to test Is_Extension.
+
+2020-07-07 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch4.adb (Try_Container_Indexing): Add ??? comment. Protect
+ against malformed tree in case of errors.
+
+2020-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * einfo.adb, sem_ch10.adb, sem_ch12.adb, sem_ch8.adb: Use
+ Is_Generic_Subprogram.
+
+2020-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch8.adb (Analyze_Use_Package): Replace low-level,
+ error-prone Ekind_In tests with high-level Is_Generic_Subprogram
+ and Is_Subprogram.
+
+2020-07-07 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch6.adb (Check_Formal_Subprogram_Conformance): New
+ subprogram to handle checking without systematically emitting an
+ error.
+ (Check_Conformance): Update call to
+ Check_Formal_Subprogram_Conformance and fix handling of Conforms
+ and Errmsg parameters.
+
+2020-07-07 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch4.adb (Tagged_Membership): Generate a call to
+ CW_Membership instead of using Build_CW_Membership.
+ (Expand_N_In): Remove wrong handling of null access types and
+ corresponding comment.
+ * exp_intr.adb (Expand_Dispatching_Constructor_Call): Generate a
+ call to CW_Membership instead of using Build_CW_Membership.
+ * rtsfind.ads: Add CW_Membership.
+ * exp_atag.ads, exp_atag.adb (Build_CW_Membership): Removed.
+ * einfo.ads: Fix typo.
+ * libgnat/a-tags.ads, libgnat/a-tags.adb (CW_Membership): Moved
+ back to spec.
+
+2020-07-07 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch3.adb (Build_Access_Subprogram_Wrapper_Body): Create
+ proper subprogram specification for body, using names in the
+ subprogram declaration but distinct entities.
+ * exp_ch6.adb (Expand_Call): If this is an indirect call
+ involving a subprogram wrapper, insert pointer parameter in list
+ of actuals with a parameter association, not as a positional
+ parameter.
+
+2020-07-07 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch6.adb (Expand_Branch): Verify the original node is a
+ conditional expression before recursing further.
+ (Insert_Level_Assign): Transform assertion into an explicit
+ raise.
+
+2020-07-07 Steve Baird <baird@adacore.com>
+
+ * sem_attr.adb (Eval_Attribute): Generalize static evaluation of
+ Size attribute references to also handle
+ Max_Size_In_Storage_Elements references.
+
+2020-07-07 Javier Miranda <miranda@adacore.com>
+
+ * sem_util.adb (Is_Potentially_Unevaluated): Code cleanup.
+
+2020-07-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * checks.ads (Expander Routines): Update the description of the
+ Do_Range_Check mechanism.
+ * checks.adb (Selected_Range_Checks): Fix typo.
+ * exp_ch9.adb: Add with and use clause for Checks.
+ (Actual_Index_Expression): Generate a range check if requested.
+ (Entry_Index_Expression): Likewise.
+ * sem_attr.adb (Resolve_Attribute) <Attribute_Count>: Call
+ Apply_Scalar_Range_Check instead of Apply_Range_Check.
+ * sem_ch9.adb (Analyze_Accept_Statement): Likewise.
+ * sem_res.adb (Resolve_Entry): Likewise, after having set the
+ actual index type on the prefix of the indexed component.
+ (Resolve_Indexed_Component): Remove useless conditional construct.
+
+2020-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * contracts.adb (Analyze_Entry_Or_Subprogram_Contract,
+ Process_Preconditions_For): Freeze expression that has been
+ relocated to pragma Precondition, not the expression which is
+ still in the aspect.
+
+2020-07-07 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch6.adb (Check_Conformance): Remove unnecessary (and
+ wrong) code.
+ * sem_ch8.adb (Check_Null_Exclusion): Post error at proper
+ location. Introduce new helper Null_Exclusion_Mismatch and fix
+ implementation wrt formal subprograms used in generic bodies.
+ (Analyze_Subprogram_Renaming): Fix missing setting of
+ Error_Msg_Sloc.
+ (Analyze_Object_Renaming): Replace "in Anonymous_Access_Kind" by
+ Is_Anonymous_Access_Type.
+ * sem_util.adb (Has_Null_Exclusion): Fix handling of
+ N_Parameter_Specification.
+ * sem_ch12.adb (Instantiate_Object): Replace "in
+ Anonymous_Access_Kind" by Is_Anonymous_Access_Type.
+
+2020-07-07 Ed Schonberg <schonberg@adacore.com>
+
+ * freeze.adb (Freeze_Expr_Types): Freeze the designated type of
+ the explicit dereference.
+
+2020-07-07 Javier Miranda <miranda@adacore.com>
+
+ * sem_util.adb (Is_Potentially_Unevaluated): Protect reading
+ attribute Etype.
+
+2020-07-07 Bob Duff <duff@adacore.com>
+
+ * libgnat/g-catiio.adb (Value, Parse_ISO_8601): Unsuppress
+ checks, and don't rely on 'Valid.
+
+2020-07-07 Arnaud Charlet <charlet@adacore.com>
+
+ * Makefile.rtl: Remove dead code.
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst:
+ Document gnatbind -xdr switch.
+ * gnat_ugn.texi: Regenerate.
+
+2020-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst
+ (Validity Checking): Add "p" to the list of switches enabled by
+ -gnatVa.
+ * gnat_ugn.texi: Regenerate.
+
+2020-07-07 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Add call
+ to Check_Restriction_No_Specification_Of_Aspect.
+ * sem_prag.adb (Analyze_Pragma): Likewise.
+ * restrict.ads (Check_Restriction_No_Specification_Of_Aspect):
+ Mention possible new node kinds in documentation.
+ * restrict.adb (Check_Restriction_No_Specification_Of_Aspect):
+ Retrieve aspect id from different fields if given node is an
+ N_Pragma or an N_Attribute_Definition_Clause.
+
+2020-07-07 Gary Dismukes <dismukes@adacore.com>
+
+ * contracts.adb (Add_Invariant_And_Predicate_Checks): Relax the
+ condition for doing invariant checks so that in-mode parameters
+ of procedures are also checked (required by AI05-0289, and
+ restricted to procedures by AI12-0044). This is done in a
+ procedure's nested postconditions procedure.
+ * exp_ch6.adb (Expand_Actuals): Also perform postcall invariant
+ checks for in parameters of procedures (but not functions).
+ Moved invariant-checking code to end of Expand_Actuals
+ (including the nested function Is_Public_Subp).
+
+2020-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aggr.adb (Resolve_Delta_Array_Aggregate): Make Index_Type
+ a constant.
+
+2020-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_aggr.adb (Expand_N_Delta_Aggregate): Use type of the delta
+ base expression for the anonymous object of the delta aggregate.
+
+2020-07-07 Javier Miranda <miranda@adacore.com>
+
+ * sem_util.ads (Interval_Lists): Reordering routine.
+ * sem_util.adb (Interval_Lists): Reordering routines to keep
+ them alphabetically ordered.
+
+2020-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Resolve_Attribute): Do not call
+ Check_Non_Static_Context.
+
+2020-07-07 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_elab.adb (Is_Guaranteed_ABE): Take into account null
+ procedures.
+
+2020-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch5.adb (Analyze_Assignment): Reuse Is_Assignable.
+
+2020-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_N_Attribute_Reference): Add scalar
+ range checks for 'Update on arrays just like for 'Update on
+ records.
+ * sem_attr.adb (Analyze_Array_Component_Update): Do not set
+ range checks for single-dimensional arrays.
+ (Resolve_Attribute): Do not set range checks for both single-
+ and multi- dimensional arrays.
+
+2020-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem.ads (Sem): Fix description.
+
+2020-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Analyze_Relaxed_Parameter): Fix for protected
+ entries.
+
+2020-07-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * checks.adb (Apply_Scalar_Range_Check): Use Is_RTE.
+
+2020-07-06 Bob Duff <duff@adacore.com>
+
+ * libgnat/g-catiio.ads: Document newly supported format. Add
+ ISO_Time constant, for convenience.
+ * libgnat/g-catiio.adb (Image_Helper): New helper function to do
+ all the formatting work, called by the two exported Image
+ functions. Add support for "%:::z" here. Add a Time_Zone
+ parameter used by the "%:::z" processing. This parameter is not
+ used for the actual time zone computations; local time is always
+ used for that, for ease of implementation reasons. It would
+ make sense to use Append throughout this function, but that's a
+ cleanup for another day.
+ (Image): Modify these to pass the local time zone, or the
+ specified time zone, as appropriate.
+
+2020-07-06 Bob Duff <duff@adacore.com>
+
+ * libgnat/g-catiio.ads: Change the regular expression that
+ documents the allowed format to match what ISO-8601 allows.
+ * libgnat/g-catiio.adb (Scan_Subsecond): Rewrite so it doesn't
+ assume the subsecond comes last.
+ (Parse_ISO_8601): Parse an optional subsecond, followed by an
+ optional time zone, rather than making these alternatives to
+ each other.
+
+2020-07-06 Bob Duff <duff@adacore.com>
+
+ * libgnat/g-catiio.adb (Parse_ISO_8601): Minor cleanups:
+ Give some objects clearer names.
+ Make some objects more local to where they are used.
+ Remove some validity checks that can't fail, because some of
+ the variables tested have been moved so they're not visible here.
+ Anyway, Wrong_Syntax is about errors in the input, not data
+ validity.
+ Use Time_Zone_Seen instead of Local_Sign = ' ' to determine
+ that a time zone indication was seen.
+ We don't need to distinguish two different kinds of
+ syntax error (End_Of_Source_Reached and Wrong_Syntax),
+ so use Wrong_Syntax always.
+ Remove comment, "Certain scanning scenarios may handle
+ this exception on their own."; there are no such scenarios.
+
+2020-07-06 Bob Duff <duff@adacore.com>
+
+ * libgnat/g-catiio.ads, libgnat/g-catiio.adb (Image): New
+ function. It might seem like the local-time Image should be
+ implemented in terms of the Time_Zone Image, but that would be
+ far harder to implement, so we do it the other way around.
+
+2020-07-06 Thomas Quinot <quinot@adacore.com>
+
+ * libgnat/g-sechas.ads, libgnat/g-sechas.adb: Refactor to use
+ Stream_Element_Array as the internal buffer type.
+ * libgnat/g-shshco.adb: Adjust to use Stream_Element_Offset
+ instead of Integer as the index in the internal state buffer.
+
+2020-07-06 Gary Dismukes <dismukes@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_pragmas.rst, errout.ads,
+ erroutc.adb, exp_ch4.adb, exp_ch6.adb, freeze.adb: Comment
+ rewording/reformatting/typo fixes. Replace "ie." with "that is"
+ in comment; "can not" -> "cannot", and remove an extraneous
+ underscore in another comment.
+ * gnat_rm.texi, gnat_ugn.texi: Regenerate.
+
+2020-07-06 Javier Miranda <miranda@adacore.com>
+
+ * sem_util.ads (Interval_Lists.Aggregate_Intervals): New
+ subprogram.
+ * sem_util.adb (Has_Null_Others_Choice,
+ Non_Static_Or_Null_Range, Interval_Lists.Aggregate_Intervals):
+ New subprograms.
+ (Is_Potentially_Unevaluated): Adding support to detect
+ potentially unevaluated components of array aggregates.
+
+2020-07-06 Bob Duff <duff@adacore.com>
+
+ * libgnat/g-catiio.adb (Parse_ISO_8601): New name for
+ Parse_ISO_8861_UTC. 8601 is the correct ISO standard number.
+ Also, "UTC" was confusing. All Time values are represented in
+ UTC, but the ISO 8601 date strings include a time zone.
+ If a time zone was specified, call
+ Ada.Calendar.Formatting.Time_Of instead of
+ GNAT.Calendar.Time_Of, because the latter adjusts to the current
+ time zone, whereas we want to use (just) the time zone specified
+ in the ISO string. This allows us to pass Time_Zone instead to
+ Time_Of, instead of adjusting by Local_Disp by hand.
+ If no time zone was specified, call GNAT.Calendar.Time_Of as
+ before.
+ Use expanded names to clarify which Time_Of is being called.
+ Remove redundant comment, and move nonredundant part of the
+ commment to the spec.
+ (Value): Minor: use "not in" instead of "or else".
+ * libgnat/g-catiio.ads: Comment moved here. Correct the ISO
+ standard number.
+ * libgnat/g-calend.adb: Add ??? comments.
+ * libgnat/a-calend.ads, libgnat/a-calend.adb: Update obsolete
+ comments regarding the representation of type Time. Move the
+ information about the epoch (year 2150) to the spec, and avoid
+ uttering "2150" more than once.
+ * libgnat/a-catizo.ads (Time_Offset): Add comment.
+
+2020-07-06 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch5.adb (Find_Component): If the target type is a derived
+ record type and the required component is a discriminant that is
+ renamed in the derived type declaration, use the name of the
+ original discriminant to locate the intended target component.
+
+2020-07-06 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch12.adb (Analyze_Associations): Add check for errors on
+ the generic formal before continuing with instantiation.
+
+2020-07-06 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-nbnbin.ads, libgnat/a-nbnbin.adb,
+ libgnat/a-nbnbin__gmp.adb: Use more Valid_Big_Integer.
+
+2020-07-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_util.ads (Get_Index_Subtype): Fix duplicate "Last".
+
+2020-07-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sinfo.ads: Indicate that Field 1 of an N_Delta_Aggregate is
+ unused. Previously it was erroneously labelled as holding an
+ Expressions list, in analogy with other aggregate constructs,
+ but there are no Expressions attached to this node syntactically
+ or semantically.
+
+2020-07-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Eval_Attribute): Check if constant has an
+ initialization expression.
+
+2020-07-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_N_Attribute_Reference): Apply
+ scalar range checks.
+ * sem_attr.adb (Resolve_Attribute): Do not set scalar range
+ checks when resolving attribute Update.
+
+2020-07-06 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute, Attribute_Constrained): Issue
+ a warning if the attribute prefix is a current instance
+ reference within an aspect of a type or subtype.
+ (Address_Checks): Replace test of Is_Object (Ent) with
+ Is_Object_Reference (P) so that testing for current instances
+ will be done.
+ (Eval_Attribute): Add test for current instance reference, to
+ ensure that we still fold array attributes when current
+ instances are involved, since value prefixes are allowed for
+ array attributes, and will now be excluded by
+ Is_Object_Reference.
+ * sem_util.ads (Is_Current_Instance_Reference_In_Type_Aspect):
+ New exported query function.
+ * sem_util.adb (Is_Object_Reference): Return False for the case
+ where N is a current instance reference within an
+ aspect_specification of a type or subtype (basically if the
+ reference occurs within a predicate, invariant, or DIC aspect
+ expression).
+ (Is_Current_Instance_Reference_In_Type_Aspect): New function
+ that tests whether a node is a reference to a current instance
+ formal of a predicate, invariant, or
+ Default_Initial_Condition (DIC) subprogram.
+
+2020-07-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Resolve_Declare_Expression): New subprogram, to
+ install the scope holding local declarations of the expression,
+ before completing its resolution.
+ (Resolve): For an Expression_With_Actions that comes from a
+ source occurrence of a Declare_Expression, call new subprogram.
+
+2020-07-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Reuse SPARK_Implicit_Load.
+
+2020-07-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch5.adb (Analyze_Loop_Parameter_Specification): Propagate
+ exception when switch -gnatdk is used and no previous errors are
+ present.
+ * sem_eval.adb (Compile_Time_Known_Value, Is_In_Range):
+ Likewise.
+ * sem_warn.adb (Operand_Has_Warnings_Suppressed): Likewise.
+
+2020-07-06 Richard Kenner <kenner@adacore.com>
+
+ * exp_unst.adb (Needs_Fat_Pointer): Don't check for formal.
+ (Unnest_Subprogram): Use 'Unchecked_Access instead of 'Access
+ when populating activation record.
+
+2020-07-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch6.adb (Add_Simple_Call_By_Copy_Code): Rename parameter
+ from Bit_Packed_Array to Force.
+ (Expand_Actuals): Do not apply BIP processing if the subprogram
+ is intrinsic. Adjust calls to Add_Simple_Call_By_Copy_Code and
+ add one for In parameters whose actual is a CPP constructor call.
+
+2020-07-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_attr.adb (Eval_Attribute): Do not apply range checks in
+ the case of 'Pos applied to an integer type here.
+
+2020-07-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): If the type is an
+ Unchecked_Union, and the expression is an aggregate. complete
+ the analysis and resolution of the aggregate, and treat like a
+ regular object declaration, instead of as a renaming
+ declarattion.
+
+2020-07-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch9.adb (Is_Potentially_Large_Family): Add documentation.
+ (Actual_Index_Expression): Use Entry_Index_Type.
+ (Build_Entry_Count_Expression): Likewise.
+ (Build_Find_Body_Index): Likewise.
+ (Collect_Entry_Families): Likewise. Use directly the bounds of
+ the index type to find out whether the family is large.
+ (Entry_Index_Expression): Likewise.
+
+2020-07-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_res.adb (Resolve_Range): Resolve both low and high bounds
+ with the range type.
+
+2020-07-06 Arnaud Charlet <charlet@adacore.com>
+
+ * aspects.ads (Is_Representation_Aspect):
+ Default_Component_Value is a representation aspect.
+ * sem_ch13.adb (Check_Aspect_Too_Late, Rep_Item_Too_Late): Relax
+ RM 13.1(10) rule wrt primitive operations for Ada 202x.
+
+2020-07-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_aggr.adb (Aggr_Assignment_OK_For_Backend): Move to library
+ level and use a new predicate Is_OK_Aggregate to recognize the
+ aggregates suitable for direct assignment by the back-end.
+ (Convert_Array_Aggr_In_Allocator): If neither in CodePeer mode nor
+ generating C code, generate a direct assignment instead of further
+ expanding if Aggr_Assignment_OK_For_Backend returns true.
+
+2020-07-06 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_aux.adb: Add a with clause for Nlists.
+ (Nearest_Ancestor): Test for the case of concurrent
+ types (testing for both Is_Concurrent_Type and
+ Is_Concurrent_Record_Type), and return the first ancestor in the
+ Interfaces list if present (otherwise will return Empty if no
+ interfaces).
+ * sem_ch13.adb (Build_Predicate_Functions): Add a ??? comment
+ about missing handling for adding predicates when they can be
+ inherited from multiple progenitors.
+
+2020-07-06 Arnaud Charlet <charlet@adacore.com>
+
+ * par-ch6.adb (P_Return_Object_Declaration): Set
+ Has_Init_Expression flag.
+
+2020-07-02 Eric Botcazou <ebotcazou@gcc.gnu.org>
+
+ * debug.adb (d.K): Document new usage.
+ * fe.h (Debug_Flag_Dot_KK): Declare.
+ * gcc-interface/decl.c (gnat_to_gnu_field): Give an error when the
+ component overlaps with the parent subtype, except with -gnatd.K.
+
+2020-06-26 Eric Botcazou <ebotcazou@gcc.gnu.org>
+
+ * exp_ch4.adb (Expand_Set_Membership): Expand the membership test
+ using left associativity instead of right associativity.
+
+2020-06-23 Eric Botcazou <ebotcazou@gcc.gnu.org>
+
+ * gcc-interface/utils2.c (build_binary_op): Remove space.
+
+2020-06-23 Eric Botcazou <ebotcazou@gcc.gnu.org>
+
+ * gcc-interface/trans.c (gnat_to_gnu) <N_Allocator>: Minor tweaks.
+ Call Has_Constrained_Partial_View on base type of designated type.
+
+2020-06-23 Eric Botcazou <ebotcazou@gcc.gnu.org>
+
+ * gcc-interface/utils.c (gnat_write_global_declarations): Output
+ integral global variables first and the imported functions later.
+
+2020-06-23 Eric Botcazou <ebotcazou@gcc.gnu.org>
+
+ * gcc-interface/decl.c (elaborate_expression_1): When GNAT encodings
+ are not used, do not create a variable for debug info purposes if
+ the expression is itself a user-declared variable.
+
+2020-06-23 Eric Botcazou <ebotcazou@gcc.gnu.org>
+
+ * gcc-interface/ada-tree.h (DECL_RENAMED_OBJECT): Delete.
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Always use
+ the stabilized reference directly for renaming and create a variable
+ pointing to it separately if requested.
+ * gcc-interface/misc.c (gnat_print_decl): Adjust for deletion.
+ * gcc-interface/trans.c (Identifier_to_gnu): Likewise.
+ (gnat_to_gnu) <N_Object_Renaming_Declaration>:
+ Do not deal with side-effects here.
+ <N_Exception_Renaming_Declaration>: Likewise.
+
+2020-06-23 Eric Botcazou <ebotcazou@gcc.gnu.org>
+
+ * gcc-interface/decl.c (elaborate_expression): Replace calls to
+ Is_OK_Static_Expression with Compile_Time_Known_Value.
+
+2020-06-23 Eric Botcazou <ebotcazou@gcc.gnu.org>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Subtype>: Set
+ debug type to the base type and only if the subtype is artificial.
+
+2020-06-23 Eric Botcazou <ebotcazou@gcc.gnu.org>
+
+ * gcc-interface/trans.c (gnat_to_gnu) <N_Assignment_Statement>: Do
+ not test Is_Bit_Packed_Array in the memset path.
+
+2020-06-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (lvalue_required_for_attribute_p): Do not deal
+ with 'Pos or 'Val.
+ (Attribute_to_gnu): Likewise.
+ * gcc-interface/utils.c (create_field_decl): Small formatting fix.
+
+2020-06-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (adjust_for_implicit_deref): Delete.
+ (maybe_implicit_deref): Likewise.
+ (Attribute_to_gnu): Replace calls to maybe_implicit_deref by calls
+ to maybe_padded_object.
+ (Call_to_gnu): Likewise.
+ (gnat_to_gnu) <N_Indexed_Component>: Likewise.
+ <N_Slice>: Likewise.
+ <N_Selected_Component>: Likewise.
+ <N_Free_Statement>: Remove call to adjust_for_implicit_deref and
+ manually make sure that the designated type is complete.
+ * gcc-interface/utils2.c (build_simple_component_ref): Add comment.
+
+2020-06-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_param): Tidy up.
+ (gnat_to_gnu_subprog_type): For a variadic C function, do not
+ build unnamed parameters and do not add final void node.
+ * gcc-interface/misc.c: Include snames.h.
+ * gcc-interface/trans.c (Attribute_to_gnu): Tidy up.
+ (Call_to_gnu): Implement support for unnamed parameters in a
+ variadic C function.
+ * gcc-interface/utils.c: Include snames.h.
+ (copy_type): Tidy up.
+
+2020-06-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch5.adb (Expand_N_Assignment_Statement): Do not apply
+ range checks to allocators here.
+
+2020-06-19 Justin Squirek <squirek@adacore.com>
+
+ * lib.adb (Check_Same_Extended_Unit): Add check to determine if
+ the body for the subunits exist in the same file as their
+ specifications.
+
+2020-06-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_aggr.adb (In_Place_Assign_OK): In an allocator context,
+ check the bounds of an array aggregate against those of the
+ designated type, except if the latter is unconstrained.
+
+2020-06-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch3.adb (Is_Visible_Component): Reason only on the private
+ status of the original type in an instance body.
+
+2020-06-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_res.adb (Resolve_Qualified_Expression): Do not override the
+ type of the node when it is unconstrained if it is for an allocator.
+
+2020-06-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_res.adb (Resolve_Allocator): Call Resolve_Qualified_Expression
+ on the qualified expression, if any, instead of doing an incomplete
+ type resolution manually.
+ (Resolve_Qualified_Expression): Apply predicate check to operand.
+
+2020-06-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch4.adb (Analyze_Selected_Component): In an instance body,
+ also invoke Find_Component_In_Instance on the parent subtype of
+ a derived tagged type immediately visible. Remove obsolete case.
+
+2020-06-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_attr.adb (Get_Integer_Type): Return the largest supported
+ unsigned integer type if need be.
+
+2020-06-19 Justin Squirek <squirek@adacore.com>
+
+ * sem_warn.adb (Warn_On_Known_Condition): Add general sanity
+ check that asserts the original source node being checked
+ contains an entity. If not, it could be the result of special
+ case expansion for type conversions.
+
+2020-06-19 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): Do not indicate
+ that the function has a completion if it appears within a Ghost
+ generic package.
+
+2020-06-19 Bob Duff <duff@adacore.com>
+
+ * libgnat/a-ststbo.adb (Write): Replace pragma Assert with "if
+ ... raise Constraint_Error".
+
+2020-06-19 Justin Squirek <squirek@adacore.com>
+
+ * widechar.adb, widechar.ads (Skip_Wide): Catch validity check
+ failure when skipping over characters, and update comment to
+ reflect Skip_Wide's usage in error printing.
+
+2020-06-19 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch3.ads (Ensure_Activation_Chain_And_Master): New
+ subprogram.
+ * exp_ch3.adb (Ensure_Activation_Chain_And_Master): New
+ subprogram that factorizes code.
+ (Expand_N_Object_Declaration): Call new subprogram.
+ * sem_ch6.adb (Analyze_Function_Return): Returning a
+ build-in-place unconstrained array type defer the full analysis
+ of the returned object to avoid generating the corresponding
+ constrained subtype; otherwise the bounds would be created in
+ the stack and a dangling reference would be returned pointing to
+ the bounds.
+
+2020-06-19 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-nbnbin.adb, libgnat/a-nbnbin.ads,
+ libgnat/a-nbnbin__gmp.adb, libgnat/a-nbnbre.adb,
+ libgnat/a-nbnbre.ads: Update spec according to AI12-0366.
+
+2020-06-19 Piotr Trojanek <trojanek@adacore.com>
+
+ * checks.ads: Remove excessive whitespace in declarations of
+ functions for check suppression.
+
+2020-06-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch7.adb (Hide_Public_Entities): Split handling of objects
+ and subprograms, and do not reject the latter upfront in nested
+ instance specs if there are no referencer subprograms at all.
+ (Analyze_Package_Body_Helper): Also call Hide_Public_Entities on
+ nested generic instances.
+
+2020-06-19 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Reject illegal positional
+ component associations; fix syntax in comment about named
+ component associations.
+
+2020-06-19 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aggr.adb (Resolve_Delta_Record_Aggregate): Modify a nested
+ Get_Component_Type routine to return a component and not just
+ its type; use this routine to decorate the identifier within the
+ delta aggregate.
+
+2020-06-19 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch4.adb (Find_Equality_Types.Check_Access_Attribute): New.
+ (Find_Equality_Types): Move universal_access related checks at
+ the end of the processing and add call to
+ Check_Access_Attribute.
+
+2020-06-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_prag.adb (Process_Convention): Revert previous change.
+
+2020-06-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * checks.ads (Apply_Static_Length_Check): Move up.
+ (Apply_Range_Check): Add parameter Insert_Node.
+ * checks.adb (Apply_Selected_Range_Checks): Merge into...
+ (Apply_Range_Check): ...this. Add parameter Insert_Node,
+ pass it as Warn_Node to Selected_Range_Checks and use it
+ as insertion point for the checks.
+ * sem_ch3.adb (Analyze_Subtype_Declaration): Rewrite block
+ dealing with the range checks for the subtype indication.
+ Use local variable and call Apply_Range_Check in both cases.
+
+2020-06-19 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): Call Ensure_Valid
+ on the expression of an object declaration that captures the
+ value of 'Old prefix.
+
+2020-06-19 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): Add comment.
+ * sem_attr.adb (Analyze_Attribute): Add ??? comment.
+ * sem_util.ads (Valid_Scalars): This routine is only used for
+ 'Valid_Scalars and not for 'Valid.
+
+2020-06-19 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): Do not call
+ Scalar_Part_Present on the array component's type.
+ (Build_Array_VS_Func): Remove Comp_Typ parameter, because it can
+ be easily computed from the Array_Top parameter *and redundant
+ parameters are confusing and error-prone).
+
+2020-06-19 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb (Build_Record_VS_Func): Strip privacy and type
+ derivation from the root type when 'Valid_Scalars is applied to
+ a class-wide type.
+
+2020-06-19 Piotr Trojanek <trojanek@adacore.com>
+
+ * checks.adb (Apply_Parameter_Validity_Checks): Remove testing
+ of Check_Validity_Of_Parameters for every formal parameter and
+ function result.
+
+2020-06-19 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Add missing
+ warning tag.
+
+2020-06-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Get_Size_For_Range): Only make sure to return a
+ size lower than that of the original type if possible.
+ * libgnat/s-rannum.adb (Random_Discrete): Back out optimization
+ added for 32-bit types.
+
+2020-06-18 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch6.ads, sem_ch6.adb (Check_Formal_Conformance): New
+ subprogram.
+ (Check_Conformance): Move code to Check_Formal_Conformance.
+ * sem_ch8.adb (Analyze_Subprogram_Renaming): Check for formal
+ conformance when needed.
+
+2020-06-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Narrow_Large_Operation): New procedure to try
+ and narrow large arithmetic and comparison operations.
+ (Expand_N_In): Call it.
+ (Expand_N_Op_Abs): Likewise.
+ (Expand_N_Op_Add): Likewise.
+ (Expand_N_Op_Divide): Likewise.
+ (Expand_N_Op_Eq): Likewise.
+ (Expand_N_Op_Ge): Likewise.
+ (Expand_N_Op_Gt): Likewise.
+ (Expand_N_Op_Le): Likewise.
+ (Expand_N_Op_Lt): Likewise.
+ (Expand_N_Op_Minus): Likewise.
+ (Expand_N_Op_Mod): Likewise.
+ (Expand_N_Op_Multiply): Likewise.
+ (Expand_N_Op_Ne): Likewise.
+ (Expand_N_Op_Plus): Likewise.
+ (Expand_N_Op_Rem): Likewise.
+ (Expand_N_Op_Subtract): Likewise.
+ (Expand_N_Type_Conversion): Use Convert_To procedure.
+ * exp_ch9.adb (Is_Pure_Barrier) <N_Identifier>: Skip all
+ numeric types.
+ <N_Type_Conversion>: Use explicit criterion.
+
+2020-06-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Expand_Allocator_Expression): Apply constraint
+ and predicate checks for the qualified expression on entry,
+ followed by constraint and predicate checks for the allocator
+ itself, and return early if this results in a static error.
+ (Expand_N_Allocator): Do not do the same here. Instead apply
+ constraint and predicate checks for arrays in the subtype
+ indication case.
+ * exp_ch5.adb (Expand_N_Assignment_Statement): Do not apply
+ range checks to allocators here.
+
+2020-06-18 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch6.adb (BIP_Suffix_Kind, Is_Build_In_Place_Entity): Move
+ declarations...
+ * exp_ch6.ads: Here.
+ * exp_util.adb (Is_Secondary_Stack_BIP_Func_Call): Do not rely
+ on the name of the scope to locate the extra formal BIPalloc
+ since they are copied when the pointer type associated with
+ dispatching calls is built; rely on routines
+ Is_Build_In_Place_Entity and BIP_Suffix_Kind.
+ * exp_disp.adb (Expand_Dispatching_Call): Set the scope of the
+ first extra formal of the internally built pointer type.
+ * sem_ch3.adb (Derive_Subprogram): Do not inherit extra formals
+ from a limited interface parent since limitedness is not
+ inherited in such case (AI-419) and this affects the extra
+ formals.
+ * sprint.adb (Write_Itype): Output extra formals of subprogram
+ types.
+
+2020-06-18 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * errout.adb (Write_Error_Summary): Display number of warnings
+ treated as errors.
+ * errutil.ads: Update comment.
+
+2020-06-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_attr.adb (Analyze_Attribute) <Asm_{In,Out}put>: Alphabetize.
+ <Component_Size>: Add check for universal integer attribute.
+ <Aft>, <Bit_Order>, <Definite>, <Max_Alignment_For_Allocation>,
+ <Scalar_Storage_Order>: Raise Program_Error on them.
+ * sem_attr.adb (Eval_Attribute) <Component_Size>: Add comment on
+ the packed array case.
+
+2020-06-18 Steve Baird <baird@adacore.com>
+
+ * sem_util.adb (Object_Access_Level): Treat a 'Old attribute
+ reference like an aggregate in determining its static
+ accessibility level; after the evaluation of the relevant
+ post-condition, the implicitly declared constant associated with
+ an Old attribute reference ceases to exist. Similarly for
+ Loop_Entry attribute.
+ * exp_ch6.adb (Expand_Call_Helper): For an attribute reference
+ that is expanded into a reference to an implicitly declared
+ constant (e.g., a 'Old or 'Loop_Entry attribute), compute the
+ dynamic accessibility level of that constant by looking at the
+ declaration of the constant (as opposed to looking at the
+ attribute reference).
+
+2020-06-18 Steve Baird <baird@adacore.com>
+
+ * exp_ch3.adb (Expand_N_Object_Declaration): Do not generate a
+ default initial condition check for the declaration of an
+ imported object.
+
+2020-06-18 Arnaud Charlet <charlet@adacore.com>
+
+ * Makefile.rtl: Add s-statxd.o.
+ * bindgen.adb (Gen_Adainit): Add support for XDR_Stream.
+ * bindusg.adb (Display): Add mention of -xdr.
+ * gnatbind.adb: Process -xdr switch.
+ * init.c (__gl_xdr_stream): New.
+ * opt.ads (XDR_Stream): New.
+ * libgnat/s-stratt__xdr.adb: Rename to...
+ * libgnat/s-statxd.adb: this and adjust.
+ * libgnat/s-statxd.ads: New.
+ * libgnat/s-stratt.ads, libgnat/s-stratt.adb: Choose between
+ default and XDR implementation at runtime.
+ * libgnat/s-ststop.ads: Update comments.
+ * doc/gnat_rm/implementation_advice.rst: Update doc on XDR
+ streaming.
+ * gnat_rm.texi: Regenerate.
+
+2020-06-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute) <To_Address>: Use the address
+ size of the target instead of the host when checking the value of
+ a static expression. Also use standard idiom for exponentiation.
+
+2020-06-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_prag.adb (Process_Convention): Give a warning on C_Variadic_n
+ being applied to a subprogram with exactly n parameters.
+
+2020-06-18 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnarl/s-osinte__linux.ads, libgnat/g-io.adb,
+ libgnat/g-socket.adb, libgnat/g-socthi.adb,
+ libgnat/g-socthi.ads, libgnat/g-socthi__vxworks.adb,
+ libgnat/g-socthi__vxworks.ads, libgnat/g-sothco.ads,
+ libgnat/s-io.adb, libgnat/a-except.adb: Fix function profile
+ mismatch with imported C functions.
+
+2020-06-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch6.adb (Expand_Call_Helper): Remove superfluous calls
+ to Relocate_Node and merge calls to Analyze and Resolve in a
+ couple of places. Do not attempt to generate a range check
+ for an actual parameter against the formal's type of a derived
+ subprogram after generating a conversion to the formal's type
+ of the parent subprogram.
+
+2020-06-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * checks.adb (Compute_Range_For_Arithmetic_Op): New procedure to
+ compute a range for an arithmetical operation extracted from...
+ (Minimize_Eliminate_Overflows): ...here. Call it.
+ (Determine_Range_Cache_O): New cache for Original_Node nodes.
+ (Determine_Range): Call Compute_Range_For_Arithmetic_Op for all
+ arithmetic expressions. Use Attribute_Id in lieu of Attribute_Name
+ for attributes. Add handling for Range_Length alongside Length.
+ Add specific handling for Alignment, Bit, First_Bit, Last_Bit,
+ Max_Size_In_Storage_Elements, Position, Bit_Position,
+ Component_Size, Object_Size, Size, Value_Size, Descriptor_Size.
+ (Enable_Overflow_Check): Omit the check for Abs and Minus if the
+ operand cannot be the largest negative number.
+ (Selected_Length_Checks): Use Pos for Number_Dimensions.
+ * exp_attr.adb (Expand_N_Attribute_Reference): Move compile-time
+ handling of Bit_Position, Descriptor_Size, First_Bit, Last_Bit
+ and Position to...
+ * sem_attr.adb (Eval_Attribute): ...here. Move up Alignment for
+ objects and use Compile_Time_Known_Attribute in this case too.
+
+2020-06-18 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * erroutc.ads: Declare new Is_Compile_Time_Msg boolean,
+ add new Compile_Time_Pragma field to Error_Msg_Object type.
+ (Count_Compile_Time_Pragma_Warnings): New function.
+ * erroutc.adb (Count_Compile_Time_Pragma_Warnings): New
+ function.
+ (Compilation_Errors): Take Compile_Time warnings into account
+ when tallying Errors/Warnings.
+ * errout.ads (Error_Msg): New procedure.
+ * errout.adb (Error_Msg): New procedure.
+ (Error_Msg_Internal): Set new Compile_Time_Pragma field in
+ Error_Msg_Object.
+ * errutil.adb (Error_Msg): Set new Compile_Time_Pragma field in
+ Error_Msg_Object.
+ * sem_prag.adb (Validate_Compile_Time_Warning_Or_Error): Pass
+ True to new Error_Msg procedure.
+ * doc/gnat_rm/implementation_defined_pragmas.rst: Update doc for
+ the Compile_Time_Warning pragma.
+ * gnat_rm.texi: Regenerate.
+ * opt.ads: Update comment.
+
+2020-06-18 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch4.adb (Check_Compatible_Profiles): Add explicit
+ initialization.
+
+2020-06-18 Piotr Trojanek <trojanek@adacore.com>
+
+ * checks.adb (Generate_Index_Checks): Handle
+ N_Subtype_Indication returned from Scalar_Range.
+
+2020-06-18 Piotr Trojanek <trojanek@adacore.com>
+
+ * checks.adb, sem_ch3.adb: Minor refactorings.
+ * sem_eval.adb (Eval_Qualified_Expression): Fix reference to RM
+ rule in comment; only set a local variable Hex in the branch
+ where it is used.
+
+2020-06-18 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_eval.adb (Check_Non_Static_Context): Use Is_RTE.
+
+2020-06-18 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch4.adb (Find_Equality_Types.Check_Access_Object_Types):
+ New function, used to implement RM 4.5.2 (9.6/2).
+ (Find_Equality_Types.Check_Compatible_Profiles): New function,
+ used to implement RM 4.5.2(9.7/2).
+ (Find_Equality_Types.Reference_Anonymous_Access_Type): New
+ function.
+ (Find_Equality_Types.Try_One_Interp): Fix handling of anonymous
+ access types which was accepting both too much and too little.
+ Remove accumulated special and incomplete cases for
+ instantiations, replaced by Has_Compatible_Type.
+ (Analyze_Overloaded_Selected_Component): Use
+ Is_Anonymous_Access_Type instead of Ekind_In.
+ * sem_res.adb: Code cleanup and bug fix: use
+ Is_Anonymous_Access_Type instead of Ekind_In. Relax checking of
+ anonymous access parameter when universal_access "=" is
+ involved.
+ * sem_type.adb: Likewise.
+ (Find_Unique_Type): Move code from here...
+ (Specific_Type): ...to here. Also add missing handling of access
+ to class wide types.
+ * einfo.ads, einfo.adb (Is_Access_Object_Type): New.
+
+2020-06-18 Bob Duff <duff@adacore.com>
+
+ * libgnat/a-strsto.ads, libgnat/a-ststbo.adb,
+ libgnat/a-ststbo.ads, libgnat/a-ststun.adb,
+ libgnat/a-ststun.ads: New files, containing packages
+ Ada.Streams.Storage, Ada.Streams.Storage.Bounded, and
+ Ada.Streams.Storage.Unbounded.
+ * impunit.adb, Makefile.rtl: Add new file names.
+
+2020-06-18 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch13.adb (Has_Good_Profile): Enforce strictness in the
+ check. Required to detect wrong profiles for Input and Output.
+ (Analyze_Stream_TSS_Definition): Minor enhancement in the text
+ of the error for class-wide attributes.
+
+2020-06-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_attr.adb (Get_Integer_Type): Pick an unsigned type based
+ on the Esize of the base type of the input type.
+
+2020-06-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Expand_Array_Equality): For the optimization of
+ the 2-element case, build new expression lists for the indices.
+
+2020-06-18 Richard Kenner <kenner@adacore.com>
+
+ * sem_util.adb (Enclosing_Subprogram): No longer need
+ Convention_Protected.
+
+2020-06-18 Claire Dross <dross@adacore.com>
+
+ * sem_util.adb (Is_OK_Volatile_Context): Return False on
+ definitions of constants declared in declare expressions.
+
+2020-06-18 Piotr Trojanek <trojanek@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_aspects.rst
+ (Relaxed_Initialization): New implementation-defined aspect.
+ * doc/gnat_rm/implementation_defined_attributes.rst
+ (Initialized): New implementation-defined attribute.
+ * gnat_rm.texi: Regenerate.
+
+2020-06-18 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.adb (Expand_Dispatching_Call): Add missing decoration
+ of attribute Extra_Accessibility_Of_Result.
+ * freeze.adb (Check_Extra_Formals): No check required if
+ expansion is disabled; Adding check on
+ Extra_Accessibilty_Of_Result.
+ (Freeze_Subprogram): Fix decoration of
+ Extra_Accessibility_Of_Result.
+ * sem_ch3.adb (Derive_Subprogram): Fix decoration of
+ Extra_Accessibility_Of_Result
+
+2020-06-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Optimize_Length_Comparison): Accept 32-bit values
+ in the full unsigned range.
+
+2020-06-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * checks.adb (Apply_Universal_Integer_Attribute_Checks): Do not do
+ anything when the type of the node is already Universal_Integer.
+
+2020-06-17 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch10.adb (Expand_With_Clause): Add missing handling of
+ N_Generic_Subprogram_Declaration, N_Subprogram_Declaration,
+ N_Subprogram_Body.
+
+2020-06-17 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb: (Check_Inherited_Indexing): Check that a type
+ derived from an indexable container type cannot specify an
+ indexing aspect if the same aspect is not specified for the
+ parent type (RM 4.1.6 (6/5), AI12-160). Add a check that a
+ specified indexing aspect for a derived type is confirming.
+
+2020-06-17 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch9.adb (Build_Protected_Subp_Specification): Add ???
+ comment about the flag Has_Nested_Subprogram not being set here.
+ (Expand_N_Protected_Body): If the original body for a protected
+ subprogram has the flag Has_Nested_Subprogram set, then set that
+ flag on the new unprotected subprogram body that's created for
+ it, and reset the Scope fields of its top level declarations,
+ which have been effectively taken from the original protected
+ subprogram body. Add ??? comment about unclear testing of
+ Corresponding_Spec.
+
+2020-06-17 Javier Miranda <miranda@adacore.com>
+
+ * aspects.ads (type Aspect_Id): Add Aspect_Yield as a Boolean
+ aspect, and update the Is_Representation_Aspect, Aspect_Names,
+ and Aspect_Delay arrays.
+ * einfo.ads, einfo.adb (Has_Yield_Aspect, Yield_Aspect): New
+ subprograms.
+ * exp_ch6.adb (Add_Return, Expand_Non_Function_Return,
+ Expand_Simple_Function_Return): Add calls to Yield.
+ * exp_ch9.adb (Build_Accept_Body, Expand_N_Accept_Statement):
+ Add calls to Yield.
+ * rtsfind.ads (RE_Yield): Adding support to generate calls to
+ the runtime service Ada.Dispatching.Yield
+ * sem_ch13.adb (Analyze_Aspect_Yield): New subprogram.
+ * sem_ch3.adb (Derive_Subprogram): Inherit attribute
+ Has_Yield_Aspect.
+ * sem_ch8.adb (Analyze_Subprogram_Renaming): Check consistency
+ of Has_Yield in the actual subprogram of a generic
+ instantiation.
+ * sem_disp.adb (Check_Dispatching_Operation): Check that if the
+ Yield aspect is specified for a dispatching subprogram that
+ inherits the aspect, the specified value shall be confirming.
+ * sem_prag.adb (Analyze_Pragma [Pragma_Implemented]): Check that
+ the implementation kind By_Protected_Procedure cannot be applied
+ to a procedure that has aspect Yield.
+
+2020-06-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Op_Expon): Replace all occurrences of
+ the original right operand with the relocated version.
+
+2020-06-17 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch6.adb (Has_BIP_Extra_Formal): New subprogram.
+ (Needs_BIP_Task_Actuals): Add support for the subprogram type
+ internally generated for dispatching calls.
+ * exp_disp.adb (Expand_Dispatching_Call): Adding code to
+ explicitly duplicate the extra formals of the target subprogram.
+ * freeze.adb (Check_Extra_Formals): New subprogram.
+ (Freeze_Subprogram): Fix decoration of Extra_Formals.
+ * sem_ch3.adb (Derive_Subprogram): Fix decoration of
+ Extra_Formals.
+
+2020-06-17 Bob Duff <duff@adacore.com>
+
+ * par.adb (P_Basic_Declarative_Items): Update comment about
+ Declare_Expression.
+ * par-ch3.adb (P_Declarative_Items): Pass in Declare_Expression
+ flag, and if True, skip the call to Style.Check_Indentation.
+ * par-ch4.adb (P_Declare_Expression): Fix incorrect comment.
+
+2020-06-17 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_res.adb (Valid_Conversion): Change error message to make
+ it more user-friendly.
+
+2020-06-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * checks.ads (Apply_Length_Check_On_Assignment): Declare.
+ * checks.adb (Apply_Length_Check_On_Assignment): New procedure
+ to apply a length check to an expression in an assignment.
+ * exp_ch5.adb (Expand_Assign_Array): Call it instead of calling
+ Apply_Length_Check to generate a length check.
+ * sem_ch5.adb (Analyze_Assignment): Likewise.
+
+2020-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * einfo.adb (Is_Relaxed_Initialization_State): Add reference to
+ SPARK RM.
+ * sem_attr.adb (Analyze_Attribute_Old_Result): Likewise.
+ * sem_ch13.adb (Analyze_Aspect_Relaxed_Initialization): Reject
+ aspect on completions of private types and deferred constants.
+ * sem_util.ads, sem_util.adb (Has_Relaxed_Initialization):
+ Adjust comments; support queries for constants.
+
+2020-06-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * cstand.adb (Stloc): Change to a renaming.
+ (Staloc): Likewise.
+ (Build_Unsigned_Integer_Type): Remove Nam parameter, use local
+ constants and do not call Make_Name.
+ (Make_Dummy_Index): Use local constants.
+ (Create_Standard): Pass the name of entities as parameter in
+ calls to New_Standard_Entity and remove calls to Make_Name.
+ Adjust calls to Build_Unsigned_Integer_Type.
+ (Identifier_For): Use local constant.
+ (Make_Component): Pass the name of the component as parameter
+ in call to New_Standard_Entity and remove call to Make_Name.
+ (Make_Formal): Likewise. Rename Formal_Name parameter into
+ Nam and use local constant.
+ (Make_Name): Delete.
+ (New_Operator): Use local constant.
+ (New_Standard_Entity): Rename S parameter into Nam and build
+ the name here. Remove call to Make_Name.
+ (Register_Float_Type): Pass the name of the type as parameter
+ in call to New_Standard_Entity and remove call to Make_Name.
+
+2020-06-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference) <Attribute_First>:
+ Remove condition added for scalar types.
+
+2020-06-17 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch3.ads (Build_Access_Subprogram_Wrapper_Body): Adjust
+ colon columns; reformat comment.
+ * exp_ch3.adb
+ (Build_Access_Subprogram_Wrapper_Body): Likewise.
+ * sem_ch3.adb (Build_Access_Subprogram_Wrapper): Reformat spec
+ comment and reformat comment in body.
+ (Analyze_Full_Type_Declaration): Reformat comment.
+ (Replace_Type_Name): Fixed three typos, plus reformatting of
+ comment.
+ * sem_prag.adb (Analyze_Pre_Post_Condition): Fix typos.
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Edit comments:
+ remove hyphen, add missing word.
+
+2020-06-17 Bob Duff <duff@adacore.com>
+
+ * libgnat/a-cbdlli.adb, libgnat/a-cbhama.adb,
+ libgnat/a-cbhase.adb, libgnat/a-cbmutr.adb,
+ libgnat/a-cborma.adb, libgnat/a-cborse.adb,
+ libgnat/a-cdlili.adb, libgnat/a-chtgbk.adb,
+ libgnat/a-chtgke.adb, libgnat/a-cidlli.adb,
+ libgnat/a-cihama.adb, libgnat/a-cihase.adb,
+ libgnat/a-cimutr.adb, libgnat/a-ciorma.adb,
+ libgnat/a-ciorse.adb, libgnat/a-cobove.adb,
+ libgnat/a-cohama.adb, libgnat/a-cohase.adb,
+ libgnat/a-coinve.adb, libgnat/a-comutr.adb,
+ libgnat/a-convec.adb, libgnat/a-coorma.adb,
+ libgnat/a-coorse.adb, libgnat/a-crbtgk.adb,
+ libgnat/a-crbtgo.adb, libgnat/a-rbtgso.adb: Move tampering
+ checks earlier.
+
+2020-06-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_attr.adb (Get_Integer_Type): Use standard types without
+ a specific size.
+ * sem_res.adb (Resolve_Unchecked_Type_Conversion): Remove a
+ redundant intermediate conversion to Universal_Integer.
+
+2020-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Get_Iterable_Type_Primitive): Fix
+ comment and enforce it with an assertion in the body.
+
+2020-06-17 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Analyze_Full_Type_Declaration): For an
+ access_to_subprogram declaration that has aspect specifications,
+ call Build_Access_ Subprogram_Wrapper at once, so that pre- and
+ postcondition aspects are analyzed in the context of a
+ subprogram declaration.
+ (Build_Access_Subprogram_Wrapper): Examine aspect specifications
+ of an Access_To_Subprogram declaration. If pre- or
+ postconditions are declared for it, create declaration for
+ subprogram wrapper and add the corresponding aspect
+ specifications to it. Replace occurrences of the type name by
+ that of the generated subprogram, so that attributes 'Old and
+ 'Result can appear in a postcondition.
+ * exp_ch3.adb (Build_Access_Subprogram_Wrapper_Body): Moved
+ here from sem_prag.adb.
+ * exp_ch3.ads (Build_Access_Subprogram_Wrapper_Body): Visible
+ subprogram.
+ * sem_prag.adb (Build_Access_Subprogram_Wrapper / _Body): Moved
+ to sem_ch3.adb and exp_ch3.adb.
+
+2020-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * atree.adb (Preserve_Comes_From_Source): Rewrite using
+ Set_Comes_From_Source and Comes_From_Source, which enforce that
+ the parameters are valid.
+ * exp_ch4.adb, exp_ch5.adb, sem_ch12.adb, sem_ch6.adb,
+ sem_res.adb: Rewrite using Preserve_Comes_From_Source.
+
+2020-06-17 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-nbnbin.ads, libgnat/a-nbnbre.ads: Remove obsolete
+ comments.
+
+2020-06-17 Gary Dismukes <dismukes@adacore.com>
+
+ * aspects.ads (type Aspect_Id): Add Aspect_Static as a Boolean
+ aspect, and update the Is_Representation_Aspect, Aspect_Names,
+ and Aspect_Delay arrays.
+ * exp_ch6.adb (Expand_Simple_Function_Return): In the case of a
+ return for a static expression function, capture a copy of the
+ expression of the return statement before it's expanded and
+ reset its Analyzed flags. Then, just before leaving this
+ procedure, if the expression was rewritten, set the
+ Original_Node of the rewritten expression to the new copy and
+ also set the Expression of the associated static expression
+ function to designate that copy. This ensures that later copies
+ of the expression made via New_Copy_Tree will fully copy all
+ nodes of the expression tree.
+ * inline.ads (Inline_Static_Expression_Function_Call): New
+ procedure to evaluate and produce the result of a static call to
+ a static expression function.
+ * inline.adb: Add with and use for Sem_Res.
+ (Establish_Actual_Mapping_For_Inlined_Call): New procedure
+ extracted from code in Expand_Inlined_Call that traverses the
+ actuals and formals of an inlined call and in some cases creates
+ temporaries for holding the actuals, plus establishes an
+ association between formals and actuals (via the Renamed_Object
+ fields of the formals).
+ (Formal_Is_Used_Once): Function removed from Expand_Inlined_Call
+ and now nested in the above procedure.
+ (Expand_Inlined_Call): Code for doing the formal/actual
+ traversal is moved to Create_Actual_Temporaries and replaced
+ with a call to that new procedure.
+ (Inline_Static_Expression_Function_Call): New procedure to
+ evaluate a static call to a static expression function,
+ substituting actuals for their corresponding formals and
+ producing a fully folded and static result expression. The
+ function has subsidiary functions Replace_Formal and Reset_Sloc
+ that take care of doing the mapping of formals to actuals and
+ resetting the Slocs of subnodes of the mapped expression to that
+ of the call so errors will be flagged on the call rather than
+ function.
+ * sem_ch6.adb (Analyze_Expression_Function): In the case of a
+ static expression function, perform an additional preanalysis of
+ the function's expression to ensure that it's a potentially
+ static expression (according to the requirements of
+ 6.8(3.2/5-3.4/5)), and issue an error if it's not. The global
+ flag Checking_Potentially_Static_Expression is set and unset
+ around this checking.
+ * sem_ch13.adb (Analyze_Aspect_Static): New procedure to enforce
+ selected requirements of the new aspect Static on expression
+ functions, including checking that the language version is
+ Ada_2020 and that the entity to which it applies is an
+ expression function whose formal parameters are of a static
+ subtype and have mode 'in', its result subtype is a static
+ subtype, and it has no pre- or postcondition aspects. A ???
+ comment is added to indicate the need for adding checking that
+ type invariants don't apply to the result type if the function
+ is a boundary entity.
+ (Analyze_One_Aspect): Call Analyze_Aspect_Static for aspect
+ Static.
+ * sem_elab.adb (Build_Call_Marker): Return without creating a
+ call marker when the subprogram is a static expression function,
+ since no ABE checking is needed for such functions.
+ * sem_eval.ads (Checking_Potentially_Static_Expression): New
+ function to return whether the checking for potentially static
+ expressions is enabled.
+ (Set_Checking_Potentially_Static_Expression): New procedure to
+ enable or disable checking of potentially static expressions.
+ * sem_eval.adb (Checking_For_Potentially_Static_Expression): New
+ global flag for determining whether preanalysis of potentially
+ static expression is being done, which affects the behavior of
+ certain static evaluation routines.
+ (Checking_Potentially_Static_Expression): New function to return
+ whether the checking for potentially static expressions is
+ enabled.
+ (Eval_Call): When evaluating a call within a static expression
+ function with checking of potentially static expression
+ functions enabled, substitutes a static value in place of the
+ call to allow folding of the expression.
+ (Eval_Entity_Name): When evaluating a formal parameter of a
+ static expression function with checking of potentially static
+ expression functions enabled, substitutes a static value in
+ place of the reference to the formal to allow folding of the
+ expression.
+ (Set_Checking_Potentially_Static_Expression): New procedure to
+ enable or disable checking of potentially static expressions.
+ * sem_res.adb (Resolve_Call): Test for a recursive call
+ occurring within a static expression function and issue an error
+ for such a call. Prevent the establishment of a transient scope
+ in the case this is a call to a (string-returning) static
+ expression function. When calling a static expression function,
+ if no error has been posted on the function, call
+ Inline_Static_Expression_Function_Call to convert the call into
+ its equivalent static value.
+ * sem_util.ads (Is_Static_Expression_Function): New function
+ returning whether the subprogram entity passed to it is a static
+ expression function.
+ (Is_Static_Expression_Function_Call): New function to determine
+ whether the call node passed to it is a static call to a static
+ expression function.
+ * sem_util.adb (Compile_Time_Constraint_Error): Suppress
+ compile-time Constraint_Error reporting when checking for a
+ potentially static expression.
+ (Is_Static_Expression_Function): New function returning whether
+ the subprogram entity passed to it is a static expression
+ function by testing for the presence of aspect Static.
+ (Has_All_Static_Actuals): New function in
+ Is_Static_Expression_Function_Call that traverses the actual
+ parameters of a function call and returns True only when all of
+ the actuals are given by static expressions. In the case of a
+ string-returning function, we call Resolve on each actual to
+ ensure that their Is_Static_Expression flag properly reflects
+ whether they're static, to allow suppressing creation of a
+ transient scope within Resolve_Call. A prominent ??? comment is
+ added to explain this rather unconventional call to Resolve.
+ (Is_Static_Expression_Function_Call): New function that
+ determines whether a node passed to it is a call to a static
+ expression function all of whose actual parameters are given by
+ static expressions.
+
+2020-06-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Optimize_Length_Comparison): New local variable to
+ record whether this may be a dynamic superflat case.
+ (Is_Optimizable): Accept 0 as lower bound and set it in this case,
+ but return false if the operand is not a length too.
+ (Rewrite_For_Equal_Lengths): New procedure.
+ Optimize the comparison of two lengths in the superflat case when
+ the arrays have the same bounds.
+
+2020-06-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_attributes.rst (Bit): Sharpen
+ the comparison with System.Storage_Unit.
+ (Descriptor_Size): Clear confusion about alignment and padding.
+ * gnat_rm.texi: Regenerate.
+
+2020-06-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference) <Attribute_First>:
+ Do not replace the bound for an array type if it is public.
+
+2020-06-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Optimize_Length_Comparison): Make sure the base
+ types are the same when comparing Y'Last and X'Last directly.
+
+2020-06-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference) <Attribute_First>:
+ Replace it with a direct reference to an entity which is not a
+ discriminant for constrained array types. Add same condition
+ for scalar types.
+ <Attribute_Last>: Merge with above implementation.
+ * exp_ch4.adb (Optimize_Length_Comparison): Be prepared for a
+ second entity whose length is compared. Rename Prepare_64 to
+ Convert_To_Long_Long_Integer. If the second entity is present,
+ compute the difference of the 'First attributes and compare the
+ sum of 'Last of the second entity with this difference against
+ 'Last of the first entity. Add a special case when the 'First
+ attributes are equal. Suppress overflow checks in all cases.
+
+2020-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_pragmas.rst, lib-writ.ads,
+ par-prag.adb, sem_ch12.adb, sem_ch8.adb, sem_prag.adb: Fix
+ casing of GNATprove.
+ * gnat_rm.texi: Regenerate.
+
+2020-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * checks.adb (Generate_Range_Check): Simplify redundant
+ condition.
+ * sem_ch3.adb (Check_Initialization, Process_Discriminants):
+ Likewise.
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Likewise.
+
+2020-06-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_fixd.adb (Build_Conversion): Also preserve the
+ Conversion_OK flag of an inner conversion.
+
+2020-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch5.adb (Analyze_Iterator_Specification): Enable expansion
+ that creates a renaming that removes side effects from the
+ iterated object in the GNATprove mode; then analyze reference to
+ this renaming (it is required for GNATprove and harmless for
+ GNAT).
+
+2020-06-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sinfo.ads (Conversion_OK): Document use for 'Pos and 'Val.
+ * exp_attr.adb (Get_Integer_Type): New function returning a
+ small integer type appropriate for an enumeration type.
+ (Expand_N_Attribute_Reference) <Attribute_Enum_Rep>: Call it.
+ <Attribute_Pos>: For an enumeration type with a standard
+ representation, expand to a conversion with Conversion_OK.
+ <Attribute_Val>: Likewise.
+ * exp_ch4.adb (Expand_N_Type_Conversion): Do not expand when
+ the target is an enumeration type and Conversion_OK is set.
+
+2020-06-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch4.adb (Common_Type): Go to Underlying_Full_View, if any.
+
+2020-06-16 Richard Kenner <kenner@adacore.com>
+
+ * exp_unst.adb (Subp_Index): Change way we detect internal
+ protected subprograms.
+
+2020-06-16 Richard Kenner <kenner@adacore.com>
+
+ * comperr.adb (Compiler_Abort): Clarify message displayed to
+ customers.
+
+2020-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * checks.adb, doc/gnat_ugn/the_gnat_compilation_model.rst,
+ einfo.ads, exp_ch5.adb, exp_ch7.adb, lib-xref.ads,
+ libgnat/g-spitbo.ads, make.adb, sem_aux.adb, sem_ch3.adb,
+ sem_ch4.adb, sem_ch5.adb, urealp.adb: Fix wrong casing.
+ * gnat_ugn.texi: Regenerate.
+
+2020-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * einfo.adb, exp_spark.adb, exp_util.adb, sem_eval.adb: Replace
+ "Ekind ... in Object_Kind" with "Is_Object (...)".
+
+2020-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Fix typo in
+ comment.
+
+2020-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_util.adb (Evaluate_Name): Force evaluation of aggregates;
+ recursively evaluate expression of a qualified expression; fix
+ location of the comment for an attribute referenced and an
+ indexed component.
+
+2020-06-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * freeze.adb (Freeze_Expression): Use consistent style and
+ formatting in a couple of cases.
+
+2020-06-16 Steve Baird <baird@adacore.com>
+
+ * libgnat/a-nbnbin.ads, libgnat/a-nbnbre.ads: Uncomment the
+ commented-out Integer_Literal aspect specification for type
+ Big_Integer.
+
+2020-06-16 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch6.adb (BIP_Suffix_Kind, Check_BIP_Actuals,
+ Is_Build_In_Place_Entity): New subprograms.
+ (Make_Build_In_Place_Call_In_Allocator,
+ Make_Build_In_Place_Call_In_Anonymous_Context,
+ Make_Build_In_Place_Call_In_Assignment,
+ Make_Build_In_Place_Call_In_Object_Declaration): Add assertions.
+ (Needs_BIP_Task_Actuals): Add missing support for thunks.
+ (Expand_Actuals): Ensure that the BIP call has available an
+ activation chain and the _master variable.
+ * exp_ch9.adb (Find_Enclosing_Context): Initialize the list of
+ declarations of empty blocks when the _master variable must be
+ declared and the list was not available.
+
+2020-06-16 Bob Duff <duff@adacore.com>
+
+ * par-ch4.adb (P_Case_Expression): Move to be local.
+ (P_Declare_Expression): New parsing routine.
+ (P_Unparen_Cond_Expr_Etc): New name for
+ P_Unparen_Cond_Case_Quant_Expression which was missing one case
+ in its name (iterated component association), and we're adding a
+ new case (declare expression), so lets use "Etc" instead of
+ trying to pack all those things into the name. Add call to
+ P_Declare_Expression, and check for missing parens.
+ (P_Expression_If_OK, P_Expression_Or_Range_Attribute_If_OK): Add
+ Tok_Declare.
+ * par.adb (P_Basic_Declarative_Items): Add parameter
+ Declare_Expression so we can tailor the error message about
+ incorrect bodies.
+ (P_Case_Expression): Move to body.
+ * par-ch3.adb (P_Basic_Declarative_Items): Tailor the error
+ message about incorrect bodies.
+ * par-ch7.adb (P_Package): Pass Declare_Expression => False to
+ P_Basic_Declarative_Items.
+ * sem.ads (In_Declare_Expr): Counter used to determine whether
+ we are analyzing a declare_expression. Needed to give errors
+ about things that are not allowed in declare_expression, such as
+ the 'Access attribute.
+ * sem.adb (Do_Analyze): Save/restore In_Declare_Expr.
+ * sem_ch4.adb (Analyze_Expression_With_Actions): Give this node
+ its own scope. That seems better in general, but it is
+ necessary for declare_expressions. For example, an identifier
+ declared in a declare_expression should not clash with the same
+ identifier in an outer scope. If this is a declare_expression,
+ indicated by Comes_From_Source, then check legality rules, and
+ incr/decr In_Declare_Expr.
+ * sem_aggr.adb (Resolve_Aggregate): Allow an applicable index
+ constraint for a declare_expression, so if its expression is an
+ array aggregate, it can have "others => ...".
+ * sem_attr.adb (Analyze_Access_Attribute): Disallow these
+ attributes in declare_expressions. Add comment to make it clear
+ that Unrestricted_Access is included.
+ * sinfo.ads, sinfo.adb, atree.ads, atree.adb: Remove the
+ now-incorrect comment in sinfo.ads that says
+ N_Expression_With_Actions has no proper scope. Add 17-parameter
+ versions of Nkind_In. Remove the 16-parameter versions of
+ Nkind_In.
+
+2020-06-16 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_aux.ads, sem_aux.adb (Is_Record_Or_Limited_Type): New
+ function.
+ * exp_ch4.adb, sem_ch4.adb (Analyze_Membership_Op,
+ Expand_Set_Membership.Make_Cond): Choose between primitive and
+ predefined equality for membership tests.
+
+2020-06-16 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Simplify code and
+ implement AI12-0216 which clarifies the conditions under which
+ overlapping actuals in a call are illegal. If proper warnings
+ are enabled, GNAT also emits warnings in legal cases of
+ overlopping actuals.
+
+2020-06-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * freeze.adb (Freeze_Expression): Stop climbing the parent chain
+ at a N_{Case,If}_Expression node for a type or an entity that
+ does not come from source.
+
+2020-06-16 Steve Baird <baird@adacore.com>
+
+ * snames.ads-tmpl: Define names of the three new aspects.
+ * aspects.ads: Define the three new aspects.
+ * sem_util.ads, sem_util.adb, sem_dim.adb: Move the function
+ String_From_Numeric_Literal from being declared in the body of
+ package Sem_Dim to being declared in the visible part of package
+ Sem_Util.
+ * sem_ch13.ads, sem_ch13.adb: Declare new visible procedure
+ Validate_Literal_Aspect. This is where most of the legality
+ checking occurs for an aspect specification for one of the three
+ new aspects, as well as resolution of the subprogram named in
+ the aspect specification. Follow example of other aspects (e.g.,
+ Validate_Literal_Aspect is called in much the same way as
+ Validate_Iterable_Aspect in Analyze_Aspects_At_Freeze_Point; a
+ small amount of legality checking is performed in
+ Analyze_One_Aspect in much the same way as for Default_Value or
+ Default_Component_Value aspects). Most of the work is done in
+ Validate_Literal_Aspect.
+ * contracts.adb (Add_Contract_Item): Call
+ Validate_Literal_Aspect in much the same way that
+ Validate_Iterable_Aspect was already being called.
+ * sem_res.adb (Resolve): Rewrite a literal as a call if it is a
+ user-defined literal. This is where the dynamic semantics of
+ the 3 new aspects are implemented.
+ * sem_ch6.adb (Fully_Conformant_Expressions): Two numeric
+ literals that have different text but the same value (e.g.,
+ 12345 and 12_345) do not conform if they are user-defined
+ literals. Introduce a new function
+ User_Defined_Numeric_Literal_Mismatch to avoid duplication in
+ making this check.
+ * sem_type.adb (Has_Compatible_Type): A numeric literal can be
+ compatible with a non-numeric type (and a string literal can be
+ compatible with a non-string type) if it can be interpreted as a
+ user-defined literal.
+
+2020-06-16 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_aggr.adb (Resolve_Extension_Aggregate): Fix implementation
+ of AI05-0115 by checking the correct type.
+
+2020-06-16 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Specification): Generate error
+ message for functions returning interfaces.
+
+2020-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Membership_Entry): Relax assertion to also
+ recognize qualified identifiers.
+
+2020-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_util.adb (Evaluate_Name): Force evaluation of operators.
+
+2020-06-16 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch4.adb (Analyze_Membership_Op): Reset entity of equality
+ nodes for membership tests with singletons.
+ (Analyze_User_Defined_Binary_Op): Always perform the analysis
+ since nodes coming from the expander also may refer to non
+ standard operators as part of membership expansion.
+ * exp_ch4.adb (Expand_Set_Membership.Make_Cond): Reset entity of
+ equality node.
+ * sem_type.ads: Fix typo in comment.
+
+2020-06-16 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Add
+ Check_Not_Incomplete_Type call.
+
+2020-06-16 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch6.adb: Add closing paren in a comment.
+ * sem_util.adb: Correct comment typo (aggreate => aggregate).
+
+2020-06-16 Javier Miranda <miranda@adacore.com>
+
+ * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings):
+ Code cleanup.
+
+2020-06-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * freeze.adb (In_Expanded_Body): Remove unreachable code.
+ (Freeze_Expression): Rename a couple of local variables.
+ In the case of an expanded body, also freeze locally the
+ entities declared in a nested block.
+
+2020-06-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch4.adb (Transform_Object_Operation): Document that it
+ may be partially destructive for the parent of the node.
+ (Try_Object_Operation): Undo the changes made above on failure.
+
+2020-06-16 Javier Miranda <miranda@adacore.com>
+
+ * restrict.adb (Global_No_Tasking): Adding
+ Targparm.Restrictions_On_Target Fixes regressions with zfp.
+
+2020-06-16 Ed Schonberg <schonberg@adacore.com>
+
+ * freeze.adb: (Freeze_Expression, In_Expanded_Body): Treat the
+ generated body of an expression function like other bodies
+ generated during expansion (e.g. stream subprograms) so that
+ those bodies are not treated as freezing points. Handle properly
+ other global references in such completions.
+
+2020-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch8.adb (Analyze_Object_Renaming): Remove trivially
+ useless initialization of Is_Object_Reference.
+ * sem_util.adb (Is_Object_Reference): Simplify detection of
+ binary and unary operators; literally implement rules about
+ aggregates and qualified expressions; recognize string literals
+ as object references.
+
+2020-06-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch12.adb (Validate_Derived_Type_Instance): Reword error
+ message for 12.5.1(8) subclause and add secondary message if
+ the incompatibility comes from the predicates.
+ * sem_ch3.adb (Check_Constraining_Discriminant): New procedure
+ to give the error required by the 3.7(15) subclause. Mention
+ "statically" in the error message and add secondary message
+ if the incompatibility comes from the predicates.
+ (Build_Derived_Concurrent_Type): Call it when a new discriminant
+ constrains an old one.
+ (Build_Derived_Record_Type): Likewise.
+ * sem_eval.ads (Predicates_Compatible): Declare.
+ * sem_eval.adb (Predicates_Compatible): New function to implement
+ the compatibility of predicates specified by the 4.9.1 clause.
+ (Subtypes_Statically_Compatible): Call it.
+
+2020-06-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_eval.ads (Predicates_Match): Fix description.
+ * sem_eval.adb (Predicates_Match): Rewrite.
+
+2020-06-15 Ed Falis <falis@adacore.com>
+
+ * Makefile.rtl: Change name of hie/g-io__vxworks-ppc-cert.adb.
+
+2020-06-15 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch8.adb (Premature_Usage): Add support for subtype
+ references and replace set of if-then-else by a case statement.
+
+2020-06-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Analyze_Depends_In_Decl_Part,
+ Analyze_Global_In_Decl_Part): Bring back task discriminants for
+ analysis of the Global/Depends contracts; add comments.
+
+2020-06-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (Return_Applies_To): Document special usage for E_Block.
+ * einfo.adb (Write_Field8_Name): Write it for E_Block too.
+ * exp_ch4.adb (Expand_N_Type_Conversion): Remove implementation of
+ the check prescribed by AI05-0073.
+ * exp_ch6.adb (Apply_CW_Accessibility_Check): New procedure to apply
+ the check prescribed by AI95-344 extracted from...
+ (Expand_N_Extended_Return_Statement): Apply the check prescribed by
+ AI95-344 to the expression, if present. Suppress only access checks
+ when analyzing the rewritten result.
+ (Expand_Simple_Function_Return): ...here. Rename local variable.
+ Call Apply_CW_Accessibility_Check to apply the check prescribed by
+ AI95-344, but do not do it for the simple return statement generated
+ by the expansion of an extended return statement. Apply the check
+ prescribed by AI05-0073 to all functions returning anonymous access
+ type designating a specific tagged type, but not if the expression
+ was null or tag checks are suppressed for the type, and use Not In
+ operator rather than comparing the tags explicitly.
+ * sem.adb (Analyze): Handle all Suppress values.
+ * sem_ch6.adb (Analyze_Function_Return): Do not explicitly apply
+ predicate checks in the case of an extended return statement.
+ Do not apply an implicit conversion to the anonymous access result
+ type in the case of the simple return statement generated by the
+ expansion of an extended return statement.
+ (New_Overloaded_Entity): Small comment tweak.
+ * treepr.adb (Print_Node): Fix typo in flag string.
+
+2020-06-15 Bob Duff <duff@adacore.com>
+
+ * exp_put_image.ads, exp_put_image.adb
+ (Image_Should_Call_Put_Image): New function to determine whether
+ the call to Put_Image should be generated.
+ (Build_Image_Call): New procedure to generate the call to
+ Put_Image.
+ * exp_imgv.adb (Expand_Image_Attribute): Use underlying types to
+ bypass privacy (only in Ada 2020). If
+ Image_Should_Call_Put_Image is True (which happens only in Ada
+ 2020), then call Build_Image_Call.
+ * rtsfind.ads, rtsfind.adb: Add the necessary declarations in
+ Ada.Strings.Text_Output.Buffers.
+ * sem_attr.adb (Check_Image_Type): Enable the Ada 2020 case.
+ * libgnat/a-stoufo.ads, libgnat/a-stoufo.adb: Use the less
+ restrictive type that allows newline characters.
+
+2020-06-15 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch9.ads (Build_Master_Declaration): Add commas.
+ * exp_ch9.adb (Build_Master_Entity): Spelling fix ("build" =>
+ "built").
+ (Build_Task_Activation_Call): Fix word order.
+
+2020-06-15 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-nbnbin.ads (Big_Positive, Big_Natural): Fix
+ predicate.
+
+2020-06-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Relaxed_Initialization): Fix
+ dealing with scopes on subprogram bodies that act as specs.
+ * sem_util.adb (Has_Relaxed_Initialization): Fix trivial
+ mistake.
+
+2020-06-15 Javier Miranda <miranda@adacore.com>
+
+ * restrict.ads (Set_Global_No_Tasking, Global_No_Tasking): New
+ subprograms.
+ * restrict.adb (Set_Global_No_Tasking, Global_No_Tasking): New
+ subprograms.
+ * sem_ch3.adb (Access_Definition): Do not skip building masters
+ since they may be required for BIP calls.
+ (Analyze_Subtype_Declaration): Propagate attribute
+ Is_Limited_Record in class-wide subtypes and subtypes with
+ cloned subtype attribute; propagate attribute
+ Is_Limited_Interface.
+ * sem_ch6.adb (Check_Anonymous_Return): Do not skip building
+ masters since they may be required for BIP calls. Use
+ Build_Master_Declaration to declare the _master variable.
+ (Create_Extra_Formals): Add decoration of Has_Master_Entity when
+ the _master formal is added.
+ * exp_ch3.adb (Init_Formals): Adding formal to decorate it with
+ attribute Has_Master_Entity when the _master formal is added.
+ (Build_Master): Do not skip building masters since they may be
+ required for BIP calls.
+ (Expand_N_Object_Declaration): Ensure activation chain and
+ master entity for objects initialized with BIP function calls.
+ * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings):
+ Adding support to detect and save restriction No_Tasking when
+ set in the run-time package System or in a global configuration
+ pragmas file.
+ * sem_util.adb (Current_Entity_In_Scope): Overload this
+ subprogram to allow searching for an entity by its Name.
+ * sem_util.ads (Current_Entity_In_Scope): Update comment.
+ * exp_ch4.adb (Expand_N_Allocator): Do not skip building masters
+ since they may be required for BIP calls.
+ * exp_ch6.ads (Might_Have_Tasks): New subprogram.
+ * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Add
+ support for BIP calls returning objects that may have tasks.
+ (Make_Build_In_Place_Call_In_Allocator): Build the activation
+ chain if the result might have tasks.
+ (Make_Build_In_Place_Iface_Call_In_Allocator): Build the class
+ wide master for the result type.
+ (Might_Have_Tasks): New subprogram.
+ (Needs_BIP_Task_Actuals): Returns False when restriction
+ No_Tasking is globally set.
+ * exp_ch9.ads (Build_Master_Declaration): New subprogram.
+ * exp_ch9.adb (Build_Activation_Chain_Entity): No action
+ performed when restriction No_Tasking is globally set.
+ (Build_Class_Wide_Master): No action performed when restriction
+ No_Tasking is globally set; use Build_Master_Declaration to
+ declare the _master variable.
+ (Build_Master_Declaration): New subprogram.
+ (Build_Master_Entity): No action performed when restriction
+ No_Tasking is globally set; added support to handle transient
+ scopes and _finalizer routines.
+ (Build_Master_Renaming): No action performed when restriction
+ No_Tasking is globally set.
+ (Build_Task_Activation_Call): Skip generating the call when
+ the chain is an ignored ghost entity.
+ (Find_Master_Scope): Generalize the code that detects transient
+ scopes with master entity.
+ * einfo.ads (Has_Nested_Subprogram): Minor comment reformatting.
+
+2020-06-15 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_attr.adb (Eval_Attribute): Protect against previous
+ errors.
+ * sem_ch13.adb (Analyze_Aspect_Default_Value): Remove redundant
+ error checking, handling in Analyze_Aspect_Specifications.
+ (Analyze_Aspect_Specifications): Refine error messages on
+ Default_[Component_]Value.
+ (Check_Aspect_Too_Late): New procedure.
+ (Rep_Item_Too_Late.Is_Derived_Type_With_Constraint): Remove,
+ dead code.
+ * aspects.ads (Is_Representation_Aspect): Default_Value is a
+ representation aspect.
+
+2020-06-15 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-wichha.ads, libgnat/a-wichha.adb,
+ libgnat/a-wichun.ads, libgnat/a-wichun.adb (Is_Basic, To_Basic):
+ New.
+ * libgnat/s-utf_32.ads, libgnat/s-utf_32.adb (Is_UTF_32_Basic,
+ To_UTF_32_Basic, Decomposition_Search): New subprograms.
+ (Unicode_Decomposition): New table.
+
+2020-06-15 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch6.adb (Add_Call_By_Copy_Code): In the case of a view
+ conversion passed to a scalar out-mode parameter where the
+ formal has Default_Value set, declare the copy temp with the
+ base type of the formal's subtype and initialize the copy temp
+ with the actual's value.
+
+2020-06-15 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Case_Expression): Set default value for
+ Target to silence potential warnings.
+ (Expand_N_If_Expression): Add calculation to check when the if
+ expression is used directly in the context of an actual of an
+ anonymous access type and add a special path to force expansion
+ of the if expression in this case.
+ * exp_ch6.adb (Expand_Branch): Generate an assignment to the
+ level temporary for a given branch.
+ (Expand_Call_Helper): Add expansion to allow for creating a
+ temporary to store associated accessiblity levels on each branch
+ of the conditional expression. Also perform expansion of
+ function calls into expressions with actions, and fixup
+ references to N with Call_Node.
+ (Insert_Level_Assign): Move through nested conditional
+ expressions to each branch.
+ * sem_util.ads, sem_util.adb (Is_Anonymous_Access_Actual): Added
+ to detect when to force expansion of if expressions.
+
+2020-06-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Analyze_Depends_In_Decl_Part,
+ Analyze_Global_In_Decl_Part): Do not install task discriminants
+ for analysis of the Global/Depends contracts.
+
+2020-06-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * contracts.adb (Analyze_Object_Contract): Do not expect
+ Global/Depends on single protected units.
+
+2020-06-15 Justin Squirek <squirek@adacore.com>
+
+ * sem_res.adb (Valid_Conversion): Add missing condition to
+ trigger proper static accessiblity failiures when the target
+ type is an anonymous access.
+
+2020-06-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch6.adb (Expand_Call_Helper): Replace repeated Ekind with
+ Ekind_In.
+
+2020-06-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch6.adb, sem_util.adb: Remove excessive parents,
+ especially since they don't make the code any easier to read.
+
+2020-06-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * aspects.ads (Aspect_Id): Add Aspect_Relaxed_Initialization.
+ (Implementation_Defined_Aspect): Add new aspect.
+ (Aspect_Argument): Add new aspect with Optional_Expression
+ argument.
+ (Is_Representation_Aspect): Add new aspect as a
+ non-representation one.
+ (Aspect_Names): Add name for the new aspect.
+ (Aspect_Delay): Add new aspect as a non-delayed one.
+ * sem_ch3.adb: Minor reformatting.
+ * einfo.ads, einfo.adb (Is_Relaxed_Initialization_State): New
+ query; reuses existing code for querying abstract state options.
+ * exp_attr.adb (Expand_N_Attribute_Reference): For now ignore
+ attribute 'Initialized.
+ * sem_attr.adb (Analyze_Attribute_Old_Result): Allow attribute
+ 'Result to be used in the aspect Relaxed_Initialization
+ expression.
+ (Analyze_Attribute): Analyze attribute 'Initialized; based on
+ existing code for attribute 'Valid_Scalars.
+ (Eval_Attribute): Do not expect attribute 'Initialized, just
+ like attribute 'Valid_Scalars is not expected.
+ * sem_ch13.adb (Analyze_Aspect_Relaxed_Initialization): New
+ routine.
+ (Analyze_Aspect_Specifications): Analyze new aspect in a
+ dedicated routine.
+ (Check_Aspect_At_Freeze_Point): Do not expect new aspect.
+ * sem_prag.adb (Analyze_Abstract_State): Support option
+ Relaxed_Initialization on abstract states.
+ * sem_util.ads, sem_util.adb (Has_Relaxed_Initialization): New
+ query for the GNATprove backend.
+ * snames.ads-tmpl (Snames): Add Name_Ids for the new aspect and
+ attribute; add an Attribute_Id for the new attribute.
+
+2020-06-15 Bob Duff <duff@adacore.com>
+
+ * exp_put_image.adb, libgnat/s-putima.adb, libgnat/s-putima.ads,
+ rtsfind.ads: Enable Put_Image if Is_Access_Subprogram_Type (Typ).
+ Remove comment saying it's disabled in that case. Rename
+ Put_Image_Access_Prot to be Put_Image_Access_Prot_Subp to
+ clarify that we're talking about access-to-subprogram, not
+ access-to-protected-object.
+
+2020-06-15 Bob Duff <duff@adacore.com>
+
+ * sem_attr.adb (Check_Image_Type): New procedure for checking
+ the type, depending on language version. Disable the Ada 2020
+ support until the corresponding expander work is done.
+ (Analyze_Image_Attribute): Call Check_Image_Type. Rearrange the
+ code to be simplier and more logical. When P_Type is modified,
+ modify P_Base_Type accordingly.
+ * sem_util.adb (Is_Object_Image): Do not return False if the
+ prefix is a type. X'Image should be considered an image of an
+ object iff X is an object (albeit illegal pre-2020 if
+ nonscalar).
+
+2020-06-15 Bob Duff <duff@adacore.com>
+
+ * libgnat/s-putima.ads, libgnat/s-putima.adb
+ (Put_Image_Access_Subp, Put_Image_Access_Prot): New procedures
+ for printing access-to-subprogram objects. Remove an explicit
+ " ", because Put_Image includes the annoying leading blank.
+ * rtsfind.ads: Add new procedures in s-putima.
+ * exp_put_image.adb: Call new procedures as appropriate.
+
+2020-06-15 Bob Duff <duff@adacore.com>
+
+ * exp_imgv.adb (Expand_Image_Attribute): Allow private types.
+ Put_Image generates Image for numeric types, and private types
+ whose full type is numeric. This requires the Conversion_OK flag
+ for integer and floating-point types. For fixed point, we need
+ the extra conversion.
+ * exp_put_image.adb (Build_Elementary_Put_Image_Call): Remove
+ special handling of real types.
+ (Enable_Put_Image): Enable for reals.
+
+2020-06-15 Bob Duff <duff@adacore.com>
+
+ * exp_attr.adb (Put_Image): Use underlying type for strings.
+ Remove unchecked union processing.
+ * exp_put_image.adb (Tagged_Put_Image_Enabled): Use -gnatd_z to
+ enable default Put_Image for tagged types. This allows testing
+ that feature.
+ (Build_String_Put_Image_Call): Set Conversion_OK flag.
+ (Make_Component_List_Attributes): Remove unchecked union
+ processing.
+ (Enable_Put_Image): Disable for unchecked unions. Enable for
+ nonscalar types (which were mistakenly disabled in earlier
+ changes).
+ * debug.adb: Document -gnatd_z switch.
+ * libgnat/s-putima.adb (Put_Image_String, Put_Image_Wide_String,
+ Put_Image_Wide_Wide_String): Double double-quote characters.
+ Forget about special handling of control characters for now --
+ that's rare enough to not be a priority, and it's not clear what
+ the right thing to do is anyway.
+ * namet.adb: Minor: Improve debugger-friendliness.
+ * sinfo.ads: Minor: Add "???" comment.
+
+2020-06-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Is_Renaming_Declaration): Remove.
+
+2020-06-15 Ed Schonberg <schonberg@adacore.com>
+
+ * freeze.adb (Freeze_Expression): When traversing the tree
+ looking for the proper insertion point for the freeze node of an
+ entity that is declared in an outer scope, set the candidate
+ subprogram body node properly. Previous code has an off-by-one
+ error.
+
+2020-06-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference) <Has_Same_Storage>:
+ Do not do superfluous work. Add the condition (X'Size /= 0) on
+ both paths and turn binary AND into short-circuit AND THEN.
+
+2020-06-15 Steve Baird <baird@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): In the Loop_Entry case,
+ replace a call to Statically_Denotes_Object with a call to
+ Statically_Names_Object and clean up the preceding comment.
+
+2020-06-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_res.adb (Resolve_Set_Membership): Remove local variable.
+ In the non-overloaded case, call Intersect_Types on the left
+ operand and the first alternative to get the resolution type.
+ But test the subtype of the left operand to give the warning.
+
+2020-06-12 Steve Baird <baird@adacore.com>
+
+ * sem_res.adb (Valid_Conversion): The simpler cases of
+ violations of the aforementioned 8.6 rule are already handled
+ correctly. These include cases where the operand of the type
+ conversion is an access parameter or a stand-alone object of an
+ anonymous access type. Add code to detect violations where the
+ operand of the type conversion is an access discriminant whose
+ accessibility level is tied to one of the other simpler cases.
+ This is implemented in a new function,
+ Valid_Conversion.Is_Discrim_Of_Bad_Access_Conversion_Argument,
+ which is called in place of the previous test.
+
+2020-06-12 Bob Duff <duff@adacore.com>
+
+ * exp_attr.adb (Put_Image): Remove assertion. This assertion is
+ False in mixed-Ada-version programs.
+ * exp_put_image.adb (Tagged_Put_Image_Enabled): New flag to make
+ it easy to experiment with Put_Image on tagged types. False in
+ this version.
+ (Enable_Put_Image): Enable in pre-2020. Workarounds: Disable
+ for tagged types if Tagged_Put_Image_Enabled is False. Disable
+ for access-to-subprogram types. Disable if errors have been
+ detected, or Sink is unavailable.
+ (Preload_Sink): Move all conditionals here, from Sem_Ch10, so
+ they can be nearby related code in Enable_Put_Image. Load Sink
+ only if we have seen a tagged type. This removes the dilemma
+ about calling Preload_Sink when compiling the compiler, which
+ caused unwanted dependences.
+ * exp_put_image.ads (Preload_Sink): New formal Compilation_Unit,
+ needed to move all conditionals here, from Sem_Ch10.
+ * libgnat/a-stouut.adb (Put_UTF_8): Make this suitable for
+ inlining, so we don't get warnings about inlining in some tests.
+ And so it can be inlined!
+ * opt.ads (Tagged_Seen): New flag (see Preload_Sink).
+ * scng.adb (Scan): Set new Tagged_Seen flag.
+ * sem_ch10.adb (Analyze_Compilation_Unit): Move conditionals and
+ comments regarding Preload_Sink into Preload_Sink.
+
+2020-06-12 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_res.adb (Resolve_Actuals): Check for AI12-0074.
+
+2020-06-12 Olivier Hainque <hainque@adacore.com>
+
+ * libgnat/s-secsta.ads (Memory_Alignment): New constant, memory
+ alignment for chunks and allocated blocks. Initialize to
+ Standard'Maximum_Alignment * 2.
+ (Chunk_Memory): Use it.
+ * libgnat/s-secsta.adb (Round_Up): Likewise.
+
+2020-06-12 Piotr Trojanek <trojanek@adacore.com>
+
+ * par-prag.adb: Fix ordering.
+ * snames.ads-tmpl (Name_Test_Case, Pragma_Test_Case): Likewise.
+ * sem_prag.adb (Sig_Flags): Likewise.
+
+2020-06-12 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_res.adb (Resolve_Entity_Name): Fix handling of expressions
+ containing array attributes wrt Ada 83 detection.
+
+2020-06-12 Steve Baird <baird@adacore.com>
+
+ * sem_util.ads, sem_util.adb: Define 3 new Boolean-valued
+ functions - Statically_Denotes_Entity,
+ Statically_Denotes_Object, and Statically_Names_Object. The
+ first two were taken from sem_attr.adb. The term "statically
+ names" is defined in the Ada RM and the new function
+ Statically_Names_Object is intended to reflect that definition,
+ or more precisely, as described in a comment in the code, to
+ reflect the expected future definition of that term.
+ * sem_attr.adb: Delete functions Statically_Denotes_Object and
+ Statically_Denotes_Entity; these two functions have been moved
+ to package Sem_Util. Replace call to Statically_Denotes_Object
+ with a call to Statically_Names_Object as per AI12-0217 (a
+ binding interpretation, so no Ada_Version check).
+ * exp_ch9.adb (Expand_Entry_Barrier.Is_Simple_Barrier): Change
+ name of function (it was previously Is_Simple_Barrier_Name)
+ because the function should return True in the case of a static
+ expression; implement this requirement. Change function to
+ include a call to Statically_Names_Object so that, for Ada_2020
+ and later, it will return True for appropriate subcomponent
+ names.
+ (Expand_Entry_Barrier.Is_Pure_Barrier): Handle
+ N_Indexed_Component and N_Selected_Component cases by calling
+ Statically_Names_Object.
+ (Expand_Entry_Barrier): Reorganize to treat Simple_Barriers and
+ Pure_Barriers more uniformly. Prevent cascaded errors.
+
+2020-06-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Find_Matching_Actual): Add guard on search loops
+ to detect a compilation error when using a compiler built
+ without assertions.
+ (Instantiate_Formal_Subprogram): Create a new subprogram name
+ for the actual only if formal has contract aspects and expansion
+ is enabled.
+
+2020-06-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_aggr.adb: Add with and use clauses for Sem_Mech.
+ (Get_Base_Object): New function to get the base object of a node.
+ (In_Place_Assign_OK): Add Target_Object parameter. Deal with a
+ qualified expression on entry. Remove short-circuit for array
+ aggregates with a single "others" choice. Do not look into the
+ components of the aggregate if the parent is an allocator.
+ (Check_Component): Add T_OK parameter and rewrite.
+ (Safe_Component): Invoke Check_Component with T_OK set to False.
+ (Convert_To_Assignments): Try to use an in-place assignment for
+ any target; for that, call Get_Base_Object on the target and pass
+ the result to In_Place_Assign_OK.
+ (Expand_Array_Aggregate): Use Parent_Kind and Parent_Node more
+ consistently. For an assignment, call Get_Base_Object on the
+ target and pass the result to In_Place_Assign_OK.
+
+2020-06-12 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * socket.c (__gnat_minus_500ms): Use GetVersionEx to detect
+ Windows Server version.
+ * libgnat/g-sothco.ads (Minus_500ms_Windows_Timeout): Remade to
+ Boolean constant.
+ * libgnat/g-socket.adb (Set_Socket_Option): Use
+ Minus_500ms_Windows_Timeout constant instead of function call.
+
+2020-06-12 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-coinho.ads, libgnat/a-coinho.adb,
+ libgnat/a-coinho__shared.ads, libgnat/a-coinho__shared.adb
+ (Swap): New procedure.
+
+2020-06-12 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch6.adb (Expand_N_Subprogram_Declaration): Do nothing for
+ a subprogram declared in a protected body.
+ * exp_ch9.ads, exp_ch9.adb
+ (Build_Private_Protected_Declaration): Moved to sem_ch6.adb.
+ (Expand_N_Protected_Body): Do nothing for a subprogram declared
+ in a protected body.
+ * sem_ch6.adb (Build_Internal_Protected_Declaration): Moved from
+ exp_ch9.adb and renamed and fixed to ensure in particular that
+ such subprograms have convention Intrinsic and have no protected
+ version.
+ (Analyze_Subprogram_Body_Helper): Call
+ Build_Internal_Protected_Declaration.
+ (Move_Pragmas): Moved up and merged with the more general
+ version from Build_Private_Protected_Declaration. We only want
+ to copy selected pragmas, most pragmas are not suitable for a
+ copy on the spec.
+
+2020-06-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Check_Overriding_Indicatior): Reject an
+ overriding indicator on a subprogram declared within a protected
+ body.
+
+2020-06-12 Piotr Trojanek <trojanek@adacore.com>
+
+ * contracts.adb, einfo.adb, sem_ch4.adb, sem_ch6.adb,
+ sem_res.adb, sem_util.adb: Replace Ekind_In with Is_Entry.
+
+2020-06-12 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_res.adb (Resolve_Entry_Call): Add call to
+ Warn_On_Overlapping_Actuals.
+
+2020-06-12 Arnaud Charlet <charlet@adacore.com>
+
+ * aspects.ads (Is_Representation_Aspect): New array.
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Check
+ 13.1(9.2/5) for representation aspects.
+
+2020-06-12 Bob Duff <duff@adacore.com>
+
+ * exp_put_image.ads, exp_put_image.adb (Preload_Sink): Procedure
+ for preloading type Sink. This has the side effect of loading
+ various dependents, including Ada.Strings.UTF_Encoding.
+ (Enable_Put_Image): Disable Put_Image in pre-2020 versions of
+ Ada. This limitation can probably be lifted later. Enable for
+ tagged types except in predefined units. Disable for CPP types;
+ Put_Image is legal, just prints the type name.
+ * sem_attr.adb (Check_Put_Image_Attribute): Don't complain about
+ Put_Image of CPP types; instead call the "unknown" version of
+ Put_Image.
+ * sem_ch10.adb (Analyze_Compilation_Unit): Call Preload_Sink.
+
+2020-06-12 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Simplify.
+
+2020-06-12 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Remove suppression
+ for internal units.
+
+2020-06-12 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_strm.adb (Build_Elementary_Input_Call): Add support for 24
+ bits elementary types.
+ * rtsfind.ads: Add 24 bits integer streaming routines.
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause
+ [Attribute_Stream_Size]): Add support for 24 bits elementary
+ types.
+ * libgnat/s-stratt.ads, libgnat/s-stratt.adb,
+ libgnat/s-stratt__xdr.adb: Add support for signed and unsigned
+ 24 bits integers.
+
+2020-06-12 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch3.adb (Get_Discr_Value): Cleanup.
+
+2020-06-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * rtsfind.ads (RTU_Id): Add System_Address_To_Access_Conversions.
+ * sem_elab.adb (Elaboration_Phase_Active): Alphabetize.
+ (Finalize_All_Data_Structures): Likewise.
+ (Error_Preelaborated_Call): New procedure.
+ (Build_Call_Marker): Set Is_Preelaborable_Call flag in marker.
+ (Build_Access_Marker): Likewise.
+ (Build_Subprogram_Invocation): Likewise.
+ (Build_Task_Activation): Likewise.
+ (Check_Preelaborated_Call): Return when the call is preelaborable.
+ Call Error_Preelaborated_Call to give the error otherwise.
+ (Check_Elab_Call): Likewise.
+ * sem_util.adb (Is_Preelaborable_Function): New predicate.
+ (Is_Non_Preelaborable_Construct.Visit): Recurse on the
+ Explicit_Actual_Parameter field of N_Parameter_Association.
+ (Is_Non_Preelaborable_Construct.Visit_Subexpression): In Ada 2020,
+ for a call to a preelaborable function, visit the parameter list;
+ otherwise, raise Non_Preelaborable exception.
+ (Is_Preelaborable_Construct): Likewise, but recursively check the
+ parameters instead and return false upon failure, otherwise true.
+ * sinfo.ads (Is_Preelaborable_Call): New flag in call marker nodes.
+ (Is_Preelaborable_Call): New inline function.
+ (Set_Is_Preelaborable_Call): New inline procedure.
+ * sinfo.adb (Is_Preelaborable_Call): New inline function.
+ (Set_Is_Preelaborable_Call): New inline procedure.
+
+2020-06-12 Bob Duff <duff@adacore.com>
+
+ * stringt.ads: Remove "use System;".
+
+2020-06-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch4.adb (Try_Container_Indexing): Replace call to
+ First_Discriminant by Get_Reference_Discriminant to get the
+ reference discriminant.
+ * sem_ch13.adb (Check_Indexing_Functions): Likewise.
+ * sem_ch5.adb (Preanalyze_Range): Call Get_Reference_Discriminant
+ to get the reference discriminant.
+ * sem_util.adb (Is_OK_Variable_For_Out_Formal): Treat all
+ Ada 2012 implicit dereferences in only one place.
+ (Is_Variable): Minor tweak.
+
+2020-06-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Has_Contracts): New predicate to check whether a
+ formal subprogram carries an aspect specification for a pre- or
+ postcondition.
+ (Build_Subprogram_Wrappers): If actual is overloaded, create a
+ new name to be used in call inside wrapper body. This names
+ carries the interpretations of the actual, and is resolved when
+ the body is analyzed.
+ (Build_Subprogram_Body_Wrapper): Use this generated name in
+ call.
+ (Build_Subprogram_Decl_Wrapper): Build profile of wrapper from
+ the profile of formal, and reset type entities for subsequent
+ analysis.
+
+2020-06-12 Bob Duff <duff@adacore.com>
+
+ * debug.adb: Remove usage of -gnatd_z.
+ * exp_attr.adb, exp_put_image.ads, exp_put_image.adb: Clean up
+ the enable/disable code. If Put_Image is disabled for a type,
+ systematically call the "unknown" version. Improve comments.
+ Consolidate workarounds. Remove usage of -gnatd_z.
+
+2020-06-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_elab.adb: Fix typos in comments.
+
+2020-06-12 Justin Squirek <squirek@adacore.com>
+
+ * sem_util.adb (Object_Access_Level): Add processing of implicit
+ dereferences.
+
+2020-06-12 Bob Duff <duff@adacore.com>
+
+ * libgnat/a-nbnbin.adb, libgnat/a-nbnbin.ads,
+ libgnat/a-nbnbin__gmp.adb, libgnat/a-nbnbre.adb,
+ libgnat/a-nbnbre.ads: Update Put_Image, and uncomment the aspect
+ specification. Add pragmas Ada_2020.
+ * libgnat/a-stouut.ads, libgnat/a-stteou.ads: Add Preelaborate,
+ because the Big_Numbers packages have Preelaborate, and now
+ depend on these Text_Output packages.
+
+2020-06-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (No_Return): Document it for all subprograms.
+ * einfo.adb (Set_No_Return): Adjust assertion accordingly.
+ * sem_ch3.adb (Check_Abstract_Overriding): Implement the
+ check prescribed by RM 6.5.1(6/2) here instead of...
+ (Derive_Subprogram): Adjust comment accordingly.
+ * sem_disp.adb (Override_Dispatching_Operation): ...here.
+ Remove superfluous return statement.
+ * sem_ch6.adb (Check_No_Return_Expression): New procedure.
+ (Analyze_Function_Return): Call it to implement the check
+ prescribed by AI12-0269 for simple return statements of
+ No_Return functions, and also checks extended statements.
+ (Analyze_Return_Statement): Only give an error on a return
+ statement in No_Return procedures. Use idiomatic form.
+ * sem_ch8.adb (Analyze_Subprogram_Renaming): Adjust error
+ message for No_Return renaming subprogram.
+ * sem_prag.adb (Analyze_Pragma) <Pragma_No_Return>: Accept
+ it on functions and generic functions in Ada 2020.
+
+2020-06-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_res.adb (Resolve_Implicit_Dereference): In an instance,
+ reset the type of the prefix if it is private before building
+ the dereference.
+
+2020-06-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_util.adb (Safe_Unchecked_Type_Conversion): Add missing
+ Is_Type guard before calling Has_Discriminants on Etype.
+
+2020-06-11 Bob Duff <duff@adacore.com>
+
+ * libgnat/a-nbnbin__gmp.adb: There's no Optional_Big_Integer
+ anymore. Invalid_Big_Integer is not used.
+ Greatest_Common_Divisor returns Big_Positive.
+
+2020-06-11 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aggr.adb (Get_Value): Refine type of the Compon parameter.
+
+2020-06-11 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aggr.adb (Resolve_Record_Aggregate): Refine type of
+ Others_Box.
+
+2020-06-11 Piotr Trojanek <trojanek@adacore.com>
+
+ * checks.adb, exp_ch7.adb, exp_ch9.adb, exp_smem.adb, lib.adb,
+ nlists.adb, sem.adb, sem_aggr.adb, sem_ch3.adb, sem_ch6.adb,
+ sem_ch8.adb, sem_dim.adb, sem_res.adb, sem_util.adb,
+ sem_warn.adb: Replace uses of Next function with procedure.
+
+2020-06-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_pakd.ads: Add paragraph about scalar storage order.
+ * exp_pakd.adb (Install_PAT): Do not set the scalar storage
+ order of the PAT here but...
+ (Set_PB_Type): ...here instead and...
+ (Create_Packed_Array_Impl_Type): ...here as well.
+ * rtsfind.ads (RE_Id): Add RE_Rev_Packed_Bytes{1,2,4}.
+ (RE_Unit_Table): Likewise.
+ * libgnat/s-unstyp.ads (Rev_Packed_Bytes1): New derived type.
+ (Rev_Packed_Bytes2): Likewise.
+ (Rev_Packed_Bytes4): Likewise.
+
+2020-06-11 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch4.adb, sem_ch6.adb, sem_res.adb, sem_util.ads: Fix
+ references to SPARK RM 7.1.3 rule numbers.
+
+2020-06-11 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Simplify code,
+ remove inner predicate Is_Covered_Formal, preserve warning for
+ two overlapping composite types when only one is writable, and
+ for two overlapping and writable elementary types.
+
+2020-06-11 Steve Baird <baird@adacore.com>
+
+ * contracts.adb (Add_Contract_Item): Support specifying
+ volatility refinement aspects for types.
+ (Analyze_Contracts): Add call to Analyze_Type_Contract in the
+ case of a contract for a type.
+ (Freeze_Contracts): Add call to Analyze_Type_Contract in the
+ case of a contract for a type.
+ (Check_Type_Or_Object_External_Properties): A new procedure
+ which performs the work that needs to be done for both object
+ declarations and types.
+ (Analyze_Object_Contract): Add a call to
+ Check_Type_Or_Object_External_Properties and remove the code in
+ this procedure which did much of the work that is now performed
+ by that call.
+ (Analyze_Type_Contract): Implement this new routine as nothing
+ more than a call to Check_Type_Or_Object_External_Properties.
+ * contracts.ads: Update comment for Add_Contract_To_Item because
+ types can have contracts. Follow (questionable) precedent and
+ declare new routine Analyze_Type_Contract as visible (following
+ example of Analyze_Object_Contract), despite the fact that it is
+ never called from outside of the package where it is declared.
+ * einfo.adb (Contract, Set_Contract): Id argument can be a type;
+ support this case.
+ (Write_Field34_Name): Field name is "contract" for a type.
+ * einfo.ads: Update comment describing Contract attribute.
+ * sem_ch3.adb (Build_Derived_Numeric_Type): Is_Volatile should
+ return same answer for all subtypes of a given type. Thus, when
+ building the base type for something like type Volatile_1_To_10
+ is range 1 .. 10 with Volatile; that basetype should be marked
+ as being volatile.
+ (Access_Type_Declaration): Add SPARK-specific legality check
+ that the designated type of an access type shall be compatible
+ with respect to volatility with the access type.
+ * sem_ch12.adb (Check_Shared_Variable_Control_Aspects): Add
+ SPARK-specific legality check that an actual type parameter in
+ an instantiation shall be compatible with respect to volatility
+ with the corresponding formal type.
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Perform checks
+ for aspect specs for the 4 volatility refinement aspects that
+ were already being performed for all language-defined aspects.
+ * sem_prag.adb (Analyze_External_Property_In_Decl_Part,
+ Analyze_Pragma): External properties (other than No_Caching) may
+ be specified for a type, including a generic formal type.
+ * sem_util.ads: Declare new subprograms - Async_Readers_Enabled,
+ Async_Writers_Enabled, Effective_Reads, Effective_Writes, and
+ Check_Volatility_Compatibility.
+ * sem_util.adb (Async_Readers_Enabled, Async_Writers_Enabled,
+ Effective_Reads, Effective_Writes): Initial implementation of
+ new functions for querying aspect values.
+ (Check_Volatility_Compatibility): New procedure intended for use
+ in checking all SPARK legality rules of the form "<> shall be
+ compatible with respect to volatility with <>".
+ (Has_Enabled_Property): Update comment because Item_Id can be a
+ type. Change name of nested Variable_Has_Enabled_Property
+ function to Type_Or_Variable_Has_Enabled_Property; add a
+ parameter to that function because recursion may be needed,
+ e.g., in the case of a derived typ). Cope with the case where
+ the argument to Has_Enabled_Property is a type.
+
+2020-06-11 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aggr.adb (Add_Association): Add assertion about the formal
+ parameters.
+ (Propagate_Discriminants): Always add an explicit component
+ association, so that an "others => <>" association is never
+ needed.
+
+2020-06-11 Bob Duff <duff@adacore.com>
+
+ * exp_put_image.adb (Build_Elementary_Put_Image_Call): If the
+ underlying type is real, call Put_Image_Unknown.
+ (Build_Unknown_Put_Image_Call): Pass the type name to
+ Put_Image_Unknown.
+ * libgnat/s-putima.ads, libgnat/s-putima.adb
+ (Put_Image_Unknown): Add Type_Name parameter. Remove
+ overly-detailed documentation of what it does; better to leave
+ it open.
+
+2020-06-11 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch3.adb (Build_Constrained_Array_Type,
+ Build_Constrained_Discriminated_Type): Skip unnecessary loop
+ iterations.
+
+2020-06-11 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aggr.adb (Build_Constrained_Itype): Move to Sem_Util.
+ * sem_ch3.adb (Build_Subtype, Inherit_Predicate_Flags): Move...
+ * sem_util.adb (Build_Subtype): Here. Add parameters for
+ references to objects previously declared in enclosing scopes.
+ (Inherit_Predicate_Flags): And here, because it is called by
+ Build_Subtype.
+ * sem_util.ads (Build_Overriding_Spec): Reorder alphabetically.
+ (Build_Subtype): Moved from Sem_Ch3; comments updated.
+ (Build_Constrained_Itype): Moved from Sem_Aggr; comments
+ updated.
+
+2020-06-11 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aggr.adb (Case_Table_Type): Change index type from Nat to
+ Pos.
+
+2020-06-11 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aggr.adb (Build_Constrained_Itype): Previously a declare
+ block, now a separate procedure; the only change is that now
+ New_Assoc_List might include components and an others clause,
+ which we ignore (while we deal with discriminants exactly as we
+ did before); extend a ??? comment about how this routine is
+ different from the Build_Subtype
+ (Resolve_Record_Aggregate): Create a constrained itype not just
+ for the outermost record aggregate, but for its inner record
+ aggregates as well.
+
+2020-06-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * checks.adb (Build_Discriminant_Checks): Build an explicit
+ dereference when the type is an access type.
+ * exp_atag.adb (Build_CW_Membership): Add explicit dereferences.
+ (Build_Get_Access_Level): Likewise.
+ (Build_Get_Alignment): Likewise.
+ (Build_Inherit_Prims): Likewise.
+ (Build_Get_Transportable): Likewise.
+ (Build_Set_Size_Function): Likewise.
+ * exp_ch3.adb (Build_Offset_To_Top_Function): Likewise.
+ * exp_ch4.adb (Expand_Allocator_Expression): Likewise.
+ (Expand_N_Indexed_Component ): Remove code dealing with implicit
+ dereferences.
+ (Expand_N_Selected_Component): Likewise.
+ (Expand_N_Slice): Likewise.
+ * exp_ch9.adb (Add_Formal_Renamings): Add explicit dereference.
+ (Expand_Accept_Declarations): Likewise.
+ (Build_Simple_Entry_Call): Remove code dealing with implicit
+ dereferences.
+ (Expand_N_Requeue_Statement): Likewise.
+ * exp_disp.adb (Expand_Dispatching_Call): Build an explicit
+ dereference when the controlling type is an access type.
+ * exp_spark.adb (Expand_SPARK_N_Selected_Component): Delete.
+ (Expand_SPARK_N_Slice_Or_Indexed_Component): Likewise.
+ (Expand_SPARK): Do not call them.
+ * sem_ch4.adb (Process_Implicit_Dereference_Prefix): Delete.
+ (Process_Indexed_Component): Call Implicitly_Designated_Type
+ to get the designated type for an implicit dereference.
+ (Analyze_Overloaded_Selected_Component): Do not insert an
+ explicit dereference here.
+ (Analyze_Selected_Component): Likewise.
+ (Analyze_Slice): Call Implicitly_Designated_Type to get the
+ designated type for an implicit dereference.
+ * sem_ch8.adb (Has_Components): New predicate extracted from...
+ (Is_Appropriate_For_Record): ...this. Delete.
+ (Is_Appropriate_For_Entry_Prefix): Likewise.
+ (Analyze_Renamed_Entry): Deal with implicit dereferences.
+ (Find_Selected_Component): Do not insert an explicit dereference
+ here. Call Implicitly_Designated_Type to get the designated type
+ for an implicit dereference. Call Has_Components, Is_Task_Type
+ and Is_Protected_Type directly. Adjust test for error.
+ * sem_res.adb (Resolve_Implicit_Dereference): New procedure.
+ (Resolve_Call): Call Resolve_Indexed_Component last.
+ (Resolve_Entry): Call Resolve_Implicit_Dereference on the prefix.
+ (Resolve_Indexed_Component): Call Implicitly_Designated_Type to
+ get the designated type for an implicit dereference and
+ Resolve_Implicit_Dereference on the prefix at the end.
+ (Resolve_Selected_Component): Likewise.
+ (Resolve_Slice): Likewise. Do not apply access checks here.
+ * sem_util.ads (Implicitly_Designated_Type): Declare.
+ * sem_util.adb (Copy_And_Maybe_Dereference): Simplify.
+ (Implicitly_Designated_Type): New function.
+ (Object_Access_Level): Fix typo.
+ * sem_warn.adb (Check_Unset_Reference): Test Comes_From_Source
+ on the original node.
+
+2020-06-11 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_disp.adb: Minor reformatting.
+ * exp_aggr.adb (Is_Static_Dispatch_Table_Aggregate): Recognize
+ aggregates of the Ada.Tags.Object_Specific_Data type as static.
+ * sem_aggr.adb (Check_Static_Discriminated_Subtype): Deconstruct
+ and do not call it from Build_Constrained_Itype.
+
+2020-06-11 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_disp.adb (Make_Secondary_DT): Internally generated OSD
+ tables are now constant.
+
+2020-06-11 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_aggr.adb (Backend_Processing_Possible): Remove useless
+ call.
+
+2020-06-11 Piotr Trojanek <trojanek@adacore.com>
+
+ * opt.ads (Building_Static_Dispatch_Tables): Fix punctuation in
+ comment.
+
+2020-06-11 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-stposu.ads (Root_Storage_Pool_With_Subpools,
+ Root_Subpool): Mark with Preelaborable_Initialization.
+
+2020-06-11 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch9.adb (Expand_N_Conditional_Entry_Call): Replace call to
+ New_Copy_List by calls to the new routine
+ New_Copy_Separate_List.
+ * sem_util.ads (New_Copy_Separate_List, New_Copy_Separate_Tree):
+ New routines.
+ * sem_util.adb (New_Copy_Separate_List, New_Copy_Separate_Tree):
+ New routines.
+ (New_Copy_Tree): Extend the machinery that detects syntactic
+ nodes to handle lists of indentifiers with field More_Ids;
+ otherwise such nodes are erroneously handled as semantic nodes.
+ Copy aspect specifications attached to nodes.
+ * sem_ch12.adb (Copy_Generic_Node): Protect reading attribute
+ Etype.
+
+2020-06-11 Bob Duff <duff@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Do not set the
+ Has_Predicates flag when the Predicate_Failure aspect is seen.
+ It is legal (but pointless) to use this aspect without a
+ predicate. If we set the flag, we generate a half-baked
+ Predicate procedure, and if that procedure is nested, it causes
+ unnesting to crash.
+
+2020-06-11 Bob Duff <duff@adacore.com>
+
+ * exp_put_image.adb (Build_Record_Put_Image_Procedure): Remove
+ special processing of protected types, because those are handled
+ by Build_Protected_Put_Image_Call.
+ (Enable_Put_Image): Use the switch -gnatd_z to control enabling
+ of Put_Image. Disable Put_Image for types in Remote_Types
+ packages.
+ * debug.adb: Document -gnatd_z switch.
+ * exp_imgv.adb, libgnat/a-stteou.ads, opt.ads: Minor cleanups.
+
+2020-06-11 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Add label to the
+ outer loop and use it in the exit statement.
+
+2020-06-11 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * exp_ch3.adb (Build_Assignment): Generate predicate check if
+ subtype mark has predicate.
+
+2020-06-11 Justin Squirek <squirek@adacore.com>
+
+ * sem_util.adb (Expand_N_Attribute_Reference): Use original
+ nodes where required to avoid looking at the expanded tree.
+
+2020-06-11 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-catizo.ads, libgnat/a-nbnbin.ads,
+ libgnat/a-nbnbre.ads, libgnat/a-nubinu.ads,
+ libgnat/s-aoinar.ads, libgnat/s-aomoar.ads,
+ libgnat/s-aotase.ads, libgnat/s-stopoo.ads: Remove aspects that
+ we will not implement.
+
+2020-06-11 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-aoinar.adb (Atomic_Fetch_And_Add,
+ Atomic_Fetch_And_Subtract): Add fallback using
+ compare-and-exchange, in case the integer type does not map to a
+ machine type.
+
+2020-06-10 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-aomoar.ads, libgnat/s-aomoar.adb: New files.
+ * libgnat/s-atopar.ads: Move...
+ * libgnat/s-aoinar.ads: Here.
+ * libgnat/s-atopar.adb: Move...
+ * libgnat/s-aoinar.adb: Here.
+ * impunit.adb: Update list of runtime files.
+ * Makefile.rtl (GNATRTL_NONTASKING_OBJS=): Adjust.
+
+2020-06-10 Arnaud Charlet <charlet@adacore.com>
+
+ * snames.ads-tmpl (Name_Characters_Assertion_Check,
+ Name_Containers_Assertion_Check,
+ Name_Interfaces_Assertion_Check, Name_IO_Assertion_Check,
+ Name_Numerics_Assertion_Check, Name_Strings_Assertion_Check,
+ Name_System_Assertion_Check): New constants.
+ * types.ads (Characters_Assertion_Check,
+ Containers_Assertion_Check, Interfaces_Assertion_Check,
+ IO_Assertion_Check, Numerics_Assertion_Check,
+ Strings_Assertion_Check, System_Assertion_Check): New constants.
+ (All_Checks): Update accordingly.
+
+2020-06-10 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * exp_ch3.adb (Build_Equivalent_Record_Aggregate): Return Empty
+ if Etype of record component has predicates.
+
+2020-06-10 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch3.adb (Build_Init_Statements): Implement the notion of
+ "require late initialization".
+
+2020-06-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_util.adb (Copy_And_Maybe_Dereference): Temporarily copy
+ the parent node of the original tree when dereferencing.
+
+2020-06-10 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Add a warning when
+ two actuals in a call overlap, both are composite types that may
+ be passed by reference, and only one of them is writable.
+
+2020-06-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Expand_N_In): Use an expression with actions to
+ insert the PE raise statement for the Unchecked_Union case.
+
+2020-06-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch4.adb (Analyze_Call): Use idiomatic condition.
+ * sem_res.adb (Resolve_Call): Remove obsolete code.
+
+2020-06-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_util.adb (Copy_And_Maybe_Dereference): New function.
+ (Build_Access_Record_Constraint): Use it to copy the prefix.
+ (Build_Actual_Array_Constraint): Likewise.
+ (Build_Actual_Record_Constraint): Likewise.
+
+2020-06-10 Bob Duff <duff@adacore.com>
+
+ * sem_prag.adb (Invariant): Remove the pragma removing code. It
+ doesn't work to remove the pragma, because various flags are set
+ during Build_Invariant_Procedure_Declaration and
+ Build_Invariant_Procedure_Body that need to be set to avoid the
+ spurious warnings.
+ * exp_util.adb (Make_Invariant_Call): Avoid calling the
+ invariant-checking procedure if the body is empty. This is an
+ optimization.
+
+2020-06-10 Vasiliy Fofanov <fofanov@adacore.com>
+
+ * doc/gnat_ugn/gnat_utility_programs.rst: Fix gnatmetric
+ switches description.
+
+2020-06-10 Arnaud Charlet <charlet@adacore.com>
+
+ * repinfo-input.ads, repinfo-input.adb, repinfo.adb,
+ repinfo.ads: Update header.
+
+2020-06-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_aggr.adb (In_Place_Assign_OK): Do not necessarily return
+ false for a type with discriminants.
+ (Convert_To_Assignments): Use Parent_Node and Parent_Kind more
+ consistently. In the in-place assignment case, first apply a
+ discriminant check if need be, and be prepared for a rewritten
+ aggregate as a result.
+
+2020-06-10 Arnaud Charlet <charlet@adacore.com>
+
+ * atree.adb, contracts.adb, debug.adb, freeze.adb,
+ repinfo-input.adb, repinfo.adb, sem_attr.adb, sem_ch10.adb,
+ sem_ch13.adb, sem_ch3.adb, sem_ch5.adb, sem_ch6.adb,
+ sem_ch8.adb, sem_ch9.adb, sem_disp.adb, sem_eval.adb,
+ sem_prag.adb: Remove more references to ASIS.
+
+2020-06-10 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-secsta.adb (Round_Up): Fix typo in exception
+ message.
+
+2020-06-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * par-ch4.adb (P_Membership_Test): Fix typo in a grammar rule.
+
+2020-06-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_N_Attribute_Reference): Remove
+ expansion of First and Last attributes.
+
+2020-06-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): Remove folding
+ for Enum_Rep attribute.
+ * exp_spark.adb (Expand_SPARK_N_Attribute_Reference): Remove
+ duplicated code for folding Enum_Rep attribute.
+ * sem_attr.adb (Eval_Attribute): Relax condition for folding
+ Enum_Rep attribute; previously dead code is now executed when
+ the attribute prefix is an enumeration literal; refine type in
+ processing of Enum_Val.
+
+2020-06-10 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch3.adb (Analyze_Declarations): Adjust the machinery that
+ takes care of late body overriding of initialize, adjust,
+ finalize. Remove ASIS mode code.
+
+2020-06-10 Ed Schonberg <schonberg@adacore.com>
+
+ * einfo.ads (Access_Subprogram_Wrapper): New attribute of
+ Subprogram_Type entities. Denotes subprogram constructed for
+ Access_To_Subprogram types that include pre- and postconditions.
+ * einfo.adb: Subprogram bodies for Access_Subprogram_Wrapper.
+ * exp_ch6.adb (Expand_Call): An indirect call through an
+ Access_To_subprogram that includes contracts is rewritten as a
+ call to the corresponding Access_ ubprogram_Wrapper. Handle
+ derived types that inherit contract from parent.
+ * sem_prag.adb (Build_Access_Subprogram_Wrapper): Build
+ subprogram declaration for subprogram that incorporates the
+ contracts of an Access_To_Subprogram type declaration. Build
+ corresponding body and attach it to freeze actions for type.
+ * sem_util.ads, sem_util.adb (Is_Access_Subprogram_Wrapper):
+ Utility that uses signature of the subprogram to determine
+ whether it is a generated wrapper for an Access_To_Subprogram
+ type.
+
+2020-06-10 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * par-ch6.adb (P_Subprogram): Make sure the specification
+ belongs to a procedure.
+
+2020-06-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (All_Membership_Choices_Static): Assert an AST
+ property documented in sinfo.ads and simplify an excessive
+ condition.
+
+2020-06-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): Fix a copy-paste
+ mistake in comment.
+ * sem_res.adb (Flag_Effectively_Volatile_Objects): Fix a type in
+ the SPARK RM rule number.
+ * exp_ch4.adb, sem_util.adb: Fix style in single line comments.
+
+2020-06-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aux.ads, sem_aux.adb (Get_Low_Bound): Remove.
+
+2020-06-10 Arnaud Charlet <charlet@adacore.com>
+
+ * scn.adb (Determine_License): Remove.
+
+2020-06-10 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch3.adb (Expand_N_Object_Declaration): Add condition to
+ handle processing of objects initialized by a call to a function
+ return an anonymous access type.
+ * exp_ch6.adb, exp_ch6.ads
+ (Has_Unconstrained_Access_Discriminants): Moved to sem_util.adb
+ (Needs_Result_Accessibility_Level): Moved to sem_util.adb
+ * sem_util.adb, sem_util.ads
+ (Has_Unconstrained_Access_Discriminants): Moved from exp_ch6.adb
+ (Needs_Result_Accessibility_Level): Moved from exp_ch6.adb
+ * sem_res.adb (Valid_Conversion): Add condition for the special
+ case where the operand of a conversion is the result of an
+ anonymous access type
+
+2020-06-10 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * par-ch6.adb (P_Subprogram): Reject duplicate subprogram
+ declarations.
+
+2020-06-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch6.adb (Insert_Post_Call_Actions): Deal with the context
+ of an if-expression and with a call written in prefixed notation.
+
+2020-06-10 Gary Dismukes <dismukes@adacore.com>
+
+ * einfo.ads: Minor reformatting of a comment.
+ * exp_aggr.adb: Minor reformatting and a grammar correction.
+ * exp_attr.adb: Minor reformatting and a typo fix in some
+ comments.
+ * sem_ch12.adb: Fix three typos in comments.
+
+2020-06-09 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch6.adb (New_Overloaded_Entity): Add missing call to check
+ subtype conformance of overriding dispatching primitive.
+ * sem_eval.adb (Subtypes_Statically_Match): Handle derivations
+ of private subtypes.
+ * libgnat/g-exptty.adb, libgnat/g-exptty.ads
+ (Set_Up_Communications): Fix the profile since null-exclusion is
+ missing in the access type formals.
+ * sem_disp.ads (Check_Operation_From_Private_View): Adding
+ documentation.
+
+2020-06-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (XEINFO section): Update format description.
+ (Is_Subprogram_Or_Entry): Move pragma to regular section.
+ (Is_Subprogram_Or_Generic_Subprogram): Likewise.
+ * xeinfo.adb (Get_B4): Rename to...
+ (Get_B0): ...this.
+ (Translate_Expr): New procedure extracted from...
+ (XEinfo): ...here. Try to apply Get_B0 first and then
+ call Translate_Expr to translate supported constructs.
+
+2020-06-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch6.adb (Freeze_Subprogram): Deal with convention C_Family.
+ * freeze.adb (Freeze_Profile): Likewise. Add missing guard.
+ * sem_mech.adb (Set_Mechanisms): Likewise.
+ * lib-xref.adb (Output_Import_Export_Info): Ditto for C_Variadic.
+ * repinfo.adb (List_Subprogram_Info): Likewise.
+ * sem_prag.adb (Set_Convention_From_Pragma): Move main checks for
+ Stdcall to...
+ (Process_Convention): ...here. Add checks for C_Variadic.
+ * snames.ads-tmpl: Add Name_C_Variadic_0 .. Name_C_Variadic_16.
+ Use consistent format for subtype declarations.
+ (Convention_Id): Add Convention_C_Variadic_0 .. C_Variadic_16
+ and move Convention_CPP up.
+ (Convention_C_Family): New subtype of Convention_Id.
+ (Convention_C_Variadic): Likewise.
+ (Foreign_Convention): Use explicit upper bound.
+ Add pragma Inline for Is_Configuration_Pragma_Name,
+ Is_Function_Attribute_Name, Is_Internal_Attribute_Name
+ and Is_Procedure_Attribute_Name.
+ * snames.adb-tmpl (Get_Convention_Id): Deal with Name_Variadic_n.
+ (Get_Convention_Name): Deal with Convention_Variadic_n.
+ * types.h (Convention_Id): New typedef.
+ * xsnamest.adb (Name2): New variable.
+ (Is_Conv): New pattern.
+ (Get_Subt1): Likewise.
+ (Get_Subt2): Likewise.
+ Output subtypes of Convention_Id into the C header file.
+
+2020-06-09 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch3.adb, exp_ch4.adb, exp_ch6.adb, exp_ch9.adb,
+ exp_disp.adb, exp_util.adb: Add comments related to errors that
+ should be moved to semantic analysis. Also replace "?" with "??"
+ in warning messages.
+
+2020-06-09 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-strunb__shared.ads, libgnat/a-strunb__shared.adb
+ (Reference, Unreference): No-op for Empty_Shared_String.
+ Remove unneeded calls to Reference.
+
+2020-06-09 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch5.adb (Expand_N_Assignment): Remove kludge for
+ AI05-0087.
+ * sem_ch12.adb (Validate_Derived_Type_Instance): Implement
+ AI05-0087 retroactively since it's a binding interpretation.
+
+2020-06-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (Has_Foreign_Convention): Fix description.
+ (Component_Alignment): Move around.
+ (Has_DIC): Likewise.
+ (Has_Interrupt_Handler): Likewise.
+ (Has_Invariants): Likewise.
+ (Is_Atomic_Or_VFA): Likewise.
+ (Next_Index): Likewise.
+ (Scope_Depth): Likewise.
+ (Init_Component_Size): Likewise.
+ (Init_Component_Location): Likewise.
+ (Init_Size): Likewise.
+ (Inline Pragmas for functions): Add Corresponding_Function,
+ Corresponding_Procedure, Entry_Max_Queue_Lengths_Array,
+ Finalize_Storage_Only, Has_DIC, Has_Invariants,
+ Initialization_Statements, Is_Anonymous_Access_Type,
+ Next_Stored_Discriminant, Address_Clause, Alignment_Clause,
+ Float_Rep, Has_Foreign_Convention, Has_Non_Limited_View,
+ Is_Constant_Object, Is_Discriminal, Is_Finalizer, Is_Null_State,
+ Is_Prival, Is_Protected_Component, Is_Protected_Record_Type,
+ Is_Subprogram_Or_Entry, Is_Task_Record_Type, Size_Clause,
+ Stream_Size_Clause, Type_High_Bound, Type_Low_Bound, Known_*,
+ Unknown_*.
+ (Inline Pragmas for procedures): Add Set_Corresponding_Function,
+ Set_Corresponding_Procedure, Set_Finalize_Storage_Only,
+ Set_Float_Rep, Set_Initialization_Statements,
+ Init_Normalized_First_Bit, Init_Normalized_Position,
+ Init_Normalized_Position_Max.
+ * einfo.adb (Was_Hidden): Move around.
+ (Is_Packed_Array): Likewise.
+ (Model_Emin_Value): Likewise.
+ (Model_Epsilon_Value): Likewise.
+ (Model_Mantissa_Value): Likewise.
+ (Model_Small_Value): Likewise.
+
+2020-06-09 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Check_Shared_Variable_Control_Aspects): Require
+ exact match between formal and actual for aspects Atomic and
+ Volatile only for formal derived types.
+
+2020-06-09 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_util.adb (Side_Effect_Free): Improve handling of
+ N_Aggregate.
+
+2020-06-09 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_res.adb (Resolve_Qualified_Expression): Use Subtype_Mark
+ type.
+
+2020-06-09 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_aggr.adb (Max_Aggregate_Size): New function to factorize
+ code.
+ (Convert_To_Positional, Aggr_Size_OK): Use Max_Aggregate_Size.
+
+2020-06-09 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Set_Debug_Info_Defining_Id): New.
+ * exp_ch3.adb, exp_ch8.adb: Call Set_Debug_Info_Defining_Id when
+ relevant.
+
+2020-06-09 Justin Squirek <squirek@adacore.com>
+
+ * einfo.ads (Returns_By_Ref): Modify documentation to reflect
+ that Returns_By_Ref can be applied to E_Subprogram_Type
+ entities.
+
+2020-06-09 Justin Squirek <squirek@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): Modify expansion
+ of 'Overlaps_Storage to take into account zero sized arrays.
+
+2020-06-09 Bob Duff <duff@adacore.com>
+
+ * bindo-graphs.adb, bindo-graphs.ads: For each invocation graph,
+ record the corresponding library graph.
+ * bindo-writers.adb (Write_Invocation_Graph_Vertex): Print the
+ lib item name. Remove library graph parameters.
+ * bindo-augmentors.adb, bindo-augmentors.ads,
+ bindo-builders.adb, bindo-diagnostics.adb,
+ bindo-diagnostics.ads, bindo-elaborators.adb: Remove library
+ graph parameters.
+
+2020-06-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * checks.adb (Apply_Predicate_Check): Extend trick used for
+ aggregates to qualified aggregates and object declarations
+ * einfo.ads (Has_Own_DIC): Mention the underlying full view.
+ (Has_Own_Invariants): Likewise.
+ (Has_Predicates): Likewise.
+ * exp_util.adb (Build_DIC_Procedure_Declaration): Do not deal
+ with base types explicitly but with underlying full views.
+ (Build_Invariant_Procedure_Declaration): Likewise.
+ * sem_ch13.adb (Build_Predicate_Functions): Do not deal with
+ the full view manually but call Propagate_Predicate_Attributes
+ to propagate attributes to views.
+ (Build_Predicate_Function_Declaration): Likewise.
+ * sem_ch3.adb (Build_Assertion_Bodies_For_Type): Build bodies
+ for private full views with an underlying full view.
+ (Build_Derived_Private_Type): Small comment tweak.
+ (Complete_Private_Subtype): Call Propagate_Predicate_Attributes.
+ (Process_Full_View): Do not deal with base types explicitly for
+ DIC and Invariant attributes. Deal with underlying full views
+ for them. Call Propagate_Predicate_Attributes and deal with
+ underlying full views for them.
+ * sem_ch7.adb (Preserve_Full_Attributes): Do not cross propagate
+ DIC and Invariant attributes between full type and its base type.
+ Propagate Predicate attributes from the full to the private view.
+ * sem_ch9.adb (Analyze_Protected_Type_Declaration): Likewise.
+ (Analyze_Task_Type_Declaration): Likewise.
+ * sem_util.ads (Get_Views): Remove Full_Base parameter and add
+ UFull_Typ parameter.
+ (Propagate_Predicate_Attributes): New procedure.
+ * sem_util.adb (Get_Views): Remove Full_Base parameter and add
+ UFull_Typ parameter. Retrieve the Corresponding_Record_Type
+ from the underlying full view, if any.
+ (Propagate_DIC_Attributes): Remove useless tests.
+ (Propagate_Invariant_Attributes): Likewise.
+ (Propagate_Predicate_Attributes): New procedure.
+
+2020-06-09 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch5.adb (Expand_Predicated_Loop): Perserve the original
+ loop identifier within the expansion.
+
+2020-06-09 Bob Duff <duff@adacore.com>
+
+ * bindo-graphs.ads (Library_Graph_Edge_Kind): Reorder enumerals
+ to reflect the order of adding edges. Clarify comments.
+ * bindo-graphs.adb (Add_Edge_Kind_Check): Correct the
+ assertions. Reorder the "when"s to match the order of adding
+ edges, and therefore the order of enumerals in type
+ Library_Graph_Edge_Kind. Change names to "Old_" and "New_" to
+ clarify what's what. Combine Invocation_Edge into the "<="
+ test. Fix the "raise Program_Error" message, which was
+ backwards.
+
+2020-06-09 Bob Duff <duff@adacore.com>
+
+ * bindo-graphs.adb (Add_Edge_Kind_Check): Add the Image of the
+ old and new Kinds to the raise Program_Error message.
+
+2020-06-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch3.adb (Is_Visible_Component): Do not special-case
+ bodies of instances.
+
+2020-06-09 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch4.adb (Expand_N_In): Fix handling of null exclusion.
+
+2020-06-09 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Check_Shared_Variable_Control_Aspects): Require
+ exact match between formal and actual for aspects Atomic,
+ Atomic_Component, Volatile, and Volatile_Components.
+
+2020-06-09 Bob Duff <duff@adacore.com>
+
+ * doc/gnat_ugn/gnat_utility_programs.rst: Add documentation for
+ the --no-separate-return switch of gnatpp.
+
+2020-06-09 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_warn.adb (Warn_On_Constant_Valid_Condition): Add proper
+ warning tag.
+
+2020-06-09 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_type.adb (Covers): Fix implementation of AI05-0149.
+ * sem_res.adb: Fix typo.
+
+2020-06-09 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch9.adb (Build_Master_Renaming): Make name in renaming
+ declaration unique by adding a numeric suffix, to prevent
+ accidental name conflict when several instantiations of a
+ package containing an access_to_incomplete type that designate
+ tasks appear in the same scope.
+
+2020-06-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * libgnarl/a-synbar.ads, libgnarl/a-synbar.adb,
+ libgnarl/a-synbar__posix.ads, libgnarl/a-synbar__posix.adb
+ (Ada.Synchronous_Barriers): Annotate with SPARK_Mode => Off.
+
+2020-06-09 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_eval.adb (Eval_Relational_Op, Eval_String_Literal,
+ Eval_Type_Conversion): Relax rules on relational operators and
+ type conversions of static string types.
+
+2020-06-09 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Is_Partially_Initialized_Type):
+ Take Default_Value and Default_Component_Value into account.
+ * sem_ch3.adb (Analyze_Object_Declaration): Update comment.
+
+2020-06-09 Bob Duff <duff@adacore.com>
+
+ * bindo-graphs.adb (Add_Edge_Kind_Check): Disable failing part
+ of the assertion.
+
+2020-06-08 Steve Baird <baird@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma.Set_Ravenscar_Profile): Add
+ appropriate call to Set_Restriction_No_Dependence if Ada_Version
+ >= Ada2012 and Profile is either Ravenscar or a GNAT-defined
+ Ravenscar variant (i.e., not Jorvik).
+
+2020-06-08 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch5.adb: Fix typo.
+ * sem_ch8.adb (Analyze_Renamed_Primitive_Operation): Check that
+ the prefix of a prefixed view must be renamable as an object.
+
+2020-06-08 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_cat.ads: Fix typo.
+ * sem_cat.adb (Validate_Remote_Access_To_Class_Wide_Type): Add
+ handling of N_Attribute_Definition_Clause.
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Call
+ Validate_Remote_Access_To_Class_Wide_Type for Storage_Size and
+ Storage_Pool.
+ * sem_attr.adb, exp_ch4.adb: Update comments.
+
+2020-06-08 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch4.adb (Analyze_One_Call): Add extra condition to the
+ predicate for deciding when a given controlled call is visible.
+
+2020-06-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_N_Attribute_Reference): Port
+ changes in frontend expander.
+
+2020-06-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (All_Membership_Choices_Static): Fix style.
+
+2020-06-08 Steve Baird <baird@adacore.com>
+
+ * libgnat/s-rident.ads: Add Jorvik to the Profile_Name
+ enumeration type. Add an element for Jorvik to the array
+ aggregate that is the initial value of the constant
+ Profile_Info.
+ * targparm.adb (Get_Target_Parameters): Handle "pragma Profile
+ (Jorvik);" similarly to "pragma Profile (Ravenscar);".
+ * snames.ads-tmpl: Declare Name_Jorvik Name_Id. Unlike
+ Ravenscar, Jorvik is not a pragma name and has no corresponding
+ element in the Pragma_Id enumeration type; this means that its
+ declaration must not occur between those of First_Pragma_Name
+ and Last_Pragma_Name.
+ * sem_prag.adb (Analyze_Pragma): Add call to
+ Set_Ravenscar_Profile for Jorvik, similar to the existing calls
+ for Ravenscar and the GNAT Ravenscar variants.
+
+2020-06-08 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch8.adb (Analyze_Object_Renaming): Update Get_Object_Name
+ to go through N_Qualified_Expression and N_Type_Conversion. Fix
+ another case of wrong usage of E_Anonymous_Access_Type instead
+ of Anonymous_Access_Kind.
+ * sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): Work
+ on the original node.
+ (Is_Aliased_View): Take into account N_Qualified_Expression.
+
+2020-06-08 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_eval.adb (Eval_Type_Conversion): Fix handling of
+ enumeration to integer conversions.
+ * exp_attr.adb (Expand_N_Attribute_Reference
+ [Attribute_Enum_Rep]): Remove special casing for first-level
+ renaming, best left to the general folding mechanism via
+ Eval_Type_Conversion.
+
+2020-06-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * atree.adb (New_Copy): Do not clear Has_Dynamic_Range_Check.
+ * checks.ads (Append_Range_Checks): Remove Flag_Node parameter.
+ (Insert_Range_Checks): Likewise and remove default value of
+ Static_Loc parameter.
+ * checks.adb (Append_Range_Checks): Remove Flag_Node parameter.
+ Do not test and set Has_Dynamic_Range_Check.
+ (Insert_Range_Checks): Likewise and remove default value of
+ Static_Loc parameter.
+ * csinfo.adb (CSinfo): Remove 'L' from [NEUB]_Fields pattern and
+ do not handle Has_Dynamic_Range_Check.
+ * exp_ch5.adb (Expand_N_Assignment_Statement): Remove argument
+ in call to Insert_Range_Checks.
+ * sem_ch3.adb (Analyze_Subtype_Declaration): Do not fiddle
+ with Has_Dynamic_Range_Check.
+ (Process_Range_Expr_In_Decl): Remove argument in calls to
+ Insert_Range_Checks and Append_Range_Checks.
+ * sinfo.ads (Has_Dynamic_Range_Check): Delete.
+ (Set_Has_Dynamic_Range_Check): Likewise.
+ * sinfo.adb (Has_Dynamic_Range_Check): Delete.
+ (Set_Has_Dynamic_Range_Check): Likewise.
+ * treepr.adb (Print_Node): Do not print Has_Dynamic_Range_Check.
+
+2020-06-08 Steve Baird <baird@adacore.com>
+
+ * sem_ch13.ads: Export new function
+ All_Membership_Choices_Static.
+ * sem_ch13.adb: Implement new function
+ All_Membership_Choices_Static. This involves moving the
+ functions Is_Static_Choice and All_Membership_Choices_Static,
+ which were previously declared within the function
+ Is_Predicate_Static, out to library level so that they can be
+ called by the new function. The already-exisiting code in
+ Is_Predicate_Static which became the body of
+ All_Membership_Choices_Static is replaced with a call to the new
+ function in order to avoid duplication.
+ * exp_ch9.adb (Is_Pure_Barrier): Several changes needed to
+ implement rules of AI12-0290 and RM D.7's definition of
+ "pure-barrier-eligible". These changes include adding a call to
+ the new function Sem_13.All_Membership_Choices_Static, as per
+ the "see 4.9" in RM D.7(1.6/5).
+
+2020-06-08 Richard Kenner <kenner@adacore.com>
+
+ * exp_unst.adb (Visit_Node): When visiting array attribute
+ nodes, in addition to checking the type of Get_Referenced_Object
+ of the prefix, also check the actual type of the prefix.
+
+2020-06-08 Gary Dismukes <dismukes@adacore.com>
+
+ * checks.adb (Apply_Predicate_Check): Refine test for being in a
+ subprogram body to account for no Corresponding_Body case,
+ avoiding blowups arising due to other changes here.
+ * exp_ch4.adb (Expand_N_Qualified_Expression): Apply predicate
+ checks, if any, after constraint checks are applied.
+ * sem_eval.ads (Check_Expression_Against_Static_Predicate): Add
+ Check_Failure_Is_Error formal for conditionalizing warning vs.
+ error messages.
+ * sem_eval.adb (Check_Expression_Against_Static_Predicate):
+ Issue an error message rather than a warning when the new
+ Check_Failure_Is_Error formal is True. In the nonstatic or
+ Dynamic_Predicate case where the predicate is known to fail,
+ emit the check to ensure that folded cases get checks applied.
+ * sem_res.adb (Resolve_Qualified_Expression): Call
+ Check_Expression_Against_Static_Predicate, passing True for
+ Check_Failure_Is_Error, to ensure we reject static predicate
+ violations. Remove code that was conditionally calling
+ Apply_Predicate_Check, which is no longer needed, and that check
+ procedure shouldn't be called from a resolution routine in any
+ case. Also remove associated comment about preventing infinite
+ recursion and consistency with Resolve_Type_Conversion, since
+ that handling was already similarly removed from
+ Resolve_Type_Convesion at some point.
+ (Resolve_Type_Conversion): Add passing of True for
+ Check_Failure_Is_Error parameter on call to
+ Check_Expression_Against_Static_Predicate, to ensure that static
+ conversion cases that violate a predicate are rejected as
+ errors.
+
+2020-06-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * snames.ads-tmpl (Name_SPARK): Restore after being deleted.
+
+2020-06-08 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_aggr.adb, exp_ch6.adb, par-ch11.adb, par-ch6.adb,
+ par-ch7.adb, par-prag.adb, restrict.adb, restrict.ads,
+ scans.ads, scng.adb, sem_aggr.adb, sem_attr.adb, sem_ch11.adb,
+ sem_ch12.adb, sem_ch3.adb, sem_ch3.ads, sem_ch4.adb,
+ sem_ch5.adb, sem_ch6.adb, sem_ch7.adb, sem_ch8.adb, sem_ch9.adb,
+ sem_res.adb, sem_util.adb, sem_util.ads, snames.ads-tmpl,
+ gnatbind.adb, libgnat/s-rident.ads,
+ doc/gnat_rm/standard_and_implementation_defined_restrictions.rst:
+ Remove processing of SPARK_05 restriction.
+ * gnat_rm.texi: Regenerate.
+ * opt.ads: Remove processing of old checksum which is now
+ handled by gprbuild directly.
+
+2020-06-08 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch12.adb (Instantiate_Object): Relax rules related to null
+ exclusions and generic objects. Handle all anonymous types
+ consistently and not just E_Anonymous_Access_Type.
+ * sem_ch8.adb (Analyze_Object_Renaming): Change wording so that
+ it applies to both renamings and instantiations to avoid
+ confusion.
+
+2020-06-08 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-textio.ads (File_Mode): Fix typo in comment.
+
+2020-06-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_res.adb (Resolve_Indexed_Component): Do not give a warning
+ for a nonatomic component of an atomic array which is subject to
+ an address clause in Ada 2020 mode.
+ (Resolve_Selected_Component): Likewise for an atomic record.
+
+2020-06-08 Philippe Gil <gil@adacore.com>
+
+ * doc/gnat_ugn/the_gnat_compilation_model.rst: in "Handling
+ Files with Multiple Units" part documents gnatname use for
+ unmodified files handling and gnatchop use for files
+ refactoring.
+ * gnat_ugn.texi: Regenerate.
+
+2020-06-08 Arnaud Charlet <charlet@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_attributes.rst:
+ Enum_Rep/Enum_Val are standard Ada 202x attributes.
+ * gnat_rm.texi: Regenerate.
+
+2020-06-08 Javier Miranda <miranda@adacore.com>
+
+ * exp_aggr.adb (Safe_Component): Remove code that considers as
+ unsafe components that are aggregates; such removal allows the
+ frontend to proceed and evaluate if they are safe by means of
+ invoking Safe_Aggregate.
+
+2020-06-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_N_Attribute_Reference): Apply
+ standard expansion to attributes First and Last.
+
+2020-06-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb, exp_util.ads, exp_util.adb (Get_Index_Subtype):
+ Move from the body of Exp_Attr to Exp_Util and expose from the
+ spec.
+ * exp_spark.adb (Expand_SPARK_N_Attribute_Reference): Replace
+ duplicated code with a call to Get_Index_Subtype.
+
+2020-06-08 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch8.adb (Analyze_Object_Renaming): Simplify code by moving
+ many special cases to Is_Object_Reference and removing others by
+ only checking renamings coming from sources.
+ * sem_util.adb (Is_Object_Reference): Update for AI12-0226 and
+ add more regular handling of 'Priority. Remove special cases no
+ longer needed now that we are only checking renamings coming
+ from sources.
+
+2020-06-08 Claire Dross <dross@adacore.com>
+
+ * libgnat/a-cofove.adb (Insert_Space): The computation of Index
+ generates a spurious compiler warning about a value not being in
+ range for a statically dead branch. Silence it using pragma
+ Warnings.
+
+2020-06-08 Bob Duff <duff@adacore.com>
+
+ * bindo-graphs.adb (function Add_Edge): Rename
+ Add_Edge_With_Return to Add_Edge; we can tell it returns because
+ it's a function, and overloading seems appropriate in this case.
+ If Activates_Task=True, and we're not going to add a new edge
+ because an existing Pred-->Succ edge already exists, then set
+ Activates_Task to True on the preexisting edge. This ensures
+ that the message:
+ info: use pragma Restrictions (No_Entry_Calls_In_Elaboration_Code)
+ appears when appropriate, no matter in what order the edges
+ happened to be processed.
+ (procedure Add_Edge): Remove redundant assertions.
+ (Activates_Task): Other kinds of edges can have
+ Activates_Task=True. For example, if we had a With_Edge and
+ then an Invocation_Edge with Activates_Task=True, then the
+ With_Edge has Activates_Task set to True.
+ (Add_Edge_Kind_Check): New procedure to prevent other bugs of
+ this nature. For example, if we were to sometimes call Add_Edge
+ for a Spec_Before_Body_Edge followed by Add_Edge for a
+ With_Edge, and sometimes in the other order, that would cause a
+ similar bug to what we're fixing here.
+ (Set_Is_Recorded_Edge): Val parameter is not used. Get rid of
+ it.
+ (Set_Activates_Task): New procedure to set the Activates_Task flag.
+ * bindo-graphs.ads (Library_Graph_Edge_Kind): Reorder the
+ enumeration literals to facilitate Add_Edge_Kind_Check.
+ * ali.adb (Known_ALI_Lines): The comment about "still available"
+ was wrong. Fix that by erasing the comment, and encoding the
+ relevant information in real code. Take advantage of Ada's full
+ coverage rules by removing "others =>". Also DRY.
+
+2020-06-08 Ed Schonberg <schonberg@adacore.com>
+
+ * par-ch12.adb (P_Formal_Derived_Type_Definition): Handle
+ properly formal derived types that include aspect
+ specifications, so that the "with" keyword appears twice in the
+ formal type declaration.
+ * sem_ch13.adb (Has_Generic_Parent): Return true if the type
+ itself is a generic formal.
+
+2020-06-08 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * socket.c (__gnat_minus_500ms): Remove
+ IsWindowsVersionOrGreater from condition.
+
+2020-06-08 Claire Dross <dross@adacore.com>
+
+ * libgnat/a-cfdlli.ads, libgnat/a-cfhama.ads,
+ libgnat/a-cfhase.ads, libgnat/a-cforma.ads, libgnat/a-cforse.ads
+ (Delete): Add Depends contract.
+
+2020-06-08 Arnaud Charlet <charlet@adacore.com>
+
+ * snames.ads-tmpl (Name_Program_Error_Check,
+ Name_Tasking_Check): New constants.
+ * types.ads (Program_Error_Check, Tasking_Check): New constants.
+ (All_Checks): Update accordingly.
+
+2020-06-05 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_prag.adb (Validate_Compile_Time_Warning_Or_Error): Use ??.
+
+2020-06-05 Arnaud Charlet <charlet@adacore.com>
+
+ * cstand.adb (Create_Standard): Update comments.
+
+2020-06-05 Arnaud Charlet <charlet@adacore.com>
+
+ * scng.adb (Scan): Fix typo to take into account all future
+ versions of Ada.
+ * sem_attr.ads (Attribute_Impl_Def): Add Attribute_Reduce for
+ now.
+ * sem_attr.adb (Analyze_Attribute): Only allow 'Reduce under
+ -gnatX.
+ * snames.ads-tmpl (Name_Reduce): Update comment.
+
+2020-06-05 Thomas Quinot <quinot@adacore.com>
+
+ * exp_disp.adb (Expand_Interface_Thunk): Add comment about
+ gnatcov reliance on specific name used for thunks.
+
+2020-06-05 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Analyze_Subtype_Declaration): For scalar types,
+ and for subtype declarations without a constraint, subtype
+ inherits Atomic flag from base type.
+
+2020-06-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_attributes.rst (Enum_Rep):
+ Remove extra colon.
+ * gnat_rm.texi: Regenerate.
+
+2020-06-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * atree.adb (New_Copy): Clear Has_Dynamic_Range_Check on
+ subexpression nodes.
+ * checks.adb (Append_Range_Checks): Assert that the node
+ doesn't have the Has_Dynamic_Range_Check flag set.
+ (Insert_Range_Checks): Likewise.
+ * exp_ch3.adb (Expand_N_Subtype_Indication): Do not apply
+ range checks for a full type or object declaration.
+ * sem_ch3.ads: Move with and use clauses for Nlists to...
+ (Process_Range_Expr_In_Decl): Change default to No_List for
+ the Check_List parameter.
+ * sem_ch3.adb: ...here.
+ (Process_Range_Expr_In_Decl): Likewise. When the insertion
+ node is a declaration, only insert on the list if is present
+ when the declaration involves discriminants, and only insert
+ on the node when there is no list otherwise.
+
+2020-06-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aggr.adb (Resolve_Record_Aggregate): Create the
+ N_Aggregate node with its Expressions field set to No_List and
+ not to an empty list.
+
+2020-06-05 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * libgnat/s-os_lib.adb (Is_Dirsep): Moved from Build_Path to
+ package level to reuse.
+ (Normalize_Pathname.Final_Value): Reduce 2 'if' statements to
+ one.
+ (Normalize_Pathname.Fill_Directory): New procedure instead of
+ function Get_Directory. Remove slash to backslash conversion and
+ drive letter uppercasing on Windows.
+
+2020-06-05 Arnaud Charlet <charlet@adacore.com>
+
+ * sem.adb (Assert_Done): Relax check for main unit, as it was
+ overzealous in the case of the main unit itself.
+
+2020-06-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch3.adb, sem_ch8.adb, sem_util.adb: Use Is_Incomplete_Type
+ to make the code easier to read.
+
+2020-06-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * einfo.adb: Minor reformatting.
+ * sem_util.adb (Has_Full_Default_Initialization,
+ Is_Partially_Initialized_Type, Caller_Known_Size_Record,
+ Large_Max_Size_Mutable): Iterate with
+ First_Component/Next_Component; rename Ent to Comp.
+
+2020-06-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_aggr.adb (Aggr_Assignment_OK_For_Backend): Use
+ Expr_Rep_Value instead of Expr_Value to obtain the equivalent
+ integer value.
+ * sem_eval.ads (Expr_Value): Document more supported cases.
+ * sem_eval.adb (Expr_Rep_Value): Copy missing cases from
+ Exp_Value.
+
+2020-06-05 Bob Duff <duff@adacore.com>
+
+ * rtsfind.adb, rtsfind.ads: Move subtypes of RTU_Id into package
+ body, because they are not needed by clients. Change "Child_" to
+ "Descendant", because grandchildren and great grandchildren are
+ involved. Replace all the repetitive comments with a single
+ concise one. Change the parent subtypes to be more consistent;
+ use the most specific parent.
+
+2020-06-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * rtsfind.ads, rtsfind.adb (Is_Text_IO_Special_Package): Moved
+ from the GNATprove backend to the frontend.
+
+2020-06-05 Yannick Moy <moy@adacore.com>
+
+ * sem_util.ads: Add comment about function only used in
+ CodePeer.
+
+2020-06-05 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch9.adb, (Analyze_Task_Body): After analying the task
+ body, indicate that all local variables have no delayed aspects.
+ This prevents improper later calls to
+ Check_Aspect_At_End_Of_Declarations, that would happen when the
+ constructed task_procedure body (generated during expansion) is
+ analyzed. The legality of aspect specifications that may appear
+ on local declarations has already been established, and it is in
+ general not possible to recheck them properly during expansion,
+ when visibility may not be fully established.
+
+2020-06-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * libgnat/a-cofuve.ads (First): Add Global contract.
+
+2020-06-05 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_prag.adb (Set_Convention_From_Pragma): Set the convention
+ of anonymous access array components.
+
+2020-06-05 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-calfor.ads, libgnat/a-catizo.ads,
+ libgnat/a-catizo.adb (Local_Time_Offset, Local_Image): New.
+ (UTC_Time_Offset): Now a renaming of Local_Time_Offset.
+
+2020-06-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch3.adb (Available_Full_View): New function returning
+ either the full or the underlying full view.
+ (Build_Full_Derivation): Add guard for the full view.
+ (Copy_And_Build): Retrieve the underlying full view, if any,
+ also if deriving a completion.
+ (Build_Derived_Private_Type): Use Available_Full_View throughout
+ to decide whether a full derivation must be done.
+
+2020-06-05 Bob Duff <duff@adacore.com>
+
+ * exp_attr.adb, exp_ch11.adb, exp_imgv.adb, exp_tss.ads,
+ par-ch4.adb, sem_attr.adb, sem_util.ads: Misc cleanup.
+
+2020-06-05 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-nudira.ads, libgnat/a-nudira.adb (Random): New
+ function.
+
+2020-06-05 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_attr.ads (Attribute_Impl_Def): Remove Enum_Rep/Val.
+ * sem_attr.adb (Attribute_20): New, move Enum_Rep/Val here.
+ (Analyze_Attribute): Take Attribute_20 into account.
+
+2020-06-05 Arnaud Charlet <charlet@adacore.com>
+
+ * restrict.ads (Unit_Array): Add a-direct.
+
+2020-06-05 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-stopoo.ads: Mark package Pure and leave room for
+ Nonblocking once this aspect is supported.
+
+2020-06-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference) <Valid_Scalars>:
+ Set the No_Truncation flag on the unchecked conversion built for
+ scalar types.
+
+2020-06-05 Bob Duff <duff@adacore.com>
+
+ * einfo.adb, einfo.ads, exp_util.adb: Remove Invariants_Ignored
+ flag.
+ * sem_prag.adb (Invariant): Instead of setting a flag to be
+ checked elsewhere, remove the pragma as soon as it is analyzed
+ and checked for legality.
+
+2020-06-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * checks.ads (Apply_Length_Check): Rename Ck_Node parameter to
+ Expr.
+ (Apply_Range_Check): Likewise.
+ (Get_Range_Checks): Likewise.
+ * checks.adb (Apply_Float_Conversion_Check): Likewise.
+ (Apply_Selected_Length_Checks): Likewise.
+ (Apply_Selected_Range_Checks): Likewise.
+ (Guard_Access): Likewise.
+ (Selected_Length_Checks): Likewise. Also avoid shadowing in
+ child procedures.
+ (Selected_Range_Checks): Likewise.
+
+2020-06-05 Arnaud Charlet <charlet@adacore.com>
+
+ * par-ch3.adb, par-ch4.adb, scng.adb, sem_aggr.adb,
+ sem_ch10.adb, sem_ch12.adb, sem_prag.adb: Update wording: change
+ Ada_2020 to Ada 2020 in comments and mention -gnat2020 instead
+ of -gnatX switch.
+
+2020-06-04 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/i-c.ads (long_long, unsigned_long_long): New
+ definitions.
+
+2020-06-04 Arnaud Charlet <charlet@adacore.com>
+
+ * Makefile.rtl: add a-tasini object
+ * impunit.adb (Non_Imp_File_Names_95): Add s-tasini.
+ * libgnarl/a-tasini.ads, libgnarl/a-tasini.adb: New files.
+ * libgnarl/s-taskin.ads (Global_Initialization_Handler): New.
+ * libgnarl/s-tassta.adb (Task_Wrapper): Call
+ Global_Initialization_Handler if non null.
+
+2020-06-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Build_Suprogram_Body_Wrapper,
+ Build_Subprogram_Decl_Wrapper): New suprograms, to create the
+ wrappers needed to implement contracts on formsl subprograms at
+ the point of instantiation.
+ (Build_Subprogram_Wrappers): New subprogram within
+ Analyze_Associations, calls the above when the formal subprogram
+ has contracts, and expansion is enabled.
+ (Instantiate_Formal_Subprogram): If the actual is not an entity,
+ such as a function attribute, or a synchronized operation,
+ create a function with an internal name and call it within the
+ wrapper.
+ (Analyze_Generic_Formal_Part): Analyze contracts at the end of
+ the list of formal declarations.
+ * sem_prag.adb (Analyze_Pre_Post_Condtion): In Ada_2020 the
+ aspect and corresponding pragma can appear on a formal
+ subprogram declaration.
+ (Find_Related_Declaration_Or_Body): Ditto.
+
+2020-06-04 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch7.adb (Make_Final_Call): Set the type of the object, if
+ it is unanalyzed, before calling Convert_View on it.
+
+2020-06-04 Arnaud Charlet <charlet@adacore.com>
+
+ * adabkend.adb, back_end.ads, opt.ads, sem_ch6.adb: Get rid of
+ Disable_FE_Inline_Always.
+
+2020-06-04 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch7.adb (Make_Final_Call): Add missing guard.
+ * sem_ch3.adb (Copy_And_Build): Adjust recursive call for
+ private types.
+ (Build_Derived_Private_Type): Deal with underlying full views.
+
+2020-06-04 Bob Duff <duff@adacore.com>
+
+ * libgnat/a-stobbu.adb, libgnat/a-stobbu.ads,
+ libgnat/a-stobfi.adb, libgnat/a-stobfi.ads,
+ libgnat/a-stoubu.adb, libgnat/a-stoubu.ads,
+ libgnat/a-stoufi.adb, libgnat/a-stoufi.ads,
+ libgnat/a-stoufo.adb, libgnat/a-stoufo.ads,
+ libgnat/a-stouut.adb, libgnat/a-stouut.ads,
+ libgnat/a-stteou.ads, libgnat/s-putaim.adb,
+ libgnat/s-putaim.ads, libgnat/s-putima.adb, libgnat/s-putima.ads
+ (Ada.Strings.Text_Output and children, System.Put_Images): New
+ runtime support for Put_Image.
+ * gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Add
+ exp_put_image.o.
+ * exp_put_image.adb, exp_put_image.ads: New compiler package
+ that generates calls to runtime routines that implement
+ Put_Image.
+ * Makefile.rtl: Add object files for Ada.Strings.Text_Output and
+ children and System.Put_Images.
+ * aspects.adb: Simplify initialization of Canonical_Aspect.
+ * aspects.ads: Improve documentation. Add Aspect_Put_Image.
+ * exp_attr.adb: Add support for Put_Image, by calling routines
+ in Exp_Put_Image.
+ * sem_util.adb (Is_Predefined_Dispatching_Operation): Return
+ True for new TSS_Put_Image operation.
+ * exp_ch3.adb: For tagged types, build a dispatching
+ TSS_Put_Image operation by calling routines in Exp_Put_Image.
+ * exp_disp.adb, exp_disp.ads: Make TSS_Put_Image be number 10,
+ adjusting other operations' numbers after 10. We choose 10
+ because that's the last number shared by all runtimes.
+ * exp_strm.adb: Use named notation as appropriate.
+ * exp_cg.adb, exp_tss.ads: Add TSS_Put_Image.
+ * libgnat/a-tags.ads: Modify Max_Predef_Prims for the new
+ TSS_Put_Image.
+ * impunit.adb: Add new runtime packages.
+ * rtsfind.adb, rtsfind.ads: Add support for
+ Ada.Strings.Text_Output, Ada.Strings.Text_Output.Utils, and
+ System.Put_Images.
+ * sem_attr.adb: Error checking for Put_Image calls.
+ * sem_ch12.adb (Valid_Default_Attribute): Support for passing
+ Put_Image as a generic formal parameter.
+ * sem_ch13.adb: Analysis of Put_Image aspect. Turn it into a
+ Put_Image attribute definition clause.
+ * sem_ch8.adb (Analyze_Subprogram_Renaming): Support for
+ renaming of the Put_Image attribute.
+ * snames.adb-tmpl: Fix comments.
+ * snames.ads-tmpl (Name_Put_Image): New Name_Id.
+ (Attribute_Put_Image): New Attribute_Id.
+ * tbuild.adb, tbuild.ads (Make_Increment): New utility.
+
+2020-06-04 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_attr.adb (xpand_N_Attribute_Reference) <Input>: Call
+ Find_Inherited_TSS to look up the Stream_Read TSS.
+ <Output>: Likewise for the Stream_Write TSS.
+ * exp_ch7.adb (Make_Final_Call): Call Underlying_Type on
+ private types to account for underlying full views.
+ * exp_strm.ads (Build_Record_Or_Elementary_Input_Function):
+ Remove Use_Underlying parameter.
+ * exp_strm.adb (Build_Record_Or_Elementary_Input_Function):
+ Likewise and adjust accordingly.
+ * exp_tss.adb (Find_Inherited_TSS): Deal with full views.
+ Call Find_Inherited_TSS recursively on the parent type if
+ the base type is a derived type.
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Take
+ into account underlying full views for derived types.
+ * sem_ch3.adb (Copy_And_Build): Look up the underlying full
+ view only for a completion. Be prepared for private types.
+ (Build_Derived_Private_Type): Build an underlying full view
+ for a completion in the general case too.
+
+2020-06-04 Arnaud Charlet <charlet@adacore.com>
+
+ * back_end.adb, opt.ads, par-prag.adb, sem_ch5.adb,
+ sem_prag.adb, sinfo.adb, sinfo.ads, snames.ads-tmpl,
+ doc/gnat_rm/implementation_defined_pragmas.rst: Remove
+ experimental support for OpenACC.
+ * gcc-interface/misc.c, gcc-interface/trans.c,
+ gcc-interface/lang.opt: Ditto.
+ * gnat_rm.texi: Regenerate.
+
+2020-06-04 Eric Botcazou <ebotcazou@adacore.com>
+
+ * checks.adb (Generate_Discriminant_Check): Remove obsolete
+ comment.
+
+2020-06-04 Gary Dismukes <dismukes@adacore.com>
+
+ * par-ch3.adb (P_Identifier_Declarations): Add parsing of object
+ renamings that have neither a subtype_mark nor an
+ access_definition. Issue an error if the version is earlier than
+ Ada_2020, and suggest using -gnatX.
+ * sem_ch8.adb (Analyze_Object_Renaming): Handle
+ object_renaming_declarations that don't have an explicit
+ subtype. Errors are issued when the name is inappropriate or
+ ambiguous, and otherwise the Etype of the renaming entity is set
+ from the Etype of the renamed object.
+ * sem_util.adb (Has_Null_Exclusion): Allow for the case of no
+ subtype given in an N_Object_Renaming_Declaration.
+ * sprint.adb (Sprint_Node_Actual): Handle printing of
+ N_Object_Renaming_Declarations that are specified without an
+ explicit subtype.
+
+2020-06-04 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sinfo.ads (N_Delta_Aggregate): Document Etype field.
+ (N_Case_Expression): Likewise.
+ (Is_Syntactic_Field) <N_Quantified_Expression>: Adjust.
+ <N_Case_Expression>: Likewise.
+
+2020-06-04 Arnaud Charlet <charlet@adacore.com>
+
+ * adaint.c: Avoid redefining IS_DIR_SEPARATOR macro.
+
+2020-06-04 Arnaud Charlet <charlet@adacore.com>
+
+ * sem.adb (Walk_Library_Items): Defer processing of main spec
+ after all other specs and before processing bodies.
+
+2020-06-04 Arnaud Charlet <charlet@adacore.com>
+
+ * bindgen.adb (Gen_Adafinal): Adafinal is convention Ada, not C.
+
+2020-06-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sinput.adb (Sloc_Range): Ignore node in the tree if it appears
+ in a unit different from that of the node whose Sloc range we
+ are computing. This is necessary when computing the source range
+ of a subprogram body whose declaration includes a pre- or
+ postcondition, because declaration and body may appear in
+ different units, and the expanded code for the body includes
+ copies of the contract code.
+
+2020-06-04 Alexandre Oliva <oliva@adacore.com>
+
+ * switch.adb (Is_Internal_GCC_Switch): Recognize dumpdir and
+ dumpbase-ext. Mark auxbase and auxbase-strip for removal.
+
+2020-06-04 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_attr.adb (Resolve_Attribute) <Access>: Do not generate
+ the secondary message about a missing pragma if the convention
+ of the prefix is Intrinsic.
+ * sem_ch12.adb (Instantiate_Formal_Subprogram): Only set the
+ Convention and the Is_Inlined flag on a null procedure.
+
+2020-06-04 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch6.adb (Check_Return_Obj_Accessibility): Change to
+ Check_Return_Construct_Accessibility to better reflect its
+ purpose. Add loop to properly obtain the object declaration
+ from an expanded extended return statement and add calls to get
+ the original node for associated values. Also, avoid checks when
+ the return statement being examined comes from an internally
+ generated function.
+
+2020-06-04 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * adaint.c (__gnat_is_absolute_path): Check for directory
+ separator after drive and colon.
+ (IS_DIR_SEPARATOR): Define new inline substitution.
+
+2020-06-04 Eric Botcazou <ebotcazou@adacore.com>
+
+ * checks.ads: Update documentation about range checks and fix
+ minor other things.
+
+2020-06-04 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch3.adb (Array_Type_Declaration): Apply special handling
+ of private index types to generic packages and restrict it to
+ index types defined in the current scope.
+
+2020-06-04 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-exextr.adb (Global_Unhandled_Action): New global
+ variable.
+ (Notify_Exception): Take into account Global_Unhandled_Action
+ and fix latent race condition.
+ (Exception_Action): Mark Favor_Top_Level so that variables can
+ be atomic.
+ (Global_Action): Mark atomic to remove the need for a lock.
+ * libgnat/g-excact.ads, libgnat/g-excact.adb
+ (Register_Global_Unhandled_Action): New procedure.
+ (Register_Global_Action): Remove lock.
+ * libgnat/s-stalib.ads (Raise_Action): Mark Favor_Top_Level to
+ be compatible with Exception_Action.
+ * sem_warn.adb (Warn_On_Unreferenced_Entity): Fix logic wrt
+ Volatile entities and entities with an address clause: the code
+ did not match the comment/intent.
+
+2020-06-04 Arnaud Charlet <charlet@adacore.com>
+
+ * comperr.adb (Compiler_Abort): Update URL and bug report
+ instructions.
+
+2020-06-04 Steve Baird <baird@adacore.com>
+
+ * libgnat/s-imgrea.ads: Declare a named number
+ Max_Real_Image_Length with value 5200. Provide a comment
+ explaining why this value was chosen.
+ * libgnat/s-imgrea.adb (Set_Image_Real): Increase the upper
+ bound of the local String variable Digs to
+ Max_Real_Image_Length.
+ * libgnat/a-tiflau.adb (Put): Increase the upper bound of the
+ local String variable Buf to Max_Real_Image_Length.
+ (Puts): Increase the upper bound of the local String variable
+ Buf to Max_Real_Image_Length.
+
+2020-06-04 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnarl/a-dynpri.adb, libgnarl/a-taside.adb,
+ libgnarl/a-taster.adb, libgnarl/s-interr.adb,
+ libgnarl/s-interr__sigaction.adb, libgnarl/s-taasde.adb,
+ libgnarl/s-taenca.adb, libgnarl/s-taenca.ads,
+ libgnarl/s-taprop.ads, libgnarl/s-taprop__hpux-dce.adb,
+ libgnarl/s-taprop__linux.adb, libgnarl/s-taprop__mingw.adb,
+ libgnarl/s-taprop__posix.adb, libgnarl/s-taprop__qnx.adb,
+ libgnarl/s-taprop__solaris.adb, libgnarl/s-taprop__vxworks.adb,
+ libgnarl/s-tarest.adb, libgnarl/s-tasini.adb,
+ libgnarl/s-tasque.adb, libgnarl/s-tasque.ads,
+ libgnarl/s-tasren.adb, libgnarl/s-tasren.ads,
+ libgnarl/s-tassta.adb, libgnarl/s-tasuti.adb,
+ libgnarl/s-tasuti.ads, libgnarl/s-tpoben.adb,
+ libgnarl/s-tpobop.adb, libgnarl/s-tpopmo.adb,
+ libgnarl/s-tposen.adb, libgnat/s-parame.ads,
+ libgnat/s-parame__ae653.ads, libgnat/s-parame__hpux.ads,
+ libgnat/s-parame__vxworks.ads: Remove references to Single_Lock
+ and Global_Lock.
+
+2020-06-04 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-atopar.adb, libgnat/s-atopex.adb: Use Object_Size
+ instead of Size, otherwise many derived types will be rejected
+ (e.g. a type with a 14 bits 'Size and a 16 bits 'Object_Size).
+
+2020-06-04 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch12.adb (Copy_Generic_Node): Add special handling for a
+ conversion between access types.
+
+2020-06-04 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch12.adb (Check_Generic_Actuals): Also restore the proper
+ views of the actuals of the parent instances if the formals are
+ used as actuals of the children.
+ (Instantiate_Type): Add comment.
+
+2020-06-04 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch12.adb: Minor editorial fixes.
+
+2020-06-03 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch12.adb (Denotes_Previous_Actual): Delete.
+ (Check_Generic_Actuals): Do not special case array types whose
+ component type denotes a previous actual. Do not special case
+ access types whose base type is private.
+ (Check_Private_View): Remove code dealing with secondary types.
+ Do not switch the views of an array because of its component.
+ (Copy_Generic_Node): Add special handling for a comparison
+ operator on array types.
+ (Instantiate_Type): Do not special case access types whose
+ designated type is private.
+ (Set_Global_Type): Do not special case array types whose
+ component type is private.
+
+2020-06-03 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch10.adb (Process_Body_Clauses): Add loop to interate
+ through all prefixes in a use_type clause so that all packages
+ in the expanded name get examined for effectiveness.
+
+2020-06-03 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch12.adb (Check_Private_View): Clean up implementation of
+ second main case, when the generic sees the private declaration.
+
+2020-06-03 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-nbnbin.ads: Minor reformatting.
+ * libgnat/a-nbnbre.ads, libgnat/a-nbnbre.adb (Is_Valid): Add
+ convention Intrinsic. Add detection of uninitialized big reals.
+
+2020-06-03 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Side_Effect_Free_Statements,
+ Side_Effect_Free_Loop): New functions.
+ (Has_Non_Null_Statements): Consider N_Call_Marker as a null
+ statement.
+ * sem_ch5.adb (Analyze_Loop_Parameter_Specification): Call
+ Set_Is_Null_Loop even inside a generic instantiation.
+ (Analyze_Loop_Statement): Mark for removal loops with no side
+ effects.
+
+2020-06-03 Eric Botcazou <ebotcazou@adacore.com>
+
+ * opt.ads (Allow_Integer_Address): Fix typo in comment.
+ * stand.ads (Standard_Address): New entity.
+ * cstand.adb (Create_Standard): Create it.
+ * sem_ch4.adb (Operator_Check): Convert the operands of an
+ operation with addresses and integers to Standard_Address
+ if pragma Allow_Integer_Address is in effect.
+
+2020-06-03 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-atopar.adb (Atomic_Fetch_And_Add): Make use of an
+ equivalent static expression.
+ (Atomic_Fetch_And_Subtract): Likewise.
+ (Is_Lock_Free): Likewise.
+ * libgnat/s-atopex.adb (Atomic_Exchange): Likewise.
+ (Atomic_Compare_And_Exchange): Likewise.
+ (Is_Lock_Free): Likewise.
+
+2020-06-03 Vadim Godunko <godunko@adacore.com>
+
+ * libgnat/s-parame.ads, libgnat/s-parame__ae653.ads,
+ libgnat/s-parame__hpux.ads: Fix typos.
+
+2020-06-03 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_util.adb (Remove_Side_Effects): For a type conversion, do
+ not remove the side effects of the expression only if it is of
+ universal integer type.
+
+2020-06-03 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-aotase.ads, libgnat/s-atoope.ads,
+ libgnat/s-atopar.ads, libgnat/s-atopex.ads: Update header.
+
+2020-06-03 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Unchecked_Type_Conversion): Also fold the
+ conversion for literals of enumeration types.
+
+2020-06-03 Yannick Moy <moy@adacore.com>
+
+ * rtsfind.adb (Load_RTU): Correctly set/reset global variable to
+ ignore SPARK_Mode in instances around loading.
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Accept Off
+ without prior On.
+ * sem_ch7.adb (Analyze_Package_Body_Helper): Likewise.
+ * sem_prag.adb (Analyze_Pragma): Always take into account
+ SPARK_Mode Off.
+
+2020-06-03 Arnaud Charlet <charlet@adacore.com>
+
+ * frontend.adb (Frontend): Call (dummy for now) tree checker.
+ * debug.adb: Reserve -gnatd_V for the tree checker.
+ * vast.ads, vast.adb: New files.
+ * gcc-interface/Make-lang.in: Add vast.o.
+
+2020-06-03 Justin Squirek <squirek@adacore.com>
+
+ * libgnat/a-cborse.adb, libgnat/a-cihase.adb,
+ libgnat/a-ciorse.adb, libgnat/a-coorse.adb: Modified to use
+ 'Unrestricted_Access in certain cases where static accessibility
+ errors were triggered.
+ * exp_ch6.adb (Expand_Simple_Return_Statement): Add generation
+ of dynamic accessibility checks as determined by
+ Is_Special_Aliased_Formal_Access.
+ * sem_attr.adb (Resolve_Attribute): Add call to
+ Is_Special_Aliased_Formal_Access to avoid performing static
+ checks where dynamic ones are required.
+ * sem_ch6.adb (Check_Return_Obj_Accessibility): Handle renamed
+ objects within component associations requiring special
+ accessibility checks.
+ * sem_util.adb, sem_util.ads (Is_Special_Aliased_Formal_Access):
+ Created to detect the special case where an aliased formal is
+ being compared against the level of an anonymous access return
+ object.
+ (Object_Access_Level): Remove incorrect condition leading to
+ overly permissive accessibility levels being returned on
+ explicitly aliased parameters.
+
+2020-06-03 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (Enum_Pos_To_Rep): Adjust description.
+ * exp_attr.adb (Expand_N_Attribute_Reference) <Pred>:
+ Reimplement in the case of an enumeration type with non-standard
+ but contiguous representation.
+ <Succ>: Likewise.
+ <Val>: Likewise.
+ * exp_ch3.adb (Expand_Freeze_Enumeration_Type): Count the
+ literals in the first loop. If the representation is
+ contiguous, just build the index type of the array type and set
+ Enum_Pos_To_Rep to it.
+
+2020-06-03 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_attr.adb (Expand_Loop_Entry_Attribute): Revise loop that
+ resets the scopes of entities associated with Loop_Id to the
+ scope of the new function, so the resetting is not restricted to
+ itypes, but excludes loop parameters and the function entity
+ itself. However, this fix is believed to be incomplete and a ???
+ comment is added to indicate that.
+
+2020-06-03 Bob Duff <duff@adacore.com>
+
+ * libgnat/s-regexp.ads: Fix comment
+
+2020-06-03 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference) <Enum_Rep>:
+ In the case of an enumeration type, do an intermediate
+ conversion to a small integer type. Remove useless stuff.
+ <Finalization_Size>: Do not hardcode Universal_Integer and
+ fix a type mismatch in the assignment to the variable.
+ <Max_Size_In_Storage_Elements>: Likewise.
+ <From_Any>: Do not redefine the Ptyp local variable.
+ <To_Any>: Likewise.
+ <TypeCode>: Likewise.
+ <Pos>: Small tweaks.
+ <Val>: For an enumeration type with standard representation,
+ apply the range check to the expression of a convertion to
+ Universal_Integer, if any. For an integer type, expand to
+ a mere conversion.
+
+2020-06-03 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-rannum.adb (Random_Discrete): In the 32-bit case,
+ use the same linear implementation as in the 64-bit case when
+ the type has a contiguous representation.
+
+2020-06-03 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_util.adb (Build_Class_Wide_Clone_Decl): Call
+ Set_Debug_Info_Needed to set the Needs_Debug_Info flag on
+ Clone_Id if the flag is set on Spec_Id.
+
+2020-06-03 Yannick Moy <moy@adacore.com>
+
+ * inline.adb (Expand_Inlined_Call): Do not suppress checks on
+ inlined code in GNATprove mode.
+
+2020-06-03 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (Has_Contiguous_Rep): Fix typo in comment.
+
+2020-06-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * checks.adb, einfo.adb, exp_aggr.adb, exp_ch4.adb, exp_ch6.adb,
+ exp_unst.adb, exp_util.adb, freeze.adb, inline.adb, repinfo.adb,
+ sem_aggr.adb, sem_attr.adb, sem_aux.adb, sem_ch13.adb,
+ sem_ch3.adb, sem_ch4.adb, sem_ch8.adb, sem_elab.adb,
+ sem_eval.adb, sem_prag.adb, sem_res.adb, sem_smem.adb,
+ sem_util.adb, treepr.adb: Replace uses of Next_ functions with
+ corresponding procedures.
+
+2020-06-03 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_attr.adb (Attribute_Valid): Use Standard_Long_Long_Integer
+ in lieu of Universal_Integer as large integer type.
+ * exp_ch3.adb (Expand_Freeze_Enumeration_Type): Likewise.
+
+2020-06-03 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-auxdec.ads (Address_Int): New.
+
+2020-06-03 Arnaud Charlet <charlet@adacore.com>
+
+ * aspects.adb, aspects.ads, atree.adb, atree.ads, elists.adb,
+ elists.ads, fname.adb, fname.ads, gnat1drv.adb, lib.adb,
+ lib.ads, namet.adb, namet.ads, nlists.adb, nlists.ads, opt.adb,
+ opt.ads, osint-c.adb, osint-c.ads, repinfo.adb, repinfo.ads,
+ sem_aux.adb, sem_aux.ads, sinput.adb, sinput.ads, stand.ads,
+ stringt.adb, stringt.ads, switch-c.adb, table.adb, table.ads,
+ uintp.adb, uintp.ads, urealp.adb, urealp.ads (Tree_Read,
+ Tree_Write): Remove generation of ASIS trees.
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst:
+ Remove -gnatt and -gnatct documentation.
+ * gnat_ugn.texi: Regenerate.
+ * tree_in.ads, tree_in.adb, tree_io.ads, tree_io.adb,
+ tree_gen.ads, tree_gen.adb, stand.adb: Remove.
+ * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Remove
+ references to tree_gen.o tree_in.o tree_io.o.
+
+2020-06-03 Eric Botcazou <ebotcazou@adacore.com>
+
+ * opt.ads (Disable_FE_Inline): Move around.
+ (Disable_FE_Inline_Always): Likewise.
+
+2020-06-03 Eric Botcazou <ebotcazou@adacore.com>
+
+ * checks.adb (Is_Single_Attribute_Reference): New predicate.
+ (Generate_Range_Check): Do not force the evaluation if the
+ node is a single attribute reference.
+ * exp_util.adb (Side_Effect_Free_Attribute): New predicate.
+ (Side_Effect_Free) <N_Attribute_Reference>: Call it.
+ (Remove_Side_Effects): Remove the side effects of the prefix
+ for an attribute reference whose prefix is not a name.
+
+2020-06-03 Arnaud Charlet <charlet@adacore.com>
+
+ * switch-c.adb (Scan_Front_End_Switches): Remove processing of
+ -gnatt.
+ * usage.adb (Usage): Remove mention of -gnatt.
+
+2020-06-03 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sinfo.ads: Minor tweaks in commentary.
+
+2020-06-02 Alexandre Oliva <oliva@adacore.com>
+
+ * lib.ads (Compilation_Switches): Remove -auxbase from
+ comments.
+ * switch.ads (Is_Internal_GCC_Switch): Likewise.
+
+2020-06-02 Arnaud Charlet <charlet@adacore.com>
+
+ * atree.ads, checks.adb, contracts.adb, debug.adb, einfo.ads,
+ exp_ch3.adb, exp_util.adb, expander.ads, expander.adb,
+ frontend.adb, gnat1drv.adb, itypes.adb, lib.ads, namet.ads,
+ opt.adb, opt.ads, par-prag.adb, repinfo.ads, sem_aggr.adb,
+ sem_aux.ads, sem_case.ads, sem_ch10.adb, sem_ch12.adb,
+ sem_ch13.adb, sem_ch3.adb, sem_ch4.adb, sem_ch6.adb,
+ sem_dim.adb, sem_elab.adb, sem_prag.adb, sem_prag.ads,
+ sem_res.adb, sem_type.adb, sem_util.adb, sinfo.ads, stand.ads,
+ tree_io.ads: Remove references to ASIS_Mode.
+
+2020-06-02 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch4.adb (Generate_Temporary): New subprogram of
+ Discrete_Range_Check that generates a temporary to facilitate
+ the C backend the code generation of the unchecked conversion
+ since the size of the source type may differ from the size of
+ the target type.
+
+2020-06-02 Arnaud Charlet <charlet@adacore.com>
+
+ * ada_get_targ.adb: Bump copyright year.
+ * adabkend.adb: Likewise.
+ * adabkend.ads: Likewise.
+ * adadecode.c: Likewise.
+ * adadecode.h: Likewise.
+ * adaint.c: Likewise.
+ * adaint.h: Likewise.
+ * affinity.c: Likewise.
+ * ali-util.adb: Likewise.
+ * ali-util.ads: Likewise.
+ * ali.adb: Likewise.
+ * ali.ads: Likewise.
+ * alloc.ads: Likewise.
+ * argv-lynxos178-raven-cert.c: Likewise.
+ * argv.c: Likewise.
+ * aspects.adb: Likewise.
+ * aspects.ads: Likewise.
+ * atree.adb: Likewise.
+ * atree.ads: Likewise.
+ * atree.h: Likewise.
+ * aux-io.c: Likewise.
+ * back_end.adb: Likewise.
+ * back_end.ads: Likewise.
+ * bcheck.adb: Likewise.
+ * bcheck.ads: Likewise.
+ * binde.adb: Likewise.
+ * binde.ads: Likewise.
+ * binderr.adb: Likewise.
+ * binderr.ads: Likewise.
+ * bindgen.adb: Likewise.
+ * bindgen.ads: Likewise.
+ * bindo-augmentors.adb: Likewise.
+ * bindo-augmentors.ads: Likewise.
+ * bindo-builders.adb: Likewise.
+ * bindo-builders.ads: Likewise.
+ * bindo-diagnostics.adb: Likewise.
+ * bindo-diagnostics.ads: Likewise.
+ * bindo-elaborators.adb: Likewise.
+ * bindo-elaborators.ads: Likewise.
+ * bindo-graphs.adb: Likewise.
+ * bindo-graphs.ads: Likewise.
+ * bindo-units.adb: Likewise.
+ * bindo-units.ads: Likewise.
+ * bindo-validators.adb: Likewise.
+ * bindo-validators.ads: Likewise.
+ * bindo-writers.adb: Likewise.
+ * bindo-writers.ads: Likewise.
+ * bindo.adb: Likewise.
+ * bindo.ads: Likewise.
+ * bindusg.adb: Likewise.
+ * bindusg.ads: Likewise.
+ * butil.adb: Likewise.
+ * butil.ads: Likewise.
+ * cal.c: Likewise.
+ * casing.adb: Likewise.
+ * casing.ads: Likewise.
+ * ceinfo.adb: Likewise.
+ * checks.adb: Likewise.
+ * checks.ads: Likewise.
+ * cio.c: Likewise.
+ * clean.adb: Likewise.
+ * clean.ads: Likewise.
+ * comperr.adb: Likewise.
+ * comperr.ads: Likewise.
+ * contracts.adb: Likewise.
+ * contracts.ads: Likewise.
+ * csets.adb: Likewise.
+ * csets.ads: Likewise.
+ * csinfo.adb: Likewise.
+ * cstand.adb: Likewise.
+ * cstand.ads: Likewise.
+ * cstreams.c: Likewise.
+ * ctrl_c.c: Likewise.
+ * debug.adb: Likewise.
+ * debug.ads: Likewise.
+ * debug_a.adb: Likewise.
+ * debug_a.ads: Likewise.
+ * einfo.adb: Likewise.
+ * einfo.ads: Likewise.
+ * elists.adb: Likewise.
+ * elists.ads: Likewise.
+ * elists.h: Likewise.
+ * env.c: Likewise.
+ * env.h: Likewise.
+ * err_vars.ads: Likewise.
+ * errno.c: Likewise.
+ * errout.adb: Likewise.
+ * errout.ads: Likewise.
+ * erroutc.adb: Likewise.
+ * erroutc.ads: Likewise.
+ * errutil.adb: Likewise.
+ * errutil.ads: Likewise.
+ * eval_fat.adb: Likewise.
+ * eval_fat.ads: Likewise.
+ * exit.c: Likewise.
+ * exp_aggr.adb: Likewise.
+ * exp_aggr.ads: Likewise.
+ * exp_atag.adb: Likewise.
+ * exp_atag.ads: Likewise.
+ * exp_attr.adb: Likewise.
+ * exp_attr.ads: Likewise.
+ * exp_cg.adb: Likewise.
+ * exp_cg.ads: Likewise.
+ * exp_ch10.ads: Likewise.
+ * exp_ch11.adb: Likewise.
+ * exp_ch11.ads: Likewise.
+ * exp_ch12.adb: Likewise.
+ * exp_ch12.ads: Likewise.
+ * exp_ch13.adb: Likewise.
+ * exp_ch13.ads: Likewise.
+ * exp_ch2.adb: Likewise.
+ * exp_ch2.ads: Likewise.
+ * exp_ch3.adb: Likewise.
+ * exp_ch3.ads: Likewise.
+ * exp_ch4.adb: Likewise.
+ * exp_ch4.ads: Likewise.
+ * exp_ch5.adb: Likewise.
+ * exp_ch5.ads: Likewise.
+ * exp_ch6.adb: Likewise.
+ * exp_ch6.ads: Likewise.
+ * exp_ch7.adb: Likewise.
+ * exp_ch7.ads: Likewise.
+ * exp_ch8.adb: Likewise.
+ * exp_ch8.ads: Likewise.
+ * exp_ch9.adb: Likewise.
+ * exp_ch9.ads: Likewise.
+ * exp_code.adb: Likewise.
+ * exp_code.ads: Likewise.
+ * exp_dbug.adb: Likewise.
+ * exp_dbug.ads: Likewise.
+ * exp_disp.adb: Likewise.
+ * exp_disp.ads: Likewise.
+ * exp_dist.adb: Likewise.
+ * exp_dist.ads: Likewise.
+ * exp_fixd.adb: Likewise.
+ * exp_fixd.ads: Likewise.
+ * exp_imgv.adb: Likewise.
+ * exp_imgv.ads: Likewise.
+ * exp_intr.adb: Likewise.
+ * exp_intr.ads: Likewise.
+ * exp_pakd.adb: Likewise.
+ * exp_pakd.ads: Likewise.
+ * exp_prag.adb: Likewise.
+ * exp_prag.ads: Likewise.
+ * exp_sel.adb: Likewise.
+ * exp_sel.ads: Likewise.
+ * exp_smem.adb: Likewise.
+ * exp_smem.ads: Likewise.
+ * exp_spark.adb: Likewise.
+ * exp_spark.ads: Likewise.
+ * exp_strm.adb: Likewise.
+ * exp_strm.ads: Likewise.
+ * exp_tss.adb: Likewise.
+ * exp_tss.ads: Likewise.
+ * exp_unst.adb: Likewise.
+ * exp_unst.ads: Likewise.
+ * exp_util.adb: Likewise.
+ * exp_util.ads: Likewise.
+ * expander.adb: Likewise.
+ * expander.ads: Likewise.
+ * expect.c: Likewise.
+ * fe.h: Likewise.
+ * final.c: Likewise.
+ * fmap.adb: Likewise.
+ * fmap.ads: Likewise.
+ * fname-sf.adb: Likewise.
+ * fname-sf.ads: Likewise.
+ * fname-uf.adb: Likewise.
+ * fname-uf.ads: Likewise.
+ * fname.adb: Likewise.
+ * fname.ads: Likewise.
+ * freeze.adb: Likewise.
+ * freeze.ads: Likewise.
+ * frontend.adb: Likewise.
+ * frontend.ads: Likewise.
+ * get_scos.adb: Likewise.
+ * get_scos.ads: Likewise.
+ * get_targ.adb: Likewise.
+ * get_targ.ads: Likewise.
+ * ghost.adb: Likewise.
+ * ghost.ads: Likewise.
+ * gnat1drv.adb: Likewise.
+ * gnat1drv.ads: Likewise.
+ * gnatbind.adb: Likewise.
+ * gnatbind.ads: Likewise.
+ * gnatchop.adb: Likewise.
+ * gnatclean.adb: Likewise.
+ * gnatcmd.adb: Likewise.
+ * gnatcmd.ads: Likewise.
+ * gnatdll.adb: Likewise.
+ * gnatfind.adb: Likewise.
+ * gnatkr.adb: Likewise.
+ * gnatkr.ads: Likewise.
+ * gnatlink.adb: Likewise.
+ * gnatlink.ads: Likewise.
+ * gnatls.adb: Likewise.
+ * gnatls.ads: Likewise.
+ * gnatmake.adb: Likewise.
+ * gnatmake.ads: Likewise.
+ * gnatname.adb: Likewise.
+ * gnatname.ads: Likewise.
+ * gnatprep.adb: Likewise.
+ * gnatprep.ads: Likewise.
+ * gnatvsn.adb: Likewise.
+ * gnatxref.adb: Likewise.
+ * gprep.adb: Likewise.
+ * gprep.ads: Likewise.
+ * gsocket.h: Likewise.
+ * hostparm.ads: Likewise.
+ * impunit.adb: Likewise.
+ * impunit.ads: Likewise.
+ * indepsw-aix.adb: Likewise.
+ * indepsw-darwin.adb: Likewise.
+ * indepsw-gnu.adb: Likewise.
+ * indepsw.adb: Likewise.
+ * indepsw.ads: Likewise.
+ * init.c: Likewise.
+ * initialize.c: Likewise.
+ * inline.adb: Likewise.
+ * inline.ads: Likewise.
+ * itypes.adb: Likewise.
+ * itypes.ads: Likewise.
+ * krunch.adb: Likewise.
+ * krunch.ads: Likewise.
+ * layout.adb: Likewise.
+ * layout.ads: Likewise.
+ * lib-list.adb: Likewise.
+ * lib-load.adb: Likewise.
+ * lib-load.ads: Likewise.
+ * lib-sort.adb: Likewise.
+ * lib-util.adb: Likewise.
+ * lib-util.ads: Likewise.
+ * lib-writ.adb: Likewise.
+ * lib-writ.ads: Likewise.
+ * lib-xref-spark_specific.adb: Likewise.
+ * lib-xref.adb: Likewise.
+ * lib-xref.ads: Likewise.
+ * lib.adb: Likewise.
+ * lib.ads: Likewise.
+ * libgnarl/a-astaco.adb: Likewise.
+ * libgnarl/a-dispat.adb: Likewise.
+ * libgnarl/a-dynpri.adb: Likewise.
+ * libgnarl/a-etgrbu.ads: Likewise.
+ * libgnarl/a-exetim__darwin.adb: Likewise.
+ * libgnarl/a-exetim__default.ads: Likewise.
+ * libgnarl/a-exetim__mingw.adb: Likewise.
+ * libgnarl/a-exetim__mingw.ads: Likewise.
+ * libgnarl/a-exetim__posix.adb: Likewise.
+ * libgnarl/a-interr.adb: Likewise.
+ * libgnarl/a-interr.ads: Likewise.
+ * libgnarl/a-intnam.ads: Likewise.
+ * libgnarl/a-intnam__aix.ads: Likewise.
+ * libgnarl/a-intnam__darwin.ads: Likewise.
+ * libgnarl/a-intnam__dragonfly.ads: Likewise.
+ * libgnarl/a-intnam__dummy.ads: Likewise.
+ * libgnarl/a-intnam__freebsd.ads: Likewise.
+ * libgnarl/a-intnam__hpux.ads: Likewise.
+ * libgnarl/a-intnam__linux.ads: Likewise.
+ * libgnarl/a-intnam__lynxos.ads: Likewise.
+ * libgnarl/a-intnam__mingw.ads: Likewise.
+ * libgnarl/a-intnam__qnx.ads: Likewise.
+ * libgnarl/a-intnam__rtems.ads: Likewise.
+ * libgnarl/a-intnam__solaris.ads: Likewise.
+ * libgnarl/a-intnam__vxworks.ads: Likewise.
+ * libgnarl/a-reatim.adb: Likewise.
+ * libgnarl/a-reatim.ads: Likewise.
+ * libgnarl/a-retide.adb: Likewise.
+ * libgnarl/a-retide.ads: Likewise.
+ * libgnarl/a-rttiev.adb: Likewise.
+ * libgnarl/a-rttiev.ads: Likewise.
+ * libgnarl/a-synbar.adb: Likewise.
+ * libgnarl/a-synbar.ads: Likewise.
+ * libgnarl/a-synbar__posix.adb: Likewise.
+ * libgnarl/a-synbar__posix.ads: Likewise.
+ * libgnarl/a-sytaco.adb: Likewise.
+ * libgnarl/a-sytaco.ads: Likewise.
+ * libgnarl/a-tasatt.adb: Likewise.
+ * libgnarl/a-tasatt.ads: Likewise.
+ * libgnarl/a-taside.adb: Likewise.
+ * libgnarl/a-taside.ads: Likewise.
+ * libgnarl/a-taster.adb: Likewise.
+ * libgnarl/g-boubuf.adb: Likewise.
+ * libgnarl/g-boubuf.ads: Likewise.
+ * libgnarl/g-boumai.ads: Likewise.
+ * libgnarl/g-semaph.adb: Likewise.
+ * libgnarl/g-semaph.ads: Likewise.
+ * libgnarl/g-signal.adb: Likewise.
+ * libgnarl/g-signal.ads: Likewise.
+ * libgnarl/g-tastus.ads: Likewise.
+ * libgnarl/g-thread.adb: Likewise.
+ * libgnarl/g-thread.ads: Likewise.
+ * libgnarl/i-vxinco.adb: Likewise.
+ * libgnarl/i-vxinco.ads: Likewise.
+ * libgnarl/s-inmaop.ads: Likewise.
+ * libgnarl/s-inmaop__dummy.adb: Likewise.
+ * libgnarl/s-inmaop__posix.adb: Likewise.
+ * libgnarl/s-inmaop__vxworks.adb: Likewise.
+ * libgnarl/s-interr.adb: Likewise.
+ * libgnarl/s-interr.ads: Likewise.
+ * libgnarl/s-interr__dummy.adb: Likewise.
+ * libgnarl/s-interr__hwint.adb: Likewise.
+ * libgnarl/s-interr__sigaction.adb: Likewise.
+ * libgnarl/s-interr__vxworks.adb: Likewise.
+ * libgnarl/s-intman.ads: Likewise.
+ * libgnarl/s-intman__android.adb: Likewise.
+ * libgnarl/s-intman__dummy.adb: Likewise.
+ * libgnarl/s-intman__lynxos.adb: Likewise.
+ * libgnarl/s-intman__mingw.adb: Likewise.
+ * libgnarl/s-intman__posix.adb: Likewise.
+ * libgnarl/s-intman__qnx.adb: Likewise.
+ * libgnarl/s-intman__solaris.adb: Likewise.
+ * libgnarl/s-intman__susv3.adb: Likewise.
+ * libgnarl/s-intman__vxworks.adb: Likewise.
+ * libgnarl/s-intman__vxworks.ads: Likewise.
+ * libgnarl/s-linux.ads: Likewise.
+ * libgnarl/s-linux__alpha.ads: Likewise.
+ * libgnarl/s-linux__android.ads: Likewise.
+ * libgnarl/s-linux__hppa.ads: Likewise.
+ * libgnarl/s-linux__mips.ads: Likewise.
+ * libgnarl/s-linux__riscv.ads: Likewise.
+ * libgnarl/s-linux__sparc.ads: Likewise.
+ * libgnarl/s-linux__x32.ads: Likewise.
+ * libgnarl/s-mudido.adb: Likewise.
+ * libgnarl/s-mudido__affinity.adb: Likewise.
+ * libgnarl/s-osinte__aix.adb: Likewise.
+ * libgnarl/s-osinte__aix.ads: Likewise.
+ * libgnarl/s-osinte__android.adb: Likewise.
+ * libgnarl/s-osinte__android.ads: Likewise.
+ * libgnarl/s-osinte__darwin.adb: Likewise.
+ * libgnarl/s-osinte__darwin.ads: Likewise.
+ * libgnarl/s-osinte__dragonfly.adb: Likewise.
+ * libgnarl/s-osinte__dragonfly.ads: Likewise.
+ * libgnarl/s-osinte__dummy.ads: Likewise.
+ * libgnarl/s-osinte__freebsd.adb: Likewise.
+ * libgnarl/s-osinte__freebsd.ads: Likewise.
+ * libgnarl/s-osinte__gnu.adb: Likewise.
+ * libgnarl/s-osinte__gnu.ads: Likewise.
+ * libgnarl/s-osinte__hpux-dce.adb: Likewise.
+ * libgnarl/s-osinte__hpux-dce.ads: Likewise.
+ * libgnarl/s-osinte__hpux.ads: Likewise.
+ * libgnarl/s-osinte__kfreebsd-gnu.ads: Likewise.
+ * libgnarl/s-osinte__linux.ads: Likewise.
+ * libgnarl/s-osinte__lynxos178.adb: Likewise.
+ * libgnarl/s-osinte__lynxos178e.ads: Likewise.
+ * libgnarl/s-osinte__mingw.ads: Likewise.
+ * libgnarl/s-osinte__posix.adb: Likewise.
+ * libgnarl/s-osinte__qnx.adb: Likewise.
+ * libgnarl/s-osinte__qnx.ads: Likewise.
+ * libgnarl/s-osinte__rtems.adb: Likewise.
+ * libgnarl/s-osinte__rtems.ads: Likewise.
+ * libgnarl/s-osinte__solaris.adb: Likewise.
+ * libgnarl/s-osinte__solaris.ads: Likewise.
+ * libgnarl/s-osinte__vxworks.adb: Likewise.
+ * libgnarl/s-osinte__vxworks.ads: Likewise.
+ * libgnarl/s-osinte__x32.adb: Likewise.
+ * libgnarl/s-proinf.adb: Likewise.
+ * libgnarl/s-proinf.ads: Likewise.
+ * libgnarl/s-qnx.ads: Likewise.
+ * libgnarl/s-solita.adb: Likewise.
+ * libgnarl/s-solita.ads: Likewise.
+ * libgnarl/s-stusta.adb: Likewise.
+ * libgnarl/s-stusta.ads: Likewise.
+ * libgnarl/s-taasde.adb: Likewise.
+ * libgnarl/s-taasde.ads: Likewise.
+ * libgnarl/s-tadeca.adb: Likewise.
+ * libgnarl/s-tadeca.ads: Likewise.
+ * libgnarl/s-tadert.adb: Likewise.
+ * libgnarl/s-tadert.ads: Likewise.
+ * libgnarl/s-taenca.adb: Likewise.
+ * libgnarl/s-taenca.ads: Likewise.
+ * libgnarl/s-taprob.adb: Likewise.
+ * libgnarl/s-taprob.ads: Likewise.
+ * libgnarl/s-taprop.ads: Likewise.
+ * libgnarl/s-taprop__dummy.adb: Likewise.
+ * libgnarl/s-taprop__hpux-dce.adb: Likewise.
+ * libgnarl/s-taprop__linux.adb: Likewise.
+ * libgnarl/s-taprop__mingw.adb: Likewise.
+ * libgnarl/s-taprop__posix.adb: Likewise.
+ * libgnarl/s-taprop__qnx.adb: Likewise.
+ * libgnarl/s-taprop__solaris.adb: Likewise.
+ * libgnarl/s-taprop__vxworks.adb: Likewise.
+ * libgnarl/s-tarest.adb: Likewise.
+ * libgnarl/s-tarest.ads: Likewise.
+ * libgnarl/s-tasdeb.adb: Likewise.
+ * libgnarl/s-tasdeb.ads: Likewise.
+ * libgnarl/s-tasinf.adb: Likewise.
+ * libgnarl/s-tasinf.ads: Likewise.
+ * libgnarl/s-tasinf__linux.adb: Likewise.
+ * libgnarl/s-tasinf__linux.ads: Likewise.
+ * libgnarl/s-tasinf__mingw.adb: Likewise.
+ * libgnarl/s-tasinf__mingw.ads: Likewise.
+ * libgnarl/s-tasinf__solaris.adb: Likewise.
+ * libgnarl/s-tasinf__solaris.ads: Likewise.
+ * libgnarl/s-tasinf__vxworks.ads: Likewise.
+ * libgnarl/s-tasini.adb: Likewise.
+ * libgnarl/s-tasini.ads: Likewise.
+ * libgnarl/s-taskin.adb: Likewise.
+ * libgnarl/s-taskin.ads: Likewise.
+ * libgnarl/s-taspri__dummy.ads: Likewise.
+ * libgnarl/s-taspri__hpux-dce.ads: Likewise.
+ * libgnarl/s-taspri__lynxos.ads: Likewise.
+ * libgnarl/s-taspri__mingw.ads: Likewise.
+ * libgnarl/s-taspri__posix-noaltstack.ads: Likewise.
+ * libgnarl/s-taspri__posix.ads: Likewise.
+ * libgnarl/s-taspri__solaris.ads: Likewise.
+ * libgnarl/s-taspri__vxworks.ads: Likewise.
+ * libgnarl/s-tasque.adb: Likewise.
+ * libgnarl/s-tasque.ads: Likewise.
+ * libgnarl/s-tasren.adb: Likewise.
+ * libgnarl/s-tasren.ads: Likewise.
+ * libgnarl/s-tasres.ads: Likewise.
+ * libgnarl/s-tassta.adb: Likewise.
+ * libgnarl/s-tassta.ads: Likewise.
+ * libgnarl/s-tasuti.adb: Likewise.
+ * libgnarl/s-tasuti.ads: Likewise.
+ * libgnarl/s-tataat.adb: Likewise.
+ * libgnarl/s-tataat.ads: Likewise.
+ * libgnarl/s-tpinop.adb: Likewise.
+ * libgnarl/s-tpinop.ads: Likewise.
+ * libgnarl/s-tpoaal.adb: Likewise.
+ * libgnarl/s-tpoben.adb: Likewise.
+ * libgnarl/s-tpoben.ads: Likewise.
+ * libgnarl/s-tpobmu.adb: Likewise.
+ * libgnarl/s-tpobmu.ads: Likewise.
+ * libgnarl/s-tpobop.adb: Likewise.
+ * libgnarl/s-tpobop.ads: Likewise.
+ * libgnarl/s-tpopmo.adb: Likewise.
+ * libgnarl/s-tpopsp__posix-foreign.adb: Likewise.
+ * libgnarl/s-tpopsp__posix.adb: Likewise.
+ * libgnarl/s-tpopsp__solaris.adb: Likewise.
+ * libgnarl/s-tpopsp__tls.adb: Likewise.
+ * libgnarl/s-tpopsp__vxworks-rtp.adb: Likewise.
+ * libgnarl/s-tpopsp__vxworks-tls.adb: Likewise.
+ * libgnarl/s-tpopsp__vxworks.adb: Likewise.
+ * libgnarl/s-tporft.adb: Likewise.
+ * libgnarl/s-tposen.adb: Likewise.
+ * libgnarl/s-tposen.ads: Likewise.
+ * libgnarl/s-vxwext.adb: Likewise.
+ * libgnarl/s-vxwext.ads: Likewise.
+ * libgnarl/s-vxwext__kernel-smp.adb: Likewise.
+ * libgnarl/s-vxwext__kernel.adb: Likewise.
+ * libgnarl/s-vxwext__kernel.ads: Likewise.
+ * libgnarl/s-vxwext__noints.adb: Likewise.
+ * libgnarl/s-vxwext__rtp-smp.adb: Likewise.
+ * libgnarl/s-vxwext__rtp.adb: Likewise.
+ * libgnarl/s-vxwext__rtp.ads: Likewise.
+ * libgnarl/s-vxwext__vthreads.ads: Likewise.
+ * libgnarl/s-vxwork__aarch64.ads: Likewise.
+ * libgnarl/s-vxwork__arm.ads: Likewise.
+ * libgnarl/s-vxwork__ppc.ads: Likewise.
+ * libgnarl/s-vxwork__x86.ads: Likewise.
+ * libgnarl/thread.c: Likewise.
+ * libgnat/a-assert.adb: Likewise.
+ * libgnat/a-assert.ads: Likewise.
+ * libgnat/a-btgbso.adb: Likewise.
+ * libgnat/a-btgbso.ads: Likewise.
+ * libgnat/a-calari.adb: Likewise.
+ * libgnat/a-calari.ads: Likewise.
+ * libgnat/a-calcon.adb: Likewise.
+ * libgnat/a-calcon.ads: Likewise.
+ * libgnat/a-caldel.adb: Likewise.
+ * libgnat/a-caldel.ads: Likewise.
+ * libgnat/a-calend.adb: Likewise.
+ * libgnat/a-calend.ads: Likewise.
+ * libgnat/a-calfor.adb: Likewise.
+ * libgnat/a-calfor.ads: Likewise.
+ * libgnat/a-catizo.adb: Likewise.
+ * libgnat/a-cbdlli.adb: Likewise.
+ * libgnat/a-cbdlli.ads: Likewise.
+ * libgnat/a-cbhama.adb: Likewise.
+ * libgnat/a-cbhama.ads: Likewise.
+ * libgnat/a-cbhase.adb: Likewise.
+ * libgnat/a-cbhase.ads: Likewise.
+ * libgnat/a-cbmutr.adb: Likewise.
+ * libgnat/a-cbmutr.ads: Likewise.
+ * libgnat/a-cborma.adb: Likewise.
+ * libgnat/a-cborma.ads: Likewise.
+ * libgnat/a-cborse.adb: Likewise.
+ * libgnat/a-cborse.ads: Likewise.
+ * libgnat/a-cbprqu.adb: Likewise.
+ * libgnat/a-cbprqu.ads: Likewise.
+ * libgnat/a-cbsyqu.adb: Likewise.
+ * libgnat/a-cbsyqu.ads: Likewise.
+ * libgnat/a-cdlili.adb: Likewise.
+ * libgnat/a-cdlili.ads: Likewise.
+ * libgnat/a-cfdlli.adb: Likewise.
+ * libgnat/a-cfdlli.ads: Likewise.
+ * libgnat/a-cfhama.adb: Likewise.
+ * libgnat/a-cfhama.ads: Likewise.
+ * libgnat/a-cfhase.adb: Likewise.
+ * libgnat/a-cfhase.ads: Likewise.
+ * libgnat/a-cfinve.adb: Likewise.
+ * libgnat/a-cfinve.ads: Likewise.
+ * libgnat/a-cforma.adb: Likewise.
+ * libgnat/a-cforma.ads: Likewise.
+ * libgnat/a-cforse.adb: Likewise.
+ * libgnat/a-cforse.ads: Likewise.
+ * libgnat/a-cgaaso.adb: Likewise.
+ * libgnat/a-cgaaso.ads: Likewise.
+ * libgnat/a-cgarso.adb: Likewise.
+ * libgnat/a-cgcaso.adb: Likewise.
+ * libgnat/a-chacon.adb: Likewise.
+ * libgnat/a-chacon.ads: Likewise.
+ * libgnat/a-chahan.adb: Likewise.
+ * libgnat/a-chahan.ads: Likewise.
+ * libgnat/a-chlat9.ads: Likewise.
+ * libgnat/a-chtgbk.adb: Likewise.
+ * libgnat/a-chtgbk.ads: Likewise.
+ * libgnat/a-chtgbo.adb: Likewise.
+ * libgnat/a-chtgbo.ads: Likewise.
+ * libgnat/a-chtgke.adb: Likewise.
+ * libgnat/a-chtgke.ads: Likewise.
+ * libgnat/a-chtgop.adb: Likewise.
+ * libgnat/a-chtgop.ads: Likewise.
+ * libgnat/a-chzla1.ads: Likewise.
+ * libgnat/a-chzla9.ads: Likewise.
+ * libgnat/a-cidlli.adb: Likewise.
+ * libgnat/a-cidlli.ads: Likewise.
+ * libgnat/a-cihama.adb: Likewise.
+ * libgnat/a-cihama.ads: Likewise.
+ * libgnat/a-cihase.adb: Likewise.
+ * libgnat/a-cihase.ads: Likewise.
+ * libgnat/a-cimutr.adb: Likewise.
+ * libgnat/a-cimutr.ads: Likewise.
+ * libgnat/a-ciorma.adb: Likewise.
+ * libgnat/a-ciorma.ads: Likewise.
+ * libgnat/a-ciormu.adb: Likewise.
+ * libgnat/a-ciormu.ads: Likewise.
+ * libgnat/a-ciorse.adb: Likewise.
+ * libgnat/a-ciorse.ads: Likewise.
+ * libgnat/a-clrefi.adb: Likewise.
+ * libgnat/a-clrefi.ads: Likewise.
+ * libgnat/a-coboho.adb: Likewise.
+ * libgnat/a-coboho.ads: Likewise.
+ * libgnat/a-cobove.adb: Likewise.
+ * libgnat/a-cobove.ads: Likewise.
+ * libgnat/a-cofove.adb: Likewise.
+ * libgnat/a-cofove.ads: Likewise.
+ * libgnat/a-cofuba.adb: Likewise.
+ * libgnat/a-cofuba.ads: Likewise.
+ * libgnat/a-cofuma.adb: Likewise.
+ * libgnat/a-cofuma.ads: Likewise.
+ * libgnat/a-cofuse.adb: Likewise.
+ * libgnat/a-cofuse.ads: Likewise.
+ * libgnat/a-cofuve.adb: Likewise.
+ * libgnat/a-cofuve.ads: Likewise.
+ * libgnat/a-cogeso.adb: Likewise.
+ * libgnat/a-cogeso.ads: Likewise.
+ * libgnat/a-cohama.adb: Likewise.
+ * libgnat/a-cohama.ads: Likewise.
+ * libgnat/a-cohase.adb: Likewise.
+ * libgnat/a-cohase.ads: Likewise.
+ * libgnat/a-cohata.ads: Likewise.
+ * libgnat/a-coinho.adb: Likewise.
+ * libgnat/a-coinho.ads: Likewise.
+ * libgnat/a-coinho__shared.adb: Likewise.
+ * libgnat/a-coinho__shared.ads: Likewise.
+ * libgnat/a-coinve.adb: Likewise.
+ * libgnat/a-coinve.ads: Likewise.
+ * libgnat/a-colien.adb: Likewise.
+ * libgnat/a-colien.ads: Likewise.
+ * libgnat/a-colire.adb: Likewise.
+ * libgnat/a-colire.ads: Likewise.
+ * libgnat/a-comlin.adb: Likewise.
+ * libgnat/a-comlin.ads: Likewise.
+ * libgnat/a-comutr.adb: Likewise.
+ * libgnat/a-comutr.ads: Likewise.
+ * libgnat/a-conhel.adb: Likewise.
+ * libgnat/a-conhel.ads: Likewise.
+ * libgnat/a-convec.adb: Likewise.
+ * libgnat/a-convec.ads: Likewise.
+ * libgnat/a-coorma.adb: Likewise.
+ * libgnat/a-coorma.ads: Likewise.
+ * libgnat/a-coormu.adb: Likewise.
+ * libgnat/a-coormu.ads: Likewise.
+ * libgnat/a-coorse.adb: Likewise.
+ * libgnat/a-coorse.ads: Likewise.
+ * libgnat/a-coprnu.adb: Likewise.
+ * libgnat/a-coprnu.ads: Likewise.
+ * libgnat/a-crbltr.ads: Likewise.
+ * libgnat/a-crbtgk.adb: Likewise.
+ * libgnat/a-crbtgk.ads: Likewise.
+ * libgnat/a-crbtgo.adb: Likewise.
+ * libgnat/a-crbtgo.ads: Likewise.
+ * libgnat/a-crdlli.adb: Likewise.
+ * libgnat/a-crdlli.ads: Likewise.
+ * libgnat/a-csquin.ads: Likewise.
+ * libgnat/a-cuprqu.adb: Likewise.
+ * libgnat/a-cuprqu.ads: Likewise.
+ * libgnat/a-cusyqu.adb: Likewise.
+ * libgnat/a-cusyqu.ads: Likewise.
+ * libgnat/a-cwila1.ads: Likewise.
+ * libgnat/a-cwila9.ads: Likewise.
+ * libgnat/a-decima.adb: Likewise.
+ * libgnat/a-decima.ads: Likewise.
+ * libgnat/a-dhfina.adb: Likewise.
+ * libgnat/a-dhfina.ads: Likewise.
+ * libgnat/a-diocst.adb: Likewise.
+ * libgnat/a-diocst.ads: Likewise.
+ * libgnat/a-direct.adb: Likewise.
+ * libgnat/a-direct.ads: Likewise.
+ * libgnat/a-direio.adb: Likewise.
+ * libgnat/a-direio.ads: Likewise.
+ * libgnat/a-dirval.adb: Likewise.
+ * libgnat/a-dirval.ads: Likewise.
+ * libgnat/a-dirval__mingw.adb: Likewise.
+ * libgnat/a-einuoc.adb: Likewise.
+ * libgnat/a-einuoc.ads: Likewise.
+ * libgnat/a-elchha.adb: Likewise.
+ * libgnat/a-elchha.ads: Likewise.
+ * libgnat/a-elchha__vxworks-ppc-full.adb: Likewise.
+ * libgnat/a-envvar.adb: Likewise.
+ * libgnat/a-excach.adb: Likewise.
+ * libgnat/a-except.adb: Likewise.
+ * libgnat/a-except.ads: Likewise.
+ * libgnat/a-excpol.adb: Likewise.
+ * libgnat/a-excpol__abort.adb: Likewise.
+ * libgnat/a-exctra.adb: Likewise.
+ * libgnat/a-exctra.ads: Likewise.
+ * libgnat/a-exexda.adb: Likewise.
+ * libgnat/a-exexpr.adb: Likewise.
+ * libgnat/a-exextr.adb: Likewise.
+ * libgnat/a-exstat.adb: Likewise.
+ * libgnat/a-finali.adb: Likewise.
+ * libgnat/a-finali.ads: Likewise.
+ * libgnat/a-locale.adb: Likewise.
+ * libgnat/a-locale.ads: Likewise.
+ * libgnat/a-nbnbin.adb: Likewise.
+ * libgnat/a-nbnbin__gmp.adb: Likewise.
+ * libgnat/a-nbnbre.adb: Likewise.
+ * libgnat/a-ngcefu.adb: Likewise.
+ * libgnat/a-ngcoar.adb: Likewise.
+ * libgnat/a-ngcoty.adb: Likewise.
+ * libgnat/a-ngcoty.ads: Likewise.
+ * libgnat/a-ngelfu.adb: Likewise.
+ * libgnat/a-ngelfu.ads: Likewise.
+ * libgnat/a-ngrear.adb: Likewise.
+ * libgnat/a-ngrear.ads: Likewise.
+ * libgnat/a-nudira.adb: Likewise.
+ * libgnat/a-nudira.ads: Likewise.
+ * libgnat/a-nuflra.adb: Likewise.
+ * libgnat/a-nuflra.ads: Likewise.
+ * libgnat/a-numaux.ads: Likewise.
+ * libgnat/a-numaux__darwin.adb: Likewise.
+ * libgnat/a-numaux__darwin.ads: Likewise.
+ * libgnat/a-numaux__libc-x86.ads: Likewise.
+ * libgnat/a-numaux__vxworks.ads: Likewise.
+ * libgnat/a-numaux__x86.adb: Likewise.
+ * libgnat/a-numaux__x86.ads: Likewise.
+ * libgnat/a-rbtgbk.adb: Likewise.
+ * libgnat/a-rbtgbk.ads: Likewise.
+ * libgnat/a-rbtgbo.adb: Likewise.
+ * libgnat/a-rbtgbo.ads: Likewise.
+ * libgnat/a-rbtgso.adb: Likewise.
+ * libgnat/a-rbtgso.ads: Likewise.
+ * libgnat/a-sbecin.adb: Likewise.
+ * libgnat/a-sbecin.ads: Likewise.
+ * libgnat/a-sbhcin.adb: Likewise.
+ * libgnat/a-sbhcin.ads: Likewise.
+ * libgnat/a-sblcin.adb: Likewise.
+ * libgnat/a-sblcin.ads: Likewise.
+ * libgnat/a-secain.adb: Likewise.
+ * libgnat/a-secain.ads: Likewise.
+ * libgnat/a-sequio.adb: Likewise.
+ * libgnat/a-sequio.ads: Likewise.
+ * libgnat/a-sfecin.ads: Likewise.
+ * libgnat/a-sfhcin.ads: Likewise.
+ * libgnat/a-sflcin.ads: Likewise.
+ * libgnat/a-shcain.adb: Likewise.
+ * libgnat/a-shcain.ads: Likewise.
+ * libgnat/a-siocst.adb: Likewise.
+ * libgnat/a-siocst.ads: Likewise.
+ * libgnat/a-slcain.adb: Likewise.
+ * libgnat/a-slcain.ads: Likewise.
+ * libgnat/a-ssicst.adb: Likewise.
+ * libgnat/a-ssicst.ads: Likewise.
+ * libgnat/a-stboha.adb: Likewise.
+ * libgnat/a-stmaco.ads: Likewise.
+ * libgnat/a-storio.adb: Likewise.
+ * libgnat/a-strbou.adb: Likewise.
+ * libgnat/a-strbou.ads: Likewise.
+ * libgnat/a-stream.adb: Likewise.
+ * libgnat/a-stream.ads: Likewise.
+ * libgnat/a-strfix.adb: Likewise.
+ * libgnat/a-strhas.adb: Likewise.
+ * libgnat/a-strmap.adb: Likewise.
+ * libgnat/a-strmap.ads: Likewise.
+ * libgnat/a-strsea.adb: Likewise.
+ * libgnat/a-strsea.ads: Likewise.
+ * libgnat/a-strsup.adb: Likewise.
+ * libgnat/a-strsup.ads: Likewise.
+ * libgnat/a-strunb.adb: Likewise.
+ * libgnat/a-strunb.ads: Likewise.
+ * libgnat/a-strunb__shared.adb: Likewise.
+ * libgnat/a-strunb__shared.ads: Likewise.
+ * libgnat/a-ststio.adb: Likewise.
+ * libgnat/a-ststio.ads: Likewise.
+ * libgnat/a-stunau.adb: Likewise.
+ * libgnat/a-stunau.ads: Likewise.
+ * libgnat/a-stunau__shared.adb: Likewise.
+ * libgnat/a-stunha.adb: Likewise.
+ * libgnat/a-stuten.adb: Likewise.
+ * libgnat/a-stwibo.adb: Likewise.
+ * libgnat/a-stwibo.ads: Likewise.
+ * libgnat/a-stwifi.adb: Likewise.
+ * libgnat/a-stwiha.adb: Likewise.
+ * libgnat/a-stwima.adb: Likewise.
+ * libgnat/a-stwima.ads: Likewise.
+ * libgnat/a-stwise.adb: Likewise.
+ * libgnat/a-stwise.ads: Likewise.
+ * libgnat/a-stwisu.adb: Likewise.
+ * libgnat/a-stwisu.ads: Likewise.
+ * libgnat/a-stwiun.adb: Likewise.
+ * libgnat/a-stwiun.ads: Likewise.
+ * libgnat/a-stwiun__shared.adb: Likewise.
+ * libgnat/a-stwiun__shared.ads: Likewise.
+ * libgnat/a-stzbou.adb: Likewise.
+ * libgnat/a-stzbou.ads: Likewise.
+ * libgnat/a-stzfix.adb: Likewise.
+ * libgnat/a-stzhas.adb: Likewise.
+ * libgnat/a-stzmap.adb: Likewise.
+ * libgnat/a-stzmap.ads: Likewise.
+ * libgnat/a-stzsea.adb: Likewise.
+ * libgnat/a-stzsea.ads: Likewise.
+ * libgnat/a-stzsup.adb: Likewise.
+ * libgnat/a-stzsup.ads: Likewise.
+ * libgnat/a-stzunb.adb: Likewise.
+ * libgnat/a-stzunb.ads: Likewise.
+ * libgnat/a-stzunb__shared.adb: Likewise.
+ * libgnat/a-stzunb__shared.ads: Likewise.
+ * libgnat/a-suecin.adb: Likewise.
+ * libgnat/a-suecin.ads: Likewise.
+ * libgnat/a-suenco.adb: Likewise.
+ * libgnat/a-suenst.adb: Likewise.
+ * libgnat/a-suewst.adb: Likewise.
+ * libgnat/a-suezst.adb: Likewise.
+ * libgnat/a-suhcin.adb: Likewise.
+ * libgnat/a-suhcin.ads: Likewise.
+ * libgnat/a-sulcin.adb: Likewise.
+ * libgnat/a-sulcin.ads: Likewise.
+ * libgnat/a-suteio.adb: Likewise.
+ * libgnat/a-suteio.ads: Likewise.
+ * libgnat/a-suteio__shared.adb: Likewise.
+ * libgnat/a-swbwha.adb: Likewise.
+ * libgnat/a-swmwco.ads: Likewise.
+ * libgnat/a-swunau.adb: Likewise.
+ * libgnat/a-swunau.ads: Likewise.
+ * libgnat/a-swunau__shared.adb: Likewise.
+ * libgnat/a-swuwha.adb: Likewise.
+ * libgnat/a-swuwti.adb: Likewise.
+ * libgnat/a-swuwti.ads: Likewise.
+ * libgnat/a-swuwti__shared.adb: Likewise.
+ * libgnat/a-szbzha.adb: Likewise.
+ * libgnat/a-szmzco.ads: Likewise.
+ * libgnat/a-szunau.adb: Likewise.
+ * libgnat/a-szunau.ads: Likewise.
+ * libgnat/a-szunau__shared.adb: Likewise.
+ * libgnat/a-szuzha.adb: Likewise.
+ * libgnat/a-szuzti.adb: Likewise.
+ * libgnat/a-szuzti.ads: Likewise.
+ * libgnat/a-szuzti__shared.adb: Likewise.
+ * libgnat/a-tags.adb: Likewise.
+ * libgnat/a-tags.ads: Likewise.
+ * libgnat/a-teioed.adb: Likewise.
+ * libgnat/a-teioed.ads: Likewise.
+ * libgnat/a-textio.adb: Likewise.
+ * libgnat/a-textio.ads: Likewise.
+ * libgnat/a-tiboio.adb: Likewise.
+ * libgnat/a-ticoau.adb: Likewise.
+ * libgnat/a-ticoau.ads: Likewise.
+ * libgnat/a-ticoio.adb: Likewise.
+ * libgnat/a-ticoio.ads: Likewise.
+ * libgnat/a-tideau.adb: Likewise.
+ * libgnat/a-tideau.ads: Likewise.
+ * libgnat/a-tideio.adb: Likewise.
+ * libgnat/a-tideio.ads: Likewise.
+ * libgnat/a-tienau.adb: Likewise.
+ * libgnat/a-tienau.ads: Likewise.
+ * libgnat/a-tienio.adb: Likewise.
+ * libgnat/a-tifiio.adb: Likewise.
+ * libgnat/a-tiflau.adb: Likewise.
+ * libgnat/a-tiflau.ads: Likewise.
+ * libgnat/a-tiflio.adb: Likewise.
+ * libgnat/a-tiflio.ads: Likewise.
+ * libgnat/a-tigeau.adb: Likewise.
+ * libgnat/a-tigeau.ads: Likewise.
+ * libgnat/a-tigeli.adb: Likewise.
+ * libgnat/a-tiinau.adb: Likewise.
+ * libgnat/a-tiinau.ads: Likewise.
+ * libgnat/a-tiinio.adb: Likewise.
+ * libgnat/a-tiinio.ads: Likewise.
+ * libgnat/a-timoau.adb: Likewise.
+ * libgnat/a-timoau.ads: Likewise.
+ * libgnat/a-timoio.adb: Likewise.
+ * libgnat/a-timoio.ads: Likewise.
+ * libgnat/a-tiocst.adb: Likewise.
+ * libgnat/a-tiocst.ads: Likewise.
+ * libgnat/a-tirsfi.adb: Likewise.
+ * libgnat/a-tirsfi.ads: Likewise.
+ * libgnat/a-titest.adb: Likewise.
+ * libgnat/a-undesu.adb: Likewise.
+ * libgnat/a-wichha.adb: Likewise.
+ * libgnat/a-wichun.adb: Likewise.
+ * libgnat/a-wichun.ads: Likewise.
+ * libgnat/a-witeio.adb: Likewise.
+ * libgnat/a-witeio.ads: Likewise.
+ * libgnat/a-wrstfi.adb: Likewise.
+ * libgnat/a-wrstfi.ads: Likewise.
+ * libgnat/a-wtcoau.adb: Likewise.
+ * libgnat/a-wtcoau.ads: Likewise.
+ * libgnat/a-wtcoio.adb: Likewise.
+ * libgnat/a-wtcstr.adb: Likewise.
+ * libgnat/a-wtcstr.ads: Likewise.
+ * libgnat/a-wtdeau.adb: Likewise.
+ * libgnat/a-wtdeau.ads: Likewise.
+ * libgnat/a-wtdeio.adb: Likewise.
+ * libgnat/a-wtedit.adb: Likewise.
+ * libgnat/a-wtedit.ads: Likewise.
+ * libgnat/a-wtenau.adb: Likewise.
+ * libgnat/a-wtenau.ads: Likewise.
+ * libgnat/a-wtenio.adb: Likewise.
+ * libgnat/a-wtfiio.adb: Likewise.
+ * libgnat/a-wtflau.adb: Likewise.
+ * libgnat/a-wtflau.ads: Likewise.
+ * libgnat/a-wtflio.adb: Likewise.
+ * libgnat/a-wtgeau.adb: Likewise.
+ * libgnat/a-wtgeau.ads: Likewise.
+ * libgnat/a-wtinau.adb: Likewise.
+ * libgnat/a-wtinau.ads: Likewise.
+ * libgnat/a-wtinio.adb: Likewise.
+ * libgnat/a-wtmoau.adb: Likewise.
+ * libgnat/a-wtmoau.ads: Likewise.
+ * libgnat/a-wtmoio.adb: Likewise.
+ * libgnat/a-wtmoio.ads: Likewise.
+ * libgnat/a-wttest.adb: Likewise.
+ * libgnat/a-wwboio.adb: Likewise.
+ * libgnat/a-zchhan.adb: Likewise.
+ * libgnat/a-zchuni.adb: Likewise.
+ * libgnat/a-zchuni.ads: Likewise.
+ * libgnat/a-zrstfi.adb: Likewise.
+ * libgnat/a-zrstfi.ads: Likewise.
+ * libgnat/a-ztcoau.adb: Likewise.
+ * libgnat/a-ztcoio.adb: Likewise.
+ * libgnat/a-ztcstr.adb: Likewise.
+ * libgnat/a-ztcstr.ads: Likewise.
+ * libgnat/a-ztdeau.adb: Likewise.
+ * libgnat/a-ztdeau.ads: Likewise.
+ * libgnat/a-ztdeio.adb: Likewise.
+ * libgnat/a-ztedit.adb: Likewise.
+ * libgnat/a-ztedit.ads: Likewise.
+ * libgnat/a-ztenau.adb: Likewise.
+ * libgnat/a-ztenau.ads: Likewise.
+ * libgnat/a-ztenio.adb: Likewise.
+ * libgnat/a-ztexio.adb: Likewise.
+ * libgnat/a-ztexio.ads: Likewise.
+ * libgnat/a-ztfiio.adb: Likewise.
+ * libgnat/a-ztflau.adb: Likewise.
+ * libgnat/a-ztflau.ads: Likewise.
+ * libgnat/a-ztflio.adb: Likewise.
+ * libgnat/a-ztgeau.adb: Likewise.
+ * libgnat/a-ztgeau.ads: Likewise.
+ * libgnat/a-ztinau.adb: Likewise.
+ * libgnat/a-ztinau.ads: Likewise.
+ * libgnat/a-ztinio.adb: Likewise.
+ * libgnat/a-ztmoau.adb: Likewise.
+ * libgnat/a-ztmoau.ads: Likewise.
+ * libgnat/a-ztmoio.adb: Likewise.
+ * libgnat/a-zttest.adb: Likewise.
+ * libgnat/a-zzboio.adb: Likewise.
+ * libgnat/g-allein.ads: Likewise.
+ * libgnat/g-alleve.adb: Likewise.
+ * libgnat/g-alleve.ads: Likewise.
+ * libgnat/g-alleve__hard.adb: Likewise.
+ * libgnat/g-alleve__hard.ads: Likewise.
+ * libgnat/g-altcon.adb: Likewise.
+ * libgnat/g-altcon.ads: Likewise.
+ * libgnat/g-altive.ads: Likewise.
+ * libgnat/g-alveop.adb: Likewise.
+ * libgnat/g-alveop.ads: Likewise.
+ * libgnat/g-alvety.ads: Likewise.
+ * libgnat/g-alvevi.ads: Likewise.
+ * libgnat/g-arrspl.adb: Likewise.
+ * libgnat/g-arrspl.ads: Likewise.
+ * libgnat/g-awk.adb: Likewise.
+ * libgnat/g-awk.ads: Likewise.
+ * libgnat/g-binenv.adb: Likewise.
+ * libgnat/g-binenv.ads: Likewise.
+ * libgnat/g-brapre.ads: Likewise.
+ * libgnat/g-bubsor.adb: Likewise.
+ * libgnat/g-bubsor.ads: Likewise.
+ * libgnat/g-busora.adb: Likewise.
+ * libgnat/g-busora.ads: Likewise.
+ * libgnat/g-busorg.adb: Likewise.
+ * libgnat/g-busorg.ads: Likewise.
+ * libgnat/g-byorma.adb: Likewise.
+ * libgnat/g-byorma.ads: Likewise.
+ * libgnat/g-bytswa.adb: Likewise.
+ * libgnat/g-bytswa.ads: Likewise.
+ * libgnat/g-calend.adb: Likewise.
+ * libgnat/g-calend.ads: Likewise.
+ * libgnat/g-casuti.adb: Likewise.
+ * libgnat/g-casuti.ads: Likewise.
+ * libgnat/g-catiio.adb: Likewise.
+ * libgnat/g-catiio.ads: Likewise.
+ * libgnat/g-cgi.adb: Likewise.
+ * libgnat/g-cgi.ads: Likewise.
+ * libgnat/g-cgicoo.adb: Likewise.
+ * libgnat/g-cgicoo.ads: Likewise.
+ * libgnat/g-cgideb.adb: Likewise.
+ * libgnat/g-cgideb.ads: Likewise.
+ * libgnat/g-comlin.adb: Likewise.
+ * libgnat/g-comlin.ads: Likewise.
+ * libgnat/g-comver.adb: Likewise.
+ * libgnat/g-comver.ads: Likewise.
+ * libgnat/g-cppexc.adb: Likewise.
+ * libgnat/g-cppexc.ads: Likewise.
+ * libgnat/g-crc32.adb: Likewise.
+ * libgnat/g-crc32.ads: Likewise.
+ * libgnat/g-ctrl_c.adb: Likewise.
+ * libgnat/g-ctrl_c.ads: Likewise.
+ * libgnat/g-curexc.ads: Likewise.
+ * libgnat/g-debpoo.adb: Likewise.
+ * libgnat/g-debpoo.ads: Likewise.
+ * libgnat/g-debuti.adb: Likewise.
+ * libgnat/g-debuti.ads: Likewise.
+ * libgnat/g-decstr.adb: Likewise.
+ * libgnat/g-decstr.ads: Likewise.
+ * libgnat/g-deutst.ads: Likewise.
+ * libgnat/g-diopit.adb: Likewise.
+ * libgnat/g-diopit.ads: Likewise.
+ * libgnat/g-dirope.adb: Likewise.
+ * libgnat/g-dirope.ads: Likewise.
+ * libgnat/g-dynhta.adb: Likewise.
+ * libgnat/g-dynhta.ads: Likewise.
+ * libgnat/g-dyntab.adb: Likewise.
+ * libgnat/g-dyntab.ads: Likewise.
+ * libgnat/g-eacodu.adb: Likewise.
+ * libgnat/g-encstr.adb: Likewise.
+ * libgnat/g-encstr.ads: Likewise.
+ * libgnat/g-enutst.ads: Likewise.
+ * libgnat/g-excact.adb: Likewise.
+ * libgnat/g-excact.ads: Likewise.
+ * libgnat/g-except.ads: Likewise.
+ * libgnat/g-exctra.adb: Likewise.
+ * libgnat/g-exctra.ads: Likewise.
+ * libgnat/g-expect.adb: Likewise.
+ * libgnat/g-expect.ads: Likewise.
+ * libgnat/g-exptty.adb: Likewise.
+ * libgnat/g-exptty.ads: Likewise.
+ * libgnat/g-flocon.ads: Likewise.
+ * libgnat/g-forstr.adb: Likewise.
+ * libgnat/g-forstr.ads: Likewise.
+ * libgnat/g-graphs.adb: Likewise.
+ * libgnat/g-graphs.ads: Likewise.
+ * libgnat/g-heasor.adb: Likewise.
+ * libgnat/g-heasor.ads: Likewise.
+ * libgnat/g-hesora.adb: Likewise.
+ * libgnat/g-hesora.ads: Likewise.
+ * libgnat/g-hesorg.adb: Likewise.
+ * libgnat/g-hesorg.ads: Likewise.
+ * libgnat/g-htable.adb: Likewise.
+ * libgnat/g-htable.ads: Likewise.
+ * libgnat/g-io-put__vxworks.adb: Likewise.
+ * libgnat/g-io.adb: Likewise.
+ * libgnat/g-io.ads: Likewise.
+ * libgnat/g-io_aux.adb: Likewise.
+ * libgnat/g-io_aux.ads: Likewise.
+ * libgnat/g-lists.adb: Likewise.
+ * libgnat/g-lists.ads: Likewise.
+ * libgnat/g-locfil.adb: Likewise.
+ * libgnat/g-locfil.ads: Likewise.
+ * libgnat/g-mbdira.adb: Likewise.
+ * libgnat/g-mbdira.ads: Likewise.
+ * libgnat/g-mbflra.adb: Likewise.
+ * libgnat/g-mbflra.ads: Likewise.
+ * libgnat/g-md5.adb: Likewise.
+ * libgnat/g-md5.ads: Likewise.
+ * libgnat/g-memdum.adb: Likewise.
+ * libgnat/g-memdum.ads: Likewise.
+ * libgnat/g-moreex.adb: Likewise.
+ * libgnat/g-moreex.ads: Likewise.
+ * libgnat/g-os_lib.adb: Likewise.
+ * libgnat/g-os_lib.ads: Likewise.
+ * libgnat/g-pehage.adb: Likewise.
+ * libgnat/g-pehage.ads: Likewise.
+ * libgnat/g-rannum.adb: Likewise.
+ * libgnat/g-rannum.ads: Likewise.
+ * libgnat/g-regexp.adb: Likewise.
+ * libgnat/g-regexp.ads: Likewise.
+ * libgnat/g-regist.adb: Likewise.
+ * libgnat/g-regist.ads: Likewise.
+ * libgnat/g-regpat.adb: Likewise.
+ * libgnat/g-regpat.ads: Likewise.
+ * libgnat/g-rewdat.adb: Likewise.
+ * libgnat/g-rewdat.ads: Likewise.
+ * libgnat/g-sechas.adb: Likewise.
+ * libgnat/g-sechas.ads: Likewise.
+ * libgnat/g-sehamd.adb: Likewise.
+ * libgnat/g-sehamd.ads: Likewise.
+ * libgnat/g-sehash.adb: Likewise.
+ * libgnat/g-sehash.ads: Likewise.
+ * libgnat/g-sercom.adb: Likewise.
+ * libgnat/g-sercom.ads: Likewise.
+ * libgnat/g-sercom__linux.adb: Likewise.
+ * libgnat/g-sercom__mingw.adb: Likewise.
+ * libgnat/g-sestin.ads: Likewise.
+ * libgnat/g-sets.adb: Likewise.
+ * libgnat/g-sets.ads: Likewise.
+ * libgnat/g-sha1.adb: Likewise.
+ * libgnat/g-sha1.ads: Likewise.
+ * libgnat/g-sha224.ads: Likewise.
+ * libgnat/g-sha256.ads: Likewise.
+ * libgnat/g-sha384.ads: Likewise.
+ * libgnat/g-sha512.ads: Likewise.
+ * libgnat/g-shsh32.adb: Likewise.
+ * libgnat/g-shsh32.ads: Likewise.
+ * libgnat/g-shsh64.adb: Likewise.
+ * libgnat/g-shsh64.ads: Likewise.
+ * libgnat/g-shshco.adb: Likewise.
+ * libgnat/g-shshco.ads: Likewise.
+ * libgnat/g-soccon.ads: Likewise.
+ * libgnat/g-socket.adb: Likewise.
+ * libgnat/g-socket.ads: Likewise.
+ * libgnat/g-socket__dummy.adb: Likewise.
+ * libgnat/g-socket__dummy.ads: Likewise.
+ * libgnat/g-socthi.adb: Likewise.
+ * libgnat/g-socthi.ads: Likewise.
+ * libgnat/g-socthi__dummy.adb: Likewise.
+ * libgnat/g-socthi__dummy.ads: Likewise.
+ * libgnat/g-socthi__mingw.adb: Likewise.
+ * libgnat/g-socthi__mingw.ads: Likewise.
+ * libgnat/g-socthi__vxworks.adb: Likewise.
+ * libgnat/g-socthi__vxworks.ads: Likewise.
+ * libgnat/g-soliop.ads: Likewise.
+ * libgnat/g-soliop__lynxos.ads: Likewise.
+ * libgnat/g-soliop__mingw.ads: Likewise.
+ * libgnat/g-soliop__qnx.ads: Likewise.
+ * libgnat/g-soliop__solaris.ads: Likewise.
+ * libgnat/g-sothco.adb: Likewise.
+ * libgnat/g-sothco.ads: Likewise.
+ * libgnat/g-sothco__dummy.adb: Likewise.
+ * libgnat/g-sothco__dummy.ads: Likewise.
+ * libgnat/g-souinf.ads: Likewise.
+ * libgnat/g-spchge.adb: Likewise.
+ * libgnat/g-spchge.ads: Likewise.
+ * libgnat/g-speche.adb: Likewise.
+ * libgnat/g-speche.ads: Likewise.
+ * libgnat/g-spipat.adb: Likewise.
+ * libgnat/g-spipat.ads: Likewise.
+ * libgnat/g-spitbo.adb: Likewise.
+ * libgnat/g-spitbo.ads: Likewise.
+ * libgnat/g-sptabo.ads: Likewise.
+ * libgnat/g-sptain.ads: Likewise.
+ * libgnat/g-sptavs.ads: Likewise.
+ * libgnat/g-sse.ads: Likewise.
+ * libgnat/g-ssvety.ads: Likewise.
+ * libgnat/g-sthcso.adb: Likewise.
+ * libgnat/g-stheme.adb: Likewise.
+ * libgnat/g-strhas.ads: Likewise.
+ * libgnat/g-string.adb: Likewise.
+ * libgnat/g-string.ads: Likewise.
+ * libgnat/g-strspl.ads: Likewise.
+ * libgnat/g-stseme.adb: Likewise.
+ * libgnat/g-stsifd__sockets.adb: Likewise.
+ * libgnat/g-table.adb: Likewise.
+ * libgnat/g-table.ads: Likewise.
+ * libgnat/g-tasloc.adb: Likewise.
+ * libgnat/g-tasloc.ads: Likewise.
+ * libgnat/g-timsta.adb: Likewise.
+ * libgnat/g-timsta.ads: Likewise.
+ * libgnat/g-traceb.adb: Likewise.
+ * libgnat/g-traceb.ads: Likewise.
+ * libgnat/g-trasym.adb: Likewise.
+ * libgnat/g-trasym.ads: Likewise.
+ * libgnat/g-tty.adb: Likewise.
+ * libgnat/g-tty.ads: Likewise.
+ * libgnat/g-u3spch.adb: Likewise.
+ * libgnat/g-u3spch.ads: Likewise.
+ * libgnat/g-utf_32.adb: Likewise.
+ * libgnat/g-utf_32.ads: Likewise.
+ * libgnat/g-wispch.adb: Likewise.
+ * libgnat/g-wispch.ads: Likewise.
+ * libgnat/g-wistsp.ads: Likewise.
+ * libgnat/g-zspche.adb: Likewise.
+ * libgnat/g-zspche.ads: Likewise.
+ * libgnat/g-zstspl.ads: Likewise.
+ * libgnat/gnat.ads: Likewise.
+ * libgnat/i-c.adb: Likewise.
+ * libgnat/i-cexten.ads: Likewise.
+ * libgnat/i-cobol.adb: Likewise.
+ * libgnat/i-cobol.ads: Likewise.
+ * libgnat/i-cpoint.adb: Likewise.
+ * libgnat/i-cpoint.ads: Likewise.
+ * libgnat/i-cstrea.adb: Likewise.
+ * libgnat/i-cstrea.ads: Likewise.
+ * libgnat/i-cstrin.adb: Likewise.
+ * libgnat/i-cstrin.ads: Likewise.
+ * libgnat/i-fortra.adb: Likewise.
+ * libgnat/i-pacdec.adb: Likewise.
+ * libgnat/i-pacdec.ads: Likewise.
+ * libgnat/i-vxwoio.adb: Likewise.
+ * libgnat/i-vxwoio.ads: Likewise.
+ * libgnat/i-vxwork.ads: Likewise.
+ * libgnat/i-vxwork__x86.ads: Likewise.
+ * libgnat/interfac.ads: Likewise.
+ * libgnat/memtrack.adb: Likewise.
+ * libgnat/s-addima.adb: Likewise.
+ * libgnat/s-addima.ads: Likewise.
+ * libgnat/s-addope.adb: Likewise.
+ * libgnat/s-addope.ads: Likewise.
+ * libgnat/s-aotase.adb: Likewise.
+ * libgnat/s-aotase.ads: Likewise.
+ * libgnat/s-arit64.adb: Likewise.
+ * libgnat/s-arit64.ads: Likewise.
+ * libgnat/s-assert.adb: Likewise.
+ * libgnat/s-assert.ads: Likewise.
+ * libgnat/s-atacco.adb: Likewise.
+ * libgnat/s-atacco.ads: Likewise.
+ * libgnat/s-atocou.adb: Likewise.
+ * libgnat/s-atocou.ads: Likewise.
+ * libgnat/s-atocou__builtin.adb: Likewise.
+ * libgnat/s-atocou__x86.adb: Likewise.
+ * libgnat/s-atoope.ads: Likewise.
+ * libgnat/s-atopar.adb: Likewise.
+ * libgnat/s-atopar.ads: Likewise.
+ * libgnat/s-atopex.adb: Likewise.
+ * libgnat/s-atopex.ads: Likewise.
+ * libgnat/s-atopri.adb: Likewise.
+ * libgnat/s-atopri.ads: Likewise.
+ * libgnat/s-auxdec.adb: Likewise.
+ * libgnat/s-auxdec.ads: Likewise.
+ * libgnat/s-bignum.adb: Likewise.
+ * libgnat/s-bignum.ads: Likewise.
+ * libgnat/s-bitfie.ads: Likewise.
+ * libgnat/s-bitops.adb: Likewise.
+ * libgnat/s-bitops.ads: Likewise.
+ * libgnat/s-bituti.adb: Likewise.
+ * libgnat/s-bituti.ads: Likewise.
+ * libgnat/s-boarop.ads: Likewise.
+ * libgnat/s-boustr.adb: Likewise.
+ * libgnat/s-boustr.ads: Likewise.
+ * libgnat/s-bytswa.ads: Likewise.
+ * libgnat/s-carsi8.adb: Likewise.
+ * libgnat/s-carsi8.ads: Likewise.
+ * libgnat/s-carun8.adb: Likewise.
+ * libgnat/s-carun8.ads: Likewise.
+ * libgnat/s-casi16.adb: Likewise.
+ * libgnat/s-casi16.ads: Likewise.
+ * libgnat/s-casi32.adb: Likewise.
+ * libgnat/s-casi32.ads: Likewise.
+ * libgnat/s-casi64.adb: Likewise.
+ * libgnat/s-casi64.ads: Likewise.
+ * libgnat/s-casuti.adb: Likewise.
+ * libgnat/s-casuti.ads: Likewise.
+ * libgnat/s-caun16.adb: Likewise.
+ * libgnat/s-caun16.ads: Likewise.
+ * libgnat/s-caun32.adb: Likewise.
+ * libgnat/s-caun32.ads: Likewise.
+ * libgnat/s-caun64.adb: Likewise.
+ * libgnat/s-caun64.ads: Likewise.
+ * libgnat/s-chepoo.ads: Likewise.
+ * libgnat/s-commun.adb: Likewise.
+ * libgnat/s-commun.ads: Likewise.
+ * libgnat/s-conca2.adb: Likewise.
+ * libgnat/s-conca2.ads: Likewise.
+ * libgnat/s-conca3.adb: Likewise.
+ * libgnat/s-conca3.ads: Likewise.
+ * libgnat/s-conca4.adb: Likewise.
+ * libgnat/s-conca4.ads: Likewise.
+ * libgnat/s-conca5.adb: Likewise.
+ * libgnat/s-conca5.ads: Likewise.
+ * libgnat/s-conca6.adb: Likewise.
+ * libgnat/s-conca6.ads: Likewise.
+ * libgnat/s-conca7.adb: Likewise.
+ * libgnat/s-conca7.ads: Likewise.
+ * libgnat/s-conca8.adb: Likewise.
+ * libgnat/s-conca8.ads: Likewise.
+ * libgnat/s-conca9.adb: Likewise.
+ * libgnat/s-conca9.ads: Likewise.
+ * libgnat/s-crc32.adb: Likewise.
+ * libgnat/s-crc32.ads: Likewise.
+ * libgnat/s-crtl.ads: Likewise.
+ * libgnat/s-dfmkio.ads: Likewise.
+ * libgnat/s-dfmopr.ads: Likewise.
+ * libgnat/s-dgmgop.ads: Likewise.
+ * libgnat/s-diflio.adb: Likewise.
+ * libgnat/s-diflio.ads: Likewise.
+ * libgnat/s-diflmk.ads: Likewise.
+ * libgnat/s-digemk.ads: Likewise.
+ * libgnat/s-diinio.adb: Likewise.
+ * libgnat/s-diinio.ads: Likewise.
+ * libgnat/s-dilomk.ads: Likewise.
+ * libgnat/s-dim.ads: Likewise.
+ * libgnat/s-dimkio.ads: Likewise.
+ * libgnat/s-dimmks.ads: Likewise.
+ * libgnat/s-direio.adb: Likewise.
+ * libgnat/s-direio.ads: Likewise.
+ * libgnat/s-dlmkio.ads: Likewise.
+ * libgnat/s-dlmopr.ads: Likewise.
+ * libgnat/s-dmotpr.ads: Likewise.
+ * libgnat/s-dsaser.ads: Likewise.
+ * libgnat/s-dwalin.adb: Likewise.
+ * libgnat/s-dwalin.ads: Likewise.
+ * libgnat/s-elaall.adb: Likewise.
+ * libgnat/s-elaall.ads: Likewise.
+ * libgnat/s-excdeb.adb: Likewise.
+ * libgnat/s-excdeb.ads: Likewise.
+ * libgnat/s-except.adb: Likewise.
+ * libgnat/s-except.ads: Likewise.
+ * libgnat/s-excmac__arm.adb: Likewise.
+ * libgnat/s-excmac__arm.ads: Likewise.
+ * libgnat/s-excmac__gcc.adb: Likewise.
+ * libgnat/s-excmac__gcc.ads: Likewise.
+ * libgnat/s-exctab.adb: Likewise.
+ * libgnat/s-exctab.ads: Likewise.
+ * libgnat/s-exctra.adb: Likewise.
+ * libgnat/s-exctra.ads: Likewise.
+ * libgnat/s-exnint.adb: Likewise.
+ * libgnat/s-exnint.ads: Likewise.
+ * libgnat/s-exnllf.adb: Likewise.
+ * libgnat/s-exnllf.ads: Likewise.
+ * libgnat/s-exnlli.adb: Likewise.
+ * libgnat/s-exnlli.ads: Likewise.
+ * libgnat/s-expint.adb: Likewise.
+ * libgnat/s-expint.ads: Likewise.
+ * libgnat/s-explli.adb: Likewise.
+ * libgnat/s-explli.ads: Likewise.
+ * libgnat/s-expllu.adb: Likewise.
+ * libgnat/s-expllu.ads: Likewise.
+ * libgnat/s-expmod.adb: Likewise.
+ * libgnat/s-expmod.ads: Likewise.
+ * libgnat/s-expuns.adb: Likewise.
+ * libgnat/s-expuns.ads: Likewise.
+ * libgnat/s-fatflt.ads: Likewise.
+ * libgnat/s-fatgen.adb: Likewise.
+ * libgnat/s-fatgen.ads: Likewise.
+ * libgnat/s-fatlfl.ads: Likewise.
+ * libgnat/s-fatllf.ads: Likewise.
+ * libgnat/s-fatsfl.ads: Likewise.
+ * libgnat/s-ficobl.ads: Likewise.
+ * libgnat/s-filatt.ads: Likewise.
+ * libgnat/s-fileio.adb: Likewise.
+ * libgnat/s-fileio.ads: Likewise.
+ * libgnat/s-finmas.adb: Likewise.
+ * libgnat/s-finmas.ads: Likewise.
+ * libgnat/s-finroo.adb: Likewise.
+ * libgnat/s-finroo.ads: Likewise.
+ * libgnat/s-flocon.adb: Likewise.
+ * libgnat/s-flocon.ads: Likewise.
+ * libgnat/s-flocon__none.adb: Likewise.
+ * libgnat/s-fore.adb: Likewise.
+ * libgnat/s-fore.ads: Likewise.
+ * libgnat/s-gearop.adb: Likewise.
+ * libgnat/s-gearop.ads: Likewise.
+ * libgnat/s-genbig.adb: Likewise.
+ * libgnat/s-genbig.ads: Likewise.
+ * libgnat/s-geveop.adb: Likewise.
+ * libgnat/s-geveop.ads: Likewise.
+ * libgnat/s-gloloc.adb: Likewise.
+ * libgnat/s-gloloc.ads: Likewise.
+ * libgnat/s-gloloc__mingw.adb: Likewise.
+ * libgnat/s-htable.adb: Likewise.
+ * libgnat/s-htable.ads: Likewise.
+ * libgnat/s-imenne.adb: Likewise.
+ * libgnat/s-imenne.ads: Likewise.
+ * libgnat/s-imgbiu.adb: Likewise.
+ * libgnat/s-imgbiu.ads: Likewise.
+ * libgnat/s-imgboo.adb: Likewise.
+ * libgnat/s-imgboo.ads: Likewise.
+ * libgnat/s-imgcha.adb: Likewise.
+ * libgnat/s-imgcha.ads: Likewise.
+ * libgnat/s-imgdec.adb: Likewise.
+ * libgnat/s-imgdec.ads: Likewise.
+ * libgnat/s-imgenu.adb: Likewise.
+ * libgnat/s-imgenu.ads: Likewise.
+ * libgnat/s-imgint.adb: Likewise.
+ * libgnat/s-imgint.ads: Likewise.
+ * libgnat/s-imgllb.adb: Likewise.
+ * libgnat/s-imgllb.ads: Likewise.
+ * libgnat/s-imglld.adb: Likewise.
+ * libgnat/s-imglld.ads: Likewise.
+ * libgnat/s-imglli.adb: Likewise.
+ * libgnat/s-imglli.ads: Likewise.
+ * libgnat/s-imgllu.adb: Likewise.
+ * libgnat/s-imgllu.ads: Likewise.
+ * libgnat/s-imgllw.adb: Likewise.
+ * libgnat/s-imgllw.ads: Likewise.
+ * libgnat/s-imgrea.adb: Likewise.
+ * libgnat/s-imgrea.ads: Likewise.
+ * libgnat/s-imguns.adb: Likewise.
+ * libgnat/s-imguns.ads: Likewise.
+ * libgnat/s-imgwch.adb: Likewise.
+ * libgnat/s-imgwch.ads: Likewise.
+ * libgnat/s-imgwiu.adb: Likewise.
+ * libgnat/s-imgwiu.ads: Likewise.
+ * libgnat/s-io.adb: Likewise.
+ * libgnat/s-io.ads: Likewise.
+ * libgnat/s-llflex.ads: Likewise.
+ * libgnat/s-maccod.ads: Likewise.
+ * libgnat/s-mantis.adb: Likewise.
+ * libgnat/s-mantis.ads: Likewise.
+ * libgnat/s-mastop.adb: Likewise.
+ * libgnat/s-mastop.ads: Likewise.
+ * libgnat/s-memcop.ads: Likewise.
+ * libgnat/s-memory.adb: Likewise.
+ * libgnat/s-memory.ads: Likewise.
+ * libgnat/s-mmap.adb: Likewise.
+ * libgnat/s-mmap.ads: Likewise.
+ * libgnat/s-mmauni__long.ads: Likewise.
+ * libgnat/s-mmosin__mingw.adb: Likewise.
+ * libgnat/s-mmosin__mingw.ads: Likewise.
+ * libgnat/s-mmosin__unix.adb: Likewise.
+ * libgnat/s-mmosin__unix.ads: Likewise.
+ * libgnat/s-multip.adb: Likewise.
+ * libgnat/s-objrea.adb: Likewise.
+ * libgnat/s-objrea.ads: Likewise.
+ * libgnat/s-optide.adb: Likewise.
+ * libgnat/s-os_lib.adb: Likewise.
+ * libgnat/s-os_lib.ads: Likewise.
+ * libgnat/s-osprim.ads: Likewise.
+ * libgnat/s-osprim__darwin.adb: Likewise.
+ * libgnat/s-osprim__lynxos.ads: Likewise.
+ * libgnat/s-osprim__mingw.adb: Likewise.
+ * libgnat/s-osprim__posix.adb: Likewise.
+ * libgnat/s-osprim__posix2008.adb: Likewise.
+ * libgnat/s-osprim__rtems.adb: Likewise.
+ * libgnat/s-osprim__solaris.adb: Likewise.
+ * libgnat/s-osprim__unix.adb: Likewise.
+ * libgnat/s-osprim__vxworks.adb: Likewise.
+ * libgnat/s-osprim__x32.adb: Likewise.
+ * libgnat/s-osvers__vxworks-653.ads: Likewise.
+ * libgnat/s-pack03.adb: Likewise.
+ * libgnat/s-pack03.ads: Likewise.
+ * libgnat/s-pack05.adb: Likewise.
+ * libgnat/s-pack05.ads: Likewise.
+ * libgnat/s-pack06.adb: Likewise.
+ * libgnat/s-pack06.ads: Likewise.
+ * libgnat/s-pack07.adb: Likewise.
+ * libgnat/s-pack07.ads: Likewise.
+ * libgnat/s-pack09.adb: Likewise.
+ * libgnat/s-pack09.ads: Likewise.
+ * libgnat/s-pack10.adb: Likewise.
+ * libgnat/s-pack10.ads: Likewise.
+ * libgnat/s-pack11.adb: Likewise.
+ * libgnat/s-pack11.ads: Likewise.
+ * libgnat/s-pack12.adb: Likewise.
+ * libgnat/s-pack12.ads: Likewise.
+ * libgnat/s-pack13.adb: Likewise.
+ * libgnat/s-pack13.ads: Likewise.
+ * libgnat/s-pack14.adb: Likewise.
+ * libgnat/s-pack14.ads: Likewise.
+ * libgnat/s-pack15.adb: Likewise.
+ * libgnat/s-pack15.ads: Likewise.
+ * libgnat/s-pack17.adb: Likewise.
+ * libgnat/s-pack17.ads: Likewise.
+ * libgnat/s-pack18.adb: Likewise.
+ * libgnat/s-pack18.ads: Likewise.
+ * libgnat/s-pack19.adb: Likewise.
+ * libgnat/s-pack19.ads: Likewise.
+ * libgnat/s-pack20.adb: Likewise.
+ * libgnat/s-pack20.ads: Likewise.
+ * libgnat/s-pack21.adb: Likewise.
+ * libgnat/s-pack21.ads: Likewise.
+ * libgnat/s-pack22.adb: Likewise.
+ * libgnat/s-pack22.ads: Likewise.
+ * libgnat/s-pack23.adb: Likewise.
+ * libgnat/s-pack23.ads: Likewise.
+ * libgnat/s-pack24.adb: Likewise.
+ * libgnat/s-pack24.ads: Likewise.
+ * libgnat/s-pack25.adb: Likewise.
+ * libgnat/s-pack25.ads: Likewise.
+ * libgnat/s-pack26.adb: Likewise.
+ * libgnat/s-pack26.ads: Likewise.
+ * libgnat/s-pack27.adb: Likewise.
+ * libgnat/s-pack27.ads: Likewise.
+ * libgnat/s-pack28.adb: Likewise.
+ * libgnat/s-pack28.ads: Likewise.
+ * libgnat/s-pack29.adb: Likewise.
+ * libgnat/s-pack29.ads: Likewise.
+ * libgnat/s-pack30.adb: Likewise.
+ * libgnat/s-pack30.ads: Likewise.
+ * libgnat/s-pack31.adb: Likewise.
+ * libgnat/s-pack31.ads: Likewise.
+ * libgnat/s-pack33.adb: Likewise.
+ * libgnat/s-pack33.ads: Likewise.
+ * libgnat/s-pack34.adb: Likewise.
+ * libgnat/s-pack34.ads: Likewise.
+ * libgnat/s-pack35.adb: Likewise.
+ * libgnat/s-pack35.ads: Likewise.
+ * libgnat/s-pack36.adb: Likewise.
+ * libgnat/s-pack36.ads: Likewise.
+ * libgnat/s-pack37.adb: Likewise.
+ * libgnat/s-pack37.ads: Likewise.
+ * libgnat/s-pack38.adb: Likewise.
+ * libgnat/s-pack38.ads: Likewise.
+ * libgnat/s-pack39.adb: Likewise.
+ * libgnat/s-pack39.ads: Likewise.
+ * libgnat/s-pack40.adb: Likewise.
+ * libgnat/s-pack40.ads: Likewise.
+ * libgnat/s-pack41.adb: Likewise.
+ * libgnat/s-pack41.ads: Likewise.
+ * libgnat/s-pack42.adb: Likewise.
+ * libgnat/s-pack42.ads: Likewise.
+ * libgnat/s-pack43.adb: Likewise.
+ * libgnat/s-pack43.ads: Likewise.
+ * libgnat/s-pack44.adb: Likewise.
+ * libgnat/s-pack44.ads: Likewise.
+ * libgnat/s-pack45.adb: Likewise.
+ * libgnat/s-pack45.ads: Likewise.
+ * libgnat/s-pack46.adb: Likewise.
+ * libgnat/s-pack46.ads: Likewise.
+ * libgnat/s-pack47.adb: Likewise.
+ * libgnat/s-pack47.ads: Likewise.
+ * libgnat/s-pack48.adb: Likewise.
+ * libgnat/s-pack48.ads: Likewise.
+ * libgnat/s-pack49.adb: Likewise.
+ * libgnat/s-pack49.ads: Likewise.
+ * libgnat/s-pack50.adb: Likewise.
+ * libgnat/s-pack50.ads: Likewise.
+ * libgnat/s-pack51.adb: Likewise.
+ * libgnat/s-pack51.ads: Likewise.
+ * libgnat/s-pack52.adb: Likewise.
+ * libgnat/s-pack52.ads: Likewise.
+ * libgnat/s-pack53.adb: Likewise.
+ * libgnat/s-pack53.ads: Likewise.
+ * libgnat/s-pack54.adb: Likewise.
+ * libgnat/s-pack54.ads: Likewise.
+ * libgnat/s-pack55.adb: Likewise.
+ * libgnat/s-pack55.ads: Likewise.
+ * libgnat/s-pack56.adb: Likewise.
+ * libgnat/s-pack56.ads: Likewise.
+ * libgnat/s-pack57.adb: Likewise.
+ * libgnat/s-pack57.ads: Likewise.
+ * libgnat/s-pack58.adb: Likewise.
+ * libgnat/s-pack58.ads: Likewise.
+ * libgnat/s-pack59.adb: Likewise.
+ * libgnat/s-pack59.ads: Likewise.
+ * libgnat/s-pack60.adb: Likewise.
+ * libgnat/s-pack60.ads: Likewise.
+ * libgnat/s-pack61.adb: Likewise.
+ * libgnat/s-pack61.ads: Likewise.
+ * libgnat/s-pack62.adb: Likewise.
+ * libgnat/s-pack62.ads: Likewise.
+ * libgnat/s-pack63.adb: Likewise.
+ * libgnat/s-pack63.ads: Likewise.
+ * libgnat/s-parame.adb: Likewise.
+ * libgnat/s-parame.ads: Likewise.
+ * libgnat/s-parame__ae653.ads: Likewise.
+ * libgnat/s-parame__hpux.ads: Likewise.
+ * libgnat/s-parame__rtems.adb: Likewise.
+ * libgnat/s-parame__vxworks.adb: Likewise.
+ * libgnat/s-parame__vxworks.ads: Likewise.
+ * libgnat/s-parint.adb: Likewise.
+ * libgnat/s-parint.ads: Likewise.
+ * libgnat/s-pooglo.adb: Likewise.
+ * libgnat/s-pooglo.ads: Likewise.
+ * libgnat/s-pooloc.adb: Likewise.
+ * libgnat/s-pooloc.ads: Likewise.
+ * libgnat/s-poosiz.adb: Likewise.
+ * libgnat/s-poosiz.ads: Likewise.
+ * libgnat/s-powtab.ads: Likewise.
+ * libgnat/s-purexc.ads: Likewise.
+ * libgnat/s-rannum.adb: Likewise.
+ * libgnat/s-rannum.ads: Likewise.
+ * libgnat/s-ransee.adb: Likewise.
+ * libgnat/s-ransee.ads: Likewise.
+ * libgnat/s-regexp.adb: Likewise.
+ * libgnat/s-regexp.ads: Likewise.
+ * libgnat/s-regpat.adb: Likewise.
+ * libgnat/s-regpat.ads: Likewise.
+ * libgnat/s-resfil.adb: Likewise.
+ * libgnat/s-resfil.ads: Likewise.
+ * libgnat/s-restri.adb: Likewise.
+ * libgnat/s-restri.ads: Likewise.
+ * libgnat/s-rident.ads: Likewise.
+ * libgnat/s-rpc.adb: Likewise.
+ * libgnat/s-rpc.ads: Likewise.
+ * libgnat/s-scaval.adb: Likewise.
+ * libgnat/s-scaval.ads: Likewise.
+ * libgnat/s-secsta.adb: Likewise.
+ * libgnat/s-secsta.ads: Likewise.
+ * libgnat/s-sequio.adb: Likewise.
+ * libgnat/s-sequio.ads: Likewise.
+ * libgnat/s-shasto.adb: Likewise.
+ * libgnat/s-shasto.ads: Likewise.
+ * libgnat/s-soflin.adb: Likewise.
+ * libgnat/s-soflin.ads: Likewise.
+ * libgnat/s-soliin.adb: Likewise.
+ * libgnat/s-soliin.ads: Likewise.
+ * libgnat/s-sopco3.adb: Likewise.
+ * libgnat/s-sopco3.ads: Likewise.
+ * libgnat/s-sopco4.adb: Likewise.
+ * libgnat/s-sopco4.ads: Likewise.
+ * libgnat/s-sopco5.adb: Likewise.
+ * libgnat/s-sopco5.ads: Likewise.
+ * libgnat/s-spsufi.adb: Likewise.
+ * libgnat/s-spsufi.ads: Likewise.
+ * libgnat/s-stache.adb: Likewise.
+ * libgnat/s-stache.ads: Likewise.
+ * libgnat/s-stalib.adb: Likewise.
+ * libgnat/s-stalib.ads: Likewise.
+ * libgnat/s-stausa.adb: Likewise.
+ * libgnat/s-stausa.ads: Likewise.
+ * libgnat/s-stchop.adb: Likewise.
+ * libgnat/s-stchop.ads: Likewise.
+ * libgnat/s-stchop__limit.ads: Likewise.
+ * libgnat/s-stchop__rtems.adb: Likewise.
+ * libgnat/s-stchop__vxworks.adb: Likewise.
+ * libgnat/s-stoele.adb: Likewise.
+ * libgnat/s-stoele.ads: Likewise.
+ * libgnat/s-stopoo.adb: Likewise.
+ * libgnat/s-stopoo.ads: Likewise.
+ * libgnat/s-stposu.adb: Likewise.
+ * libgnat/s-stposu.ads: Likewise.
+ * libgnat/s-stratt.adb: Likewise.
+ * libgnat/s-stratt.ads: Likewise.
+ * libgnat/s-stratt__xdr.adb: Likewise.
+ * libgnat/s-strcom.adb: Likewise.
+ * libgnat/s-strcom.ads: Likewise.
+ * libgnat/s-strhas.adb: Likewise.
+ * libgnat/s-strhas.ads: Likewise.
+ * libgnat/s-string.adb: Likewise.
+ * libgnat/s-string.ads: Likewise.
+ * libgnat/s-strops.adb: Likewise.
+ * libgnat/s-strops.ads: Likewise.
+ * libgnat/s-ststop.adb: Likewise.
+ * libgnat/s-ststop.ads: Likewise.
+ * libgnat/s-tasloc.adb: Likewise.
+ * libgnat/s-tasloc.ads: Likewise.
+ * libgnat/s-thread.ads: Likewise.
+ * libgnat/s-thread__ae653.adb: Likewise.
+ * libgnat/s-traceb.adb: Likewise.
+ * libgnat/s-traceb.ads: Likewise.
+ * libgnat/s-traceb__hpux.adb: Likewise.
+ * libgnat/s-traceb__mastop.adb: Likewise.
+ * libgnat/s-traent.adb: Likewise.
+ * libgnat/s-traent.ads: Likewise.
+ * libgnat/s-trasym.adb: Likewise.
+ * libgnat/s-trasym.ads: Likewise.
+ * libgnat/s-trasym__dwarf.adb: Likewise.
+ * libgnat/s-tsmona.adb: Likewise.
+ * libgnat/s-tsmona__linux.adb: Likewise.
+ * libgnat/s-tsmona__mingw.adb: Likewise.
+ * libgnat/s-unstyp.ads: Likewise.
+ * libgnat/s-utf_32.adb: Likewise.
+ * libgnat/s-utf_32.ads: Likewise.
+ * libgnat/s-valboo.adb: Likewise.
+ * libgnat/s-valboo.ads: Likewise.
+ * libgnat/s-valcha.adb: Likewise.
+ * libgnat/s-valcha.ads: Likewise.
+ * libgnat/s-valdec.adb: Likewise.
+ * libgnat/s-valdec.ads: Likewise.
+ * libgnat/s-valenu.adb: Likewise.
+ * libgnat/s-valenu.ads: Likewise.
+ * libgnat/s-valint.adb: Likewise.
+ * libgnat/s-valint.ads: Likewise.
+ * libgnat/s-vallld.adb: Likewise.
+ * libgnat/s-vallld.ads: Likewise.
+ * libgnat/s-vallli.adb: Likewise.
+ * libgnat/s-vallli.ads: Likewise.
+ * libgnat/s-valllu.adb: Likewise.
+ * libgnat/s-valllu.ads: Likewise.
+ * libgnat/s-valrea.adb: Likewise.
+ * libgnat/s-valrea.ads: Likewise.
+ * libgnat/s-valuns.adb: Likewise.
+ * libgnat/s-valuns.ads: Likewise.
+ * libgnat/s-valuti.adb: Likewise.
+ * libgnat/s-valuti.ads: Likewise.
+ * libgnat/s-valwch.adb: Likewise.
+ * libgnat/s-valwch.ads: Likewise.
+ * libgnat/s-veboop.adb: Likewise.
+ * libgnat/s-veboop.ads: Likewise.
+ * libgnat/s-vector.ads: Likewise.
+ * libgnat/s-vercon.adb: Likewise.
+ * libgnat/s-vercon.ads: Likewise.
+ * libgnat/s-wchcnv.adb: Likewise.
+ * libgnat/s-wchcnv.ads: Likewise.
+ * libgnat/s-wchcon.adb: Likewise.
+ * libgnat/s-wchcon.ads: Likewise.
+ * libgnat/s-wchjis.adb: Likewise.
+ * libgnat/s-wchjis.ads: Likewise.
+ * libgnat/s-wchstw.adb: Likewise.
+ * libgnat/s-wchstw.ads: Likewise.
+ * libgnat/s-wchwts.adb: Likewise.
+ * libgnat/s-wchwts.ads: Likewise.
+ * libgnat/s-widboo.adb: Likewise.
+ * libgnat/s-widboo.ads: Likewise.
+ * libgnat/s-widcha.adb: Likewise.
+ * libgnat/s-widcha.ads: Likewise.
+ * libgnat/s-widenu.adb: Likewise.
+ * libgnat/s-widenu.ads: Likewise.
+ * libgnat/s-widlli.adb: Likewise.
+ * libgnat/s-widlli.ads: Likewise.
+ * libgnat/s-widllu.adb: Likewise.
+ * libgnat/s-widllu.ads: Likewise.
+ * libgnat/s-widwch.adb: Likewise.
+ * libgnat/s-widwch.ads: Likewise.
+ * libgnat/s-win32.ads: Likewise.
+ * libgnat/s-winext.ads: Likewise.
+ * libgnat/s-wwdcha.adb: Likewise.
+ * libgnat/s-wwdcha.ads: Likewise.
+ * libgnat/s-wwdenu.adb: Likewise.
+ * libgnat/s-wwdenu.ads: Likewise.
+ * libgnat/s-wwdwch.adb: Likewise.
+ * libgnat/s-wwdwch.ads: Likewise.
+ * libgnat/system-aix.ads: Likewise.
+ * libgnat/system-darwin-arm.ads: Likewise.
+ * libgnat/system-darwin-ppc.ads: Likewise.
+ * libgnat/system-darwin-x86.ads: Likewise.
+ * libgnat/system-djgpp.ads: Likewise.
+ * libgnat/system-dragonfly-x86_64.ads: Likewise.
+ * libgnat/system-freebsd.ads: Likewise.
+ * libgnat/system-hpux-ia64.ads: Likewise.
+ * libgnat/system-hpux.ads: Likewise.
+ * libgnat/system-linux-alpha.ads: Likewise.
+ * libgnat/system-linux-arm.ads: Likewise.
+ * libgnat/system-linux-hppa.ads: Likewise.
+ * libgnat/system-linux-ia64.ads: Likewise.
+ * libgnat/system-linux-m68k.ads: Likewise.
+ * libgnat/system-linux-mips.ads: Likewise.
+ * libgnat/system-linux-ppc.ads: Likewise.
+ * libgnat/system-linux-riscv.ads: Likewise.
+ * libgnat/system-linux-s390.ads: Likewise.
+ * libgnat/system-linux-sh4.ads: Likewise.
+ * libgnat/system-linux-sparc.ads: Likewise.
+ * libgnat/system-linux-x86.ads: Likewise.
+ * libgnat/system-lynxos178-ppc.ads: Likewise.
+ * libgnat/system-lynxos178-x86.ads: Likewise.
+ * libgnat/system-mingw.ads: Likewise.
+ * libgnat/system-qnx-aarch64.ads: Likewise.
+ * libgnat/system-rtems.ads: Likewise.
+ * libgnat/system-solaris-sparc.ads: Likewise.
+ * libgnat/system-solaris-x86.ads: Likewise.
+ * libgnat/system-vxworks-arm-rtp-smp.ads: Likewise.
+ * libgnat/system-vxworks-arm-rtp.ads: Likewise.
+ * libgnat/system-vxworks-arm.ads: Likewise.
+ * libgnat/system-vxworks-e500-kernel.ads: Likewise.
+ * libgnat/system-vxworks-e500-rtp-smp.ads: Likewise.
+ * libgnat/system-vxworks-e500-rtp.ads: Likewise.
+ * libgnat/system-vxworks-e500-vthread.ads: Likewise.
+ * libgnat/system-vxworks-ppc-kernel.ads: Likewise.
+ * libgnat/system-vxworks-ppc-ravenscar.ads: Likewise.
+ * libgnat/system-vxworks-ppc-rtp-smp.ads: Likewise.
+ * libgnat/system-vxworks-ppc-rtp.ads: Likewise.
+ * libgnat/system-vxworks-ppc-vthread.ads: Likewise.
+ * libgnat/system-vxworks-ppc.ads: Likewise.
+ * libgnat/system-vxworks-x86-kernel.ads: Likewise.
+ * libgnat/system-vxworks-x86-rtp-smp.ads: Likewise.
+ * libgnat/system-vxworks-x86-rtp.ads: Likewise.
+ * libgnat/system-vxworks-x86-vthread.ads: Likewise.
+ * libgnat/system-vxworks-x86.ads: Likewise.
+ * libgnat/system-vxworks7-aarch64-rtp-smp.ads: Likewise.
+ * libgnat/system-vxworks7-aarch64.ads: Likewise.
+ * libgnat/system-vxworks7-arm-rtp-smp.ads: Likewise.
+ * libgnat/system-vxworks7-arm.ads: Likewise.
+ * libgnat/system-vxworks7-e500-kernel.ads: Likewise.
+ * libgnat/system-vxworks7-e500-rtp-smp.ads: Likewise.
+ * libgnat/system-vxworks7-e500-rtp.ads: Likewise.
+ * libgnat/system-vxworks7-ppc-kernel.ads: Likewise.
+ * libgnat/system-vxworks7-ppc-rtp-smp.ads: Likewise.
+ * libgnat/system-vxworks7-ppc-rtp.ads: Likewise.
+ * libgnat/system-vxworks7-ppc64-kernel.ads: Likewise.
+ * libgnat/system-vxworks7-ppc64-rtp-smp.ads: Likewise.
+ * libgnat/system-vxworks7-x86-kernel.ads: Likewise.
+ * libgnat/system-vxworks7-x86-rtp-smp.ads: Likewise.
+ * libgnat/system-vxworks7-x86-rtp.ads: Likewise.
+ * libgnat/system-vxworks7-x86_64-kernel.ads: Likewise.
+ * libgnat/system-vxworks7-x86_64-rtp-smp.ads: Likewise.
+ * libgnat/system.ads: Likewise.
+ * link.c: Likewise.
+ * live.adb: Likewise.
+ * live.ads: Likewise.
+ * locales.c: Likewise.
+ * make.adb: Likewise.
+ * make.ads: Likewise.
+ * make_util.adb: Likewise.
+ * make_util.ads: Likewise.
+ * makeusg.adb: Likewise.
+ * makeusg.ads: Likewise.
+ * mdll-fil.adb: Likewise.
+ * mdll-fil.ads: Likewise.
+ * mdll-utl.adb: Likewise.
+ * mdll-utl.ads: Likewise.
+ * mdll.adb: Likewise.
+ * mdll.ads: Likewise.
+ * mingw32.h: Likewise.
+ * mkdir.c: Likewise.
+ * namet-sp.adb: Likewise.
+ * namet-sp.ads: Likewise.
+ * namet.adb: Likewise.
+ * namet.ads: Likewise.
+ * namet.h: Likewise.
+ * nlists.adb: Likewise.
+ * nlists.ads: Likewise.
+ * nlists.h: Likewise.
+ * opt.adb: Likewise.
+ * opt.ads: Likewise.
+ * osint-b.adb: Likewise.
+ * osint-b.ads: Likewise.
+ * osint-c.adb: Likewise.
+ * osint-c.ads: Likewise.
+ * osint-l.adb: Likewise.
+ * osint-l.ads: Likewise.
+ * osint-m.adb: Likewise.
+ * osint-m.ads: Likewise.
+ * osint.adb: Likewise.
+ * osint.ads: Likewise.
+ * output.adb: Likewise.
+ * output.ads: Likewise.
+ * par-ch10.adb: Likewise.
+ * par-ch11.adb: Likewise.
+ * par-ch12.adb: Likewise.
+ * par-ch13.adb: Likewise.
+ * par-ch2.adb: Likewise.
+ * par-ch3.adb: Likewise.
+ * par-ch4.adb: Likewise.
+ * par-ch5.adb: Likewise.
+ * par-ch6.adb: Likewise.
+ * par-ch7.adb: Likewise.
+ * par-ch8.adb: Likewise.
+ * par-ch9.adb: Likewise.
+ * par-endh.adb: Likewise.
+ * par-labl.adb: Likewise.
+ * par-load.adb: Likewise.
+ * par-prag.adb: Likewise.
+ * par-sync.adb: Likewise.
+ * par-tchk.adb: Likewise.
+ * par-util.adb: Likewise.
+ * par.adb: Likewise.
+ * par.ads: Likewise.
+ * par_sco.adb: Likewise.
+ * par_sco.ads: Likewise.
+ * pprint.adb: Likewise.
+ * pprint.ads: Likewise.
+ * prep.adb: Likewise.
+ * prep.ads: Likewise.
+ * prepcomp.adb: Likewise.
+ * prepcomp.ads: Likewise.
+ * put_scos.adb: Likewise.
+ * put_scos.ads: Likewise.
+ * raise-gcc.c: Likewise.
+ * raise.c: Likewise.
+ * raise.h: Likewise.
+ * repinfo-input.adb: Likewise.
+ * repinfo-input.ads: Likewise.
+ * repinfo.adb: Likewise.
+ * repinfo.ads: Likewise.
+ * repinfo.h: Likewise.
+ * restrict.adb: Likewise.
+ * restrict.ads: Likewise.
+ * rident.ads: Likewise.
+ * rtfinal.c: Likewise.
+ * rtinit.c: Likewise.
+ * rtsfind.adb: Likewise.
+ * rtsfind.ads: Likewise.
+ * runtime.h: Likewise.
+ * s-oscons-tmplt.c: Likewise.
+ * sa_messages.adb: Likewise.
+ * sa_messages.ads: Likewise.
+ * scans.adb: Likewise.
+ * scans.ads: Likewise.
+ * scil_ll.adb: Likewise.
+ * scil_ll.ads: Likewise.
+ * scn.adb: Likewise.
+ * scn.ads: Likewise.
+ * scng.adb: Likewise.
+ * scng.ads: Likewise.
+ * scos.adb: Likewise.
+ * scos.ads: Likewise.
+ * scos.h: Likewise.
+ * sdefault.ads: Likewise.
+ * seh_init.c: Likewise.
+ * sem.adb: Likewise.
+ * sem.ads: Likewise.
+ * sem_aggr.adb: Likewise.
+ * sem_aggr.ads: Likewise.
+ * sem_attr.adb: Likewise.
+ * sem_attr.ads: Likewise.
+ * sem_aux.adb: Likewise.
+ * sem_aux.ads: Likewise.
+ * sem_case.adb: Likewise.
+ * sem_case.ads: Likewise.
+ * sem_cat.adb: Likewise.
+ * sem_cat.ads: Likewise.
+ * sem_ch10.adb: Likewise.
+ * sem_ch10.ads: Likewise.
+ * sem_ch11.adb: Likewise.
+ * sem_ch11.ads: Likewise.
+ * sem_ch12.adb: Likewise.
+ * sem_ch12.ads: Likewise.
+ * sem_ch13.adb: Likewise.
+ * sem_ch13.ads: Likewise.
+ * sem_ch2.adb: Likewise.
+ * sem_ch2.ads: Likewise.
+ * sem_ch3.adb: Likewise.
+ * sem_ch3.ads: Likewise.
+ * sem_ch4.adb: Likewise.
+ * sem_ch4.ads: Likewise.
+ * sem_ch5.adb: Likewise.
+ * sem_ch5.ads: Likewise.
+ * sem_ch6.adb: Likewise.
+ * sem_ch6.ads: Likewise.
+ * sem_ch7.adb: Likewise.
+ * sem_ch7.ads: Likewise.
+ * sem_ch8.adb: Likewise.
+ * sem_ch8.ads: Likewise.
+ * sem_ch9.adb: Likewise.
+ * sem_ch9.ads: Likewise.
+ * sem_dim.adb: Likewise.
+ * sem_dim.ads: Likewise.
+ * sem_disp.adb: Likewise.
+ * sem_disp.ads: Likewise.
+ * sem_dist.adb: Likewise.
+ * sem_dist.ads: Likewise.
+ * sem_elab.adb: Likewise.
+ * sem_elab.ads: Likewise.
+ * sem_elim.adb: Likewise.
+ * sem_elim.ads: Likewise.
+ * sem_eval.adb: Likewise.
+ * sem_eval.ads: Likewise.
+ * sem_intr.adb: Likewise.
+ * sem_intr.ads: Likewise.
+ * sem_mech.adb: Likewise.
+ * sem_mech.ads: Likewise.
+ * sem_prag.adb: Likewise.
+ * sem_prag.ads: Likewise.
+ * sem_res.adb: Likewise.
+ * sem_res.ads: Likewise.
+ * sem_scil.adb: Likewise.
+ * sem_scil.ads: Likewise.
+ * sem_smem.adb: Likewise.
+ * sem_smem.ads: Likewise.
+ * sem_type.adb: Likewise.
+ * sem_type.ads: Likewise.
+ * sem_util.adb: Likewise.
+ * sem_util.ads: Likewise.
+ * sem_warn.adb: Likewise.
+ * sem_warn.ads: Likewise.
+ * set_targ.adb: Likewise.
+ * set_targ.ads: Likewise.
+ * sfn_scan.adb: Likewise.
+ * sfn_scan.ads: Likewise.
+ * sigtramp-armdroid.c: Likewise.
+ * sigtramp-ios.c: Likewise.
+ * sigtramp-qnx.c: Likewise.
+ * sigtramp-vxworks.c: Likewise.
+ * sigtramp.h: Likewise.
+ * sinfo-cn.adb: Likewise.
+ * sinfo-cn.ads: Likewise.
+ * sinfo.adb: Likewise.
+ * sinfo.ads: Likewise.
+ * sinput-c.adb: Likewise.
+ * sinput-c.ads: Likewise.
+ * sinput-d.adb: Likewise.
+ * sinput-d.ads: Likewise.
+ * sinput-l.adb: Likewise.
+ * sinput-l.ads: Likewise.
+ * sinput.adb: Likewise.
+ * sinput.ads: Likewise.
+ * socket.c: Likewise.
+ * spark_xrefs.adb: Likewise.
+ * spark_xrefs.ads: Likewise.
+ * sprint.adb: Likewise.
+ * sprint.ads: Likewise.
+ * stand.adb: Likewise.
+ * stand.ads: Likewise.
+ * stringt.adb: Likewise.
+ * stringt.ads: Likewise.
+ * stringt.h: Likewise.
+ * style.adb: Likewise.
+ * style.ads: Likewise.
+ * styleg.adb: Likewise.
+ * styleg.ads: Likewise.
+ * stylesw.adb: Likewise.
+ * stylesw.ads: Likewise.
+ * switch-b.adb: Likewise.
+ * switch-b.ads: Likewise.
+ * switch-c.adb: Likewise.
+ * switch-c.ads: Likewise.
+ * switch-m.adb: Likewise.
+ * switch-m.ads: Likewise.
+ * switch.adb: Likewise.
+ * switch.ads: Likewise.
+ * symbols.adb: Likewise.
+ * symbols.ads: Likewise.
+ * sysdep.c: Likewise.
+ * table.adb: Likewise.
+ * table.ads: Likewise.
+ * targext.c: Likewise.
+ * targparm.adb: Likewise.
+ * targparm.ads: Likewise.
+ * tbuild.adb: Likewise.
+ * tbuild.ads: Likewise.
+ * tempdir.adb: Likewise.
+ * tempdir.ads: Likewise.
+ * terminals.c: Likewise.
+ * tracebak.c: Likewise.
+ * tree_gen.adb: Likewise.
+ * tree_gen.ads: Likewise.
+ * tree_in.adb: Likewise.
+ * tree_in.ads: Likewise.
+ * tree_io.adb: Likewise.
+ * tree_io.ads: Likewise.
+ * treepr.adb: Likewise.
+ * treepr.ads: Likewise.
+ * ttypes.ads: Likewise.
+ * types.adb: Likewise.
+ * types.ads: Likewise.
+ * types.h: Likewise.
+ * uintp.adb: Likewise.
+ * uintp.ads: Likewise.
+ * uintp.h: Likewise.
+ * uname.adb: Likewise.
+ * uname.ads: Likewise.
+ * urealp.adb: Likewise.
+ * urealp.ads: Likewise.
+ * urealp.h: Likewise.
+ * usage.adb: Likewise.
+ * usage.ads: Likewise.
+ * validsw.adb: Likewise.
+ * validsw.ads: Likewise.
+ * warnsw.adb: Likewise.
+ * warnsw.ads: Likewise.
+ * widechar.adb: Likewise.
+ * widechar.ads: Likewise.
+ * xeinfo.adb: Likewise.
+ * xnmake.adb: Likewise.
+ * xoscons.adb: Likewise.
+ * xr_tabls.adb: Likewise.
+ * xr_tabls.ads: Likewise.
+ * xref_lib.adb: Likewise.
+ * xref_lib.ads: Likewise.
+ * xsinfo.adb: Likewise.
+ * xsnamest.adb: Likewise.
+ * xtreeprs.adb: Likewise.
+ * xutil.adb: Likewise.
+ * xutil.ads: Likewise.
+
+2020-06-02 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): Set attribute
+ Expansion_Delayed on aggregates that initialize an object that
+ has aspect alignment or address clause. Done to allow ther
+ initialization by means of multiple assignments.
+ * exp_ch3.adb (Expand_N_Object_Declaration): Resolve delayed
+ aggregates. This patch complements the patch applied to
+ sem_ch3.adb
+
+2020-06-02 Javier Miranda <miranda@adacore.com>
+
+ * sem_util.adb (Ensure_Minimum_Decoration): New subprogram that
+ ensures the minimum decoration required by
+ Requires_Transient_Scope() to provide its functionality when the
+ entity is not frozen.
+
+2020-06-02 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Op_Divide): Remove code dealing with
+ the Treat_Fixed_As_Integer flag.
+ (Expand_N_Op_Multiply): Likewise.
+ * exp_fixd.adb (Build_Divide): Do the division in an integer
+ type long enough to hold both operands and convert the result
+ to the type of the LHS. Do not set Treat_Fixed_As_Integer.
+ (Build_Multiply): Do not set Treat_Fixed_As_Integer.
+ (Build_Rem): Likewise.
+ * sem_ch4.adb (Analyze_Arithmetic_Op): Remove code dealing with
+ the Treat_Fixed_As_Integer flag.
+ (Check_Arithmetic_Pair): Likewise.
+ * sinfo.ads (Treat_Fixed_As_Integer): Delete.
+ (N_Has_Treat_Fixed_As_Integer): Likewise.
+ (Set_Treat_Fixed_As_Integer): Likewise.
+ * sinfo.adb (Treat_Fixed_As_Integer): Likewise.
+ (Set_Treat_Fixed_As_Integer): Likewise.
+ * sprint.ads (Syntax Extensions): Remove '#' special character.
+ * sprint.adb (Process_TFAI_RR_Flags): Delete.
+ (Sprint_Node_Actual) <N_Op_Divide>: Print '@' manually.
+ <N_Op_Multiply>: Likewise.
+ <N_Op_Mod>: Do not print '#'.
+ <N_Op_Rem>: Likewise.
+
+2020-06-02 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_aggr.adb (Others_Check): In the positional case, use the
+ general expression for the comparison only when needed.
+ * exp_attr.adb (Expand_Fpt_Attribute;): Use a simple conversion
+ to the target type instead of an unchecked conversion to the
+ base type to do the range check, as in the other cases.
+ (Expand_N_Attribute_Reference) <Attribute_Storage_Size>: Do the
+ Max operation in the type of the storage size variable, and use
+ Convert_To as in the other cases.
+ * tbuild.adb (Convert_To): Do not get rid of an intermediate
+ conversion to Universal_Integer here...
+ * sem_res.adb (Simplify_Type_Conversion): ...but here instead.
+
+2020-06-02 Bob Duff <duff@adacore.com>
+
+ * doc/gnat_ugn/gnat_utility_programs.rst: Update documentation
+ for --RM-style-spacing.
+
+2020-06-02 Bob Duff <duff@adacore.com>
+
+ * doc/gnat_ugn/gnat_utility_programs.rst: Add documentation for
+ --[no-]compact switch.
+
+2020-06-02 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_aggr.adb (Build_Array_Aggr_Code): Set the type of the PAT
+ on the zero used to clear the array.
+ * exp_attr.adb (Expand_N_Attribute_Reference)
+ <Attribute_Alignment>: In the CW case, directly convert from the
+ alignment's type to the target type if the parent is an
+ unchecked conversion.
+ * sem_res.adb (Set_String_Literal_Subtype): In the dynamic case,
+ use the general expression for the upper bound only when needed.
+ Set the base type of the index as the type of the low bound.
+ (Simplify_Type_Conversion): Do an intermediate conversion to the
+ root type of the target type if the operand is an integer
+ literal.
+ * tbuild.adb (Convert_To): Get rid of an intermediate conversion
+ to Universal_Integer if the inner expression has integer tyoe.
+ * libgnat/a-sequio.adb (Byte_Swap): Make use of an equivalent
+ static expression in the case statement.
+
+2020-06-02 Thomas Quinot <quinot@adacore.com>
+
+ * par_sco.adb (Traverse_Degenerate_Subprogram): Set statement
+ code to 'X'.
+ * scos.ads: Update comment documenting SCO data.
+
+2020-06-02 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_unst.adb (Register_Subprogram): Test for Address_Taken (in
+ addition to the existing test for In_Synchonized_Unit) when
+ deciding whether to reset the Reachable flag on all subprograms
+ enclosing the subprogram being registered.
+
+2020-06-02 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch6.adb (Check_Return_Obj_Accessibility): Avoid use of
+ parent node pointers so we are not relying on expansion done in
+ GNATprove mode.
+
+2020-06-02 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference)
+ <Attribute_Alignment>: Adjust comment and compare against proper
+ type.
+
+2020-06-02 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_unst.adb (Visit_Node): When visiting array attribute
+ nodes, apply Get_Referenced_Object to the attribute prefix, to
+ handle prefixes denoting renamed objects by picking up the Etype
+ of the renamed object rather than the possibly unconstrained
+ nominal subtype of the renaming declaration's Entity.
+ * sem_util.ads (Get_Referenced_Object): Update comment to
+ clearly indicate that any kind of node can be passed to this
+ function.
+ * sem_util.adb (Get_Referenced_Object): Add test of Is_Object to
+ the condition, to allow for passing names that denote types and
+ subtypes.
+
+2020-06-02 Bob Duff <duff@adacore.com>
+
+ * snames.ads-tmpl: Add comments explaining that enumeration
+ types have to be kept in synch with subtypes of Name_Id.
+
+2020-06-02 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Check_No_Hidden_State): Remove dead code.
+
+2020-06-02 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_pakd.adb (Expand_Packed_Bit_Reference): Change type of
+ reference from Universal_Integer to Standard_Natural.
+
+2020-06-02 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Collect_States_And_Objects): Call itself on
+ declaration of nested packages; append abstract states
+ one-by-one, so that in recursive call we do not overwrite the
+ ones that have been already collected.
+
+2020-06-02 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_atag.ads (Build_Inherit_Predefined_Prims): Change type
+ of Num_Predef_Prim parameter from Int to Nat.
+ * exp_atag.adb (Build_Range): New procedure.
+ (Build_Val): Likewise.
+ (Build_CW_Membership): Call Build_Val.
+ (Build_Get_Predefined_Prim_Op_Address): Likewise.
+ (Build_Inherit_CPP_Prims): Likewise.
+ (Build_Get_Prim_Op_Address): Likewise.
+ (Build_Set_Predefined_Prim_Op_Address): Likewise.
+ (Build_Inherit_Prims): Call Build_Range.
+ (Build_Inherit_Predefined_Prims): Likewise. Change type of
+ Num_Predef_Prim parameter from Int to Nat.
+
+2020-06-02 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch3.adb: Two typo fixes.
+
+2020-06-02 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch3.adb (Replace_Discriminants): Preserve the Etype of the
+ Name of N_Variant_Part nodes when rewriting it.
+
+2020-06-02 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch3.adb (Signed_Integer_Type_Declaration): Change the type
+ of the bounds from Universal_Integer to Implicit_Base.
+
+2020-06-02 Arnaud Charlet <charlet@adacore.com>
+
+ * bcheck.adb, binde.adb, bindo-diagnostics.adb, checks.adb,
+ exp_aggr.adb, exp_ch3.adb, exp_ch4.adb, exp_ch7.adb,
+ exp_ch9.adb, gnatname.adb, sem_case.adb, sem_ch13.adb,
+ sem_ch5.adb, sem_prag.adb, sem_util.adb, uintp.adb, urealp.adb,
+ xoscons.adb, xr_tabls.adb, xref_lib.adb: Initialize objects more
+ explicitly and add corresponding assertions. Remove dead code.
+ Also add a few Annotate pragmas to help static analysis.
+ * libgnat/a-caldel.adb, libgnat/a-calend.adb,
+ libgnat/a-ngcoty.adb, libgnat/a-ngelfu.adb,
+ libgnat/a-ngrear.adb, libgnat/a-strfix.adb,
+ libgnat/g-calend.adb, libgnat/g-catiio.adb,
+ libgnat/g-comlin.adb, libgnat/g-debpoo.adb,
+ libgnat/g-dirope.adb, libgnat/g-hesorg.adb,
+ libgnat/g-pehage.adb, libgnat/g-socket.adb, libgnat/i-cobol.adb,
+ libgnat/s-dwalin.adb, libgnat/s-dwalin.ads,
+ libgnat/s-fatgen.adb, libgnat/s-gearop.adb,
+ libgnat/s-genbig.adb, libgnat/s-imgrea.adb,
+ libgnat/s-os_lib.adb, libgnat/s-rannum.adb,
+ libgnat/s-regpat.adb, libgnat/s-trasym__dwarf.adb,
+ libgnat/s-valrea.adb: Ditto.
+
+2020-06-02 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch3.adb (Replace_Components): Rename into...
+ (Replace_Discriminants): ...this. Replace girder discriminants
+ with non-girder ones. Do not replace components.
+ * sem_ch13.adb (Check_Record_Representation_Clause): Deal with
+ non-girder discriminants correctly.
+
+2020-06-02 Piotr Trojanek <trojanek@adacore.com>
+
+ * lib-xref-spark_specific.adb (Create_Heap): use a new variant
+ of Name_Enter to directly converts String to Make_Id.
+
+2020-06-02 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_attr.adb, par-ch4.adb, par-util.adb, scans.ads, scng.adb,
+ sem_attr.adb, sem_ch4.adb, sinfo.ads: Typo corrections and minor
+ reformatting.
+
+2020-06-02 Arnaud Charlet <charlet@adacore.com>
+
+ * snames.ads-tmpl (Name_Img, Attribute_Img): Make it an
+ attribute returning renamable functions.
+
+2020-06-02 Yannick Moy <moy@adacore.com>
+
+ * sem_prag.adb, sem_prag.ads (Set_Overflow_Mode): New procedure
+ to set overflow mode.
+
+2020-06-02 Piotr Trojanek <trojanek@adacore.com>
+
+ * contracts.adb, einfo.adb, exp_ch9.adb, sem_ch12.adb,
+ sem_ch4.adb, sem_ch7.adb, sem_ch8.adb, sem_elab.adb,
+ sem_type.adb, sem_util.adb: Reuse Is_Package_Or_Generic_Package
+ where possible (similarly, reuse Is_Concurrent_Type if it was
+ possible in the same expressions).
+
+2020-05-30 Arnaud Charlet <charlet@adacore.com>
+
+ * Makefile.rtl (ADA_INCLUDE_SRCS): Replace Makefile.adalib by
+ libada.gpr and associated project files.
+ (g-debpoo.o): Add missing rule to ensure subprograms are not reordered.
+ (setup-rts): Add generation of libgnat/libgnarl.lst.
+ (LIBGNAT_SRCS): Remove thread.c which is part of libgnarl.
+ * tracebak.c, tb-gcc.c: Merged the two files to simplify dependencies.
+ * libgnarl/libgnarl.gpr, libgnat/libada.gpr,
+ libgnat/libgnat.gpr, libgnat/libgnat_common.gpr: New files.
+ * doc/gnat_ugn/the_gnat_compilation_model.rst: Makefile.adalib
+ replaced by libada.gpr.
+ * libgnat/system-mingw.ads: Remove obsolete comment.
+ * gcc-interface/Makefile.in: Remove dependency on tb-gcc.c.
+
+2020-05-27 Martin Liska <mliska@suse.cz>
+
+ * gnatvsn.ads: Bump Library_Version to 11.
+
+2020-05-26 Eric Botcazou <ebotcazou@gcc.gnu.org>
+
+ PR ada/95333
+ * gcc-interface/decl.c (gnat_to_gnu_param): Never make a variant of
+ the type.
+
+2020-05-26 Alexandre Oliva <oliva@adacore.com>
+
+ * gcc-interface/lang-specs.h (ADA_DUMPS_OPTIONS): Define in
+ terms of DUMPS_OPTIONS. Replace occurrences of %{d*} %:dumps
+ with it.
+
+2020-05-26 Alexandre Oliva <oliva@adacore.com>
+
+ * gcc-interface/lang-specs.h: Drop auxbase and auxbase-strip.
+ Use %:dumps instead of -dumpbase. Add %w for implicit .s
+ primary output.
+ * switch.adb (Is_Internal_GCC_Switch): Recognize dumpdir and
+ dumpbase-ext. Drop auxbase and auxbase-strip.
+
+2020-05-25 Yannick Moy <moy@adacore.com>
+
+ * sem_util.adb (Check_No_Hidden_State): Stop propagation at
+ first block/task/entry.
+
+2020-05-25 Yannick Moy <moy@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_pragmas.rst: Document
+ changes to pragmas Compile_Time_Error/Compile_Time_Warning.
+ * gnat_rm.texi: Regenerate.
+ * libgnat/g-bytswa.adb: Change uses of Compile_Time_Error to
+ Compile_Time_Warning, as the actual expression may not always be
+ known statically.
+ * sem_prag.adb (Analyze_Pragma): Handle differently pragma
+ Compile_Time_Error in both compilation and in GNATprove mode.
+ (Validate_Compile_Time_Warning_Or_Error): Issue an error or
+ warning when the expression is not known at compile time.
+ * usage.adb: Add missing documentation for warning switches _c
+ and _r.
+ * warnsw.ads: Update comment.
+
+2020-05-25 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch6.adb (Check_Return_Obj_Accessibility): Use original
+ node to avoid looking at expansion done in GNATprove mode.
+
+2020-05-25 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity): Add new local variable
+ and use it throughout the function.
+ <E_Variable>: Rename local variable and adjust accordingly. In the
+ case of a renaming, materialize the entity if the renamed object is
+ an N_Expression_With_Actions node.
+ <E_Procedure>: Use Alias accessor function consistently.
+
+2020-05-25 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/misc.c (get_array_bit_stride): Get to the debug type,
+ if any, before calling gnat_get_array_descr_info.
+
+2020-05-25 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: Tidy up.
+ (build_variant_list): Add GNAT_VARIANT_PART parameter and annotate its
+ variants if it is present. Adjust the recursive call by passing the
+ variant subpart of variants, if any.
+ (copy_and_substitute_in_layout): Rename GNU_SUBST_LIST to SUBST_LIST
+ and adjust throughout. For a type, pass the variant part in the
+ call to build_variant_list.
+
+2020-05-25 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_component_type): Cap the alignment
+ of the component type according to the component size.
+
+2020-05-25 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Array_Type>: Add a
+ description of the various types associated with the unconstrained
+ type. Declare the fat pointer earlier. Set the current function
+ as context on the template type, and the fat pointer type on the
+ array type. Always mark the fat pointer type as artificial and set
+ it as the context for the pointer type to the array. Also reuse
+ GNU_ENTITY_NAME. Finish up the unconstrained type at the very end.
+ * gcc-interface/misc.c (gnat_get_array_descr_info): Do not handle
+ fat pointer types and tidy up accordingly.
+ * gcc-interface/utils.c (build_unc_object_type): Do not set the
+ context on the template type.
+ (gnat_pushdecl): Mark the canonical fat pointer types as artificial.
+
+2020-05-25 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/gigi.h (operand_type): New static inline function.
+ * gcc-interface/trans.c (gnat_to_gnu): Do not suppress conversion
+ to the resulty type at the end for array types.
+ * gcc-interface/utils2.c (build_binary_op) <MODIFY_EXPR>: Do not
+ remove conversions between array types on the LHS.
+
+2020-05-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_aggr.ads (Is_Single_Aggregate): New function.
+ * sem_aggr.adb (Is_Others_Aggregate): Use local variable.
+ (Is_Single_Aggregate): New function to recognize an aggregate with
+ a single association containing a single choice.
+ * fe.h (Is_Others_Aggregate): Delete.
+ (Is_Single_Aggregate): New declaration.
+ * gcc-interface/trans.c (gnat_to_gnu) <N_Assignment_Statement>: Call
+ Is_Single_Aggregate instead of Is_Others_Aggregate.
+
+2020-05-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/95035
+ * gcc-interface/utils.c (packable_type_hasher::equal): Also compare
+ the scalar storage order.
+ (hash_packable_type): Also hash the scalar storage order.
+ (hash_pad_type): Likewise.
+
+2020-05-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/*.[ch]: Update copyright year.
+
+2020-05-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (Attribute_to_gnu) <Attr_Access>: Assert that
+ the prefix is not a type.
+
+2020-05-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/ada-tree.h (TYPE_PACKED_ARRAY_TYPE_P): Rename into...
+ (TYPE_BIT_PACKED_ARRAY_TYPE_P): ...this.
+ (TYPE_IS_PACKED_ARRAY_TYPE_P): Rename into...
+ (BIT_PACKED_ARRAY_TYPE_P): ...this.
+ (TYPE_IMPL_PACKED_ARRAY_P): Adjust to above renaming.
+ * gcc-interface/gigi.h (maybe_pad_type): Remove IS_USER_TYPE parameter.
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Adjust call
+ to maybe_pad_type.
+ <E_Ordinary_Fixed_Point_Type>: Remove const qualifiers for tree.
+ <E_Signed_Integer_Subtype>: Remove redundant test and redundant call
+ to associate_original_type_to_packed_array. Turn test into assertion.
+ Call associate_original_type_to_packed_array and modify gnu_entity_name
+ accordingly. Explicitly set the parallel type for GNAT encodings.
+ Call create_type_decl in the misaligned case before maybe_pad_type.
+ <E_Array_Type>: Do not use the name of the implementation type for a
+ packed array when not using GNAT encodings.
+ <E_Array_Subtype>: Move around setting flags. Use the result of the
+ call to associate_original_type_to_packed_array for gnu_entity_name.
+ <E_Record_Subtype>: Create XVS type and XVZ variable only if debug
+ info is requested for the type.
+ Call create_type_decl if a padded type was created for a type entity.
+ (gnat_to_gnu_component_type): Use local variable and adjust calls to
+ maybe_pad_type.
+ (gnat_to_gnu_subprog_type): Adjust call to maybe_pad_type.
+ (gnat_to_gnu_field): Likewise.
+ (validate_size): Adjust to renaming of macro.
+ (set_rm_size): Likewise.
+ (associate_original_type_to_packed_array): Adjust return type and
+ return the name of the original type if GNAT encodings are not used.
+ * gcc-interface/misc.c (gnat_get_debug_typ): Remove obsolete stuff.
+ (gnat_get_fixed_point_type_info): Remove const qualifiers for tree.
+ (gnat_get_array_descr_info): Likewise and set variables lazily.
+ Remove call to maybe_debug_type. Simplify a few computations.
+ (enumerate_modes): Remove const qualifier for tree.
+ * gcc-interface/utils.c (make_type_from_size): Adjust to renaming.
+ (maybe_pad_type): Remove IS_USER_TYPE parameter and adjust. Remove
+ specific code for implementation types for packed arrays.
+ (compute_deferred_decl_context): Remove const qualifier for tree.
+ (convert): Adjust call to maybe_pad_type.
+ (unchecked_convert): Likewise.
+ * gcc-interface/utils2.c (is_simple_additive_expressio): Likewise.
+
+2020-05-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/utils2.c (build_binary_op) <ARRAY_RANGE_REF>: Use
+ build_nonshared_array_type to build the common type and declare it.
+
+2020-05-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/misc.c (gnat_init_gcc_eh): Do not override the user
+ for -fnon-call-exceptions in default mode.
+
+2020-05-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (lvalue_required_p) <N_Selected_Component>:
+ Merge with N_Slice.
+ <N_Allocator>: Move to...
+ (lvalue_for_aggregate_p): ...here. New function.
+ (Identifier_to_gnu): For an identifier with aggregate type, also
+ call lvalue_for_aggregate_p if lvalue_required_p returned false
+ before substituting the identifier with the constant.
+
+2020-05-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (gnat_to_gnu): Do not wrap boolean values if
+ they appear in any kind of attribute references.
+
+2020-05-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (gnat_to_gnu) <N_Assignment_Statement>: Deal
+ with qualified "others" aggregates in the memset case.
+
+2020-05-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_param): Also back-annotate the
+ mechanism in the case of an Out parameter only passed by copy-out.
+
+2020-05-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/gigi.h (change_qualified_type): Move around.
+ (maybe_vector_array): Likewise.
+ (maybe_padded_object): New static line function.
+ * gcc-interface/trans.c (Attribute_to_gnu) <Attr_Component_Size>:
+ Remove useless code.
+ <Attr_Null_Parameter>: Remove obsolete code.
+ (Call_to_gn): Likewise. Use maybe_padded_object to remove padding.
+ (gnat_to_gnu): Likewise.
+ <N_String_Literal>: Do not add a useless null character at the end.
+ <N_Indexed_Component>: Likewise and remove obsolete code.
+ (add_decl_expr): Likewise.
+ (maybe_implicit_deref): Likewise.
+ * gcc-interface/utils.c (maybe_unconstrained_array): Likewise.
+ * gcc-interface/utils2.c (gnat_invariant_expr): Likewise.
+
+2020-05-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/utils2.c: Include builtins.h.
+ (known_alignment) <ADDR_EXPR>: Use DECL_ALIGN for DECL_P operands
+ and get_object_alignment for the rest.
+
+2020-05-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Force at
+ least the unit size for an aliased object of a constrained nominal
+ subtype whose size is variable.
+
+2020-05-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Array_Subtype>: Deal
+ with artificial maximally-sized types designed by access types.
+ * gcc-interface/utils.c (packable_type_hash): New structure.
+ (packable_type_hasher): Likewise.
+ (packable_type_hash_table): New hash table.
+ (init_gnat_utils): Initialize it.
+ (destroy_gnat_utils): Destroy it.
+ (packable_type_hasher::equal): New method.
+ (hash_packable_type): New static function.
+ (canonicalize_packable_type): Likewise.
+ (make_packable_type): Make sure not to use too small a type for the
+ size of the new fields. Canonicalize the type if it is named.
+
+2020-05-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (Raise_Error_to_gnu): Always compute a lower
+ bound and an upper bound for use by the -gnateE switch for range and
+ comparison operators.
+
+2020-05-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_param): Do not make a variant of
+ the type in LTO mode.
+
2020-05-04 Mikael Pettersson <mikpelinux@gmail.com>
PR bootstrap/94918
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
index 55ff9b0..fc978a2 100644
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -1,5 +1,5 @@
# Makefile.rtl for GNU Ada Compiler (GNAT).
-# Copyright (C) 2003-2017, Free Software Foundation, Inc.
+# Copyright (C) 2003-2020, Free Software Foundation, Inc.
#This file is part of GCC.
@@ -39,6 +39,7 @@ GNATRTL_TASKING_OBJS= \
a-sytaco$(objext) \
a-tasatt$(objext) \
a-taside$(objext) \
+ a-tasini$(objext) \
a-taster$(objext) \
g-boubuf$(objext) \
g-boumai$(objext) \
@@ -52,6 +53,7 @@ GNATRTL_TASKING_OBJS= \
s-mudido$(objext) \
s-osinte$(objext) \
s-proinf$(objext) \
+ s-putaim$(objext) \
s-solita$(objext) \
s-stusta$(objext) \
s-taenca$(objext) \
@@ -79,7 +81,7 @@ GNATRTL_TASKING_OBJS= \
thread$(objext) \
$(EXTRA_GNATRTL_TASKING_OBJS)
-# Objects the require IEEE Float
+# Objects that require IEEE Float
GNATRTL_ALTIVEC_OBJS= \
g-allein$(objext) \
g-alleve$(objext) \
@@ -263,9 +265,18 @@ GNATRTL_NONTASKING_OBJS= \
a-stboha$(objext) \
a-stfiha$(objext) \
a-stmaco$(objext) \
+ a-stobbu$(objext) \
+ a-stobfi$(objext) \
a-storio$(objext) \
+ a-stoubu$(objext) \
+ a-stoufi$(objext) \
+ a-stoufo$(objext) \
+ a-stouut$(objext) \
a-strbou$(objext) \
a-stream$(objext) \
+ a-strsto$(objext) \
+ a-ststbo$(objext) \
+ a-ststun$(objext) \
a-strfix$(objext) \
a-strhas$(objext) \
a-string$(objext) \
@@ -274,6 +285,7 @@ GNATRTL_NONTASKING_OBJS= \
a-strsup$(objext) \
a-strunb$(objext) \
a-ststio$(objext) \
+ a-stteou$(objext) \
a-stunau$(objext) \
a-stunha$(objext) \
a-stuten$(objext) \
@@ -421,7 +433,6 @@ GNATRTL_NONTASKING_OBJS= \
g-excact$(objext) \
g-except$(objext) \
g-exctra$(objext) \
- s-exctra$(objext) \
g-expect$(objext) \
g-exptty$(objext) \
g-flocon$(objext) \
@@ -476,7 +487,6 @@ GNATRTL_NONTASKING_OBJS= \
g-timsta$(objext) \
g-traceb$(objext) \
g-trasym$(objext) \
- s-trasym$(objext) \
g-tty$(objext) \
g-u3spch$(objext) \
g-utf_32$(objext) \
@@ -498,13 +508,14 @@ GNATRTL_NONTASKING_OBJS= \
machcode$(objext) \
s-addima$(objext) \
s-addope$(objext) \
+ s-aoinar$(objext) \
+ s-aomoar$(objext) \
s-aotase$(objext) \
s-arit64$(objext) \
s-assert$(objext) \
s-atacco$(objext) \
s-atocou$(objext) \
s-atoope$(objext) \
- s-atopar$(objext) \
s-atopex$(objext) \
s-atopri$(objext) \
s-auxdec$(objext) \
@@ -539,7 +550,6 @@ GNATRTL_NONTASKING_OBJS= \
s-dfmkio$(objext) \
s-dfmopr$(objext) \
s-dgmgop$(objext) \
- s-dlmopr$(objext) \
s-diflio$(objext) \
s-diflmk$(objext) \
s-digemk$(objext) \
@@ -550,12 +560,14 @@ GNATRTL_NONTASKING_OBJS= \
s-dimmks$(objext) \
s-direio$(objext) \
s-dlmkio$(objext) \
+ s-dlmopr$(objext) \
s-dmotpr$(objext) \
s-dsaser$(objext) \
s-elaall$(objext) \
s-excdeb$(objext) \
s-except$(objext) \
s-exctab$(objext) \
+ s-exctra$(objext) \
s-exnint$(objext) \
s-exnllf$(objext) \
s-exnlli$(objext) \
@@ -672,6 +684,7 @@ GNATRTL_NONTASKING_OBJS= \
s-poosiz$(objext) \
s-powtab$(objext) \
s-purexc$(objext) \
+ s-putima$(objext) \
s-rannum$(objext) \
s-ransee$(objext) \
s-regexp$(objext) \
@@ -683,6 +696,7 @@ GNATRTL_NONTASKING_OBJS= \
s-scaval$(objext) \
s-secsta$(objext) \
s-sequio$(objext) \
+ s-shabig$(objext) \
s-shasto$(objext) \
s-soflin$(objext) \
s-soliin$(objext) \
@@ -694,12 +708,14 @@ GNATRTL_NONTASKING_OBJS= \
s-stopoo$(objext) \
s-stposu$(objext) \
s-stratt$(objext) \
+ s-statxd$(objext) \
s-strhas$(objext) \
s-string$(objext) \
s-ststop$(objext) \
s-tasloc$(objext) \
s-traceb$(objext) \
s-traent$(objext) \
+ s-trasym$(objext) \
s-unstyp$(objext) \
s-utf_32$(objext) \
s-valboo$(objext) \
@@ -818,13 +834,13 @@ ATOMICS_BUILTINS_TARGET_PAIRS = \
# Special version of units for x86 and x86-64 platforms.
X86_TARGET_PAIRS = \
- a-numaux.ads<libgnat/a-numaux__x86.ads \
- a-numaux.adb<libgnat/a-numaux__x86.adb \
+ a-numaux.ads<libgnat/a-numaux__libc-x86.ads \
+ a-numaux.adb<libgnat/a-numaux__dummy.adb \
s-atocou.adb<libgnat/s-atocou__x86.adb
X86_64_TARGET_PAIRS = \
- a-numaux.ads<libgnat/a-numaux__x86.ads \
- a-numaux.adb<libgnat/a-numaux__x86.adb \
+ a-numaux.ads<libgnat/a-numaux__libc-x86.ads \
+ a-numaux.adb<libgnat/a-numaux__dummy.adb \
s-atocou.adb<libgnat/s-atocou__builtin.adb
# Implementation of symbolic traceback based on dwarf
@@ -1024,7 +1040,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae vxworksaespe,$(target_cpu) $(t
a-elchha.adb<libgnat/a-elchha__vxworks-ppc-full.adb \
a-intnam.ads<libgnarl/a-intnam__vxworks.ads \
a-numaux.ads<libgnat/a-numaux__vxworks.ads \
- g-io.adb<hie/g-io__vxworks-ppc-cert.adb \
+ g-io.adb<hie/g-io__vxworks-cert.adb \
s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \
s-interr.adb<libgnarl/s-interr__vxworks.adb \
s-intman.ads<libgnarl/s-intman__vxworks.ads \
@@ -1080,7 +1096,7 @@ ifeq ($(strip $(filter-out %86 wrs vxworksae,$(target_cpu) $(target_vendor) $(ta
a-elchha.adb<libgnat/a-elchha__vxworks-ppc-full.adb \
a-intnam.ads<libgnarl/a-intnam__vxworks.ads \
a-numaux.ads<libgnat/a-numaux__vxworks.ads \
- g-io.adb<hie/g-io__vxworks-ppc-cert.adb \
+ g-io.adb<hie/g-io__vxworks-cert.adb \
s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \
s-interr.adb<libgnarl/s-interr__vxworks.adb \
s-intman.ads<libgnarl/s-intman__vxworks.ads \
@@ -1632,8 +1648,8 @@ endif
ifeq ($(strip $(filter-out x86_64 kfreebsd%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<libgnarl/a-intnam__freebsd.ads \
- a-numaux.adb<libgnat/a-numaux__x86.adb \
- a-numaux.ads<libgnat/a-numaux__x86.ads \
+ a-numaux.ads<libgnat/a-numaux__libc-x86.ads \
+ a-numaux.adb<libgnat/a-numaux__dummy.adb \
s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
@@ -1895,7 +1911,6 @@ ifeq ($(strip $(filter-out lynxos178%,$(target_os))),)
endif
ifeq ($(strip $(filter-out %86, $(target_cpu))),)
LIBGNAT_TARGET_PAIRS += system.ads<libgnat/system-lynxos178-x86.ads
- LIBGNAT_TARGET_PAIRS += $(X86_TARGET_PAIRS)
endif
ifeq ($(strip $(filter-out lynxos178e,$(target_os))),)
@@ -2621,7 +2636,7 @@ LIBGNAT_OBJS = adadecode.o adaint.o argv.o aux-io.o \
LIBGNAT_SRCS = $(patsubst %.o,%.c,$(LIBGNAT_OBJS)) \
adadecode.h adaint.h env.h gsocket.h raise.h standard.ads.h \
- tb-gcc.c runtime.h libgnarl/thread.c $(EXTRA_LIBGNAT_SRCS)
+ runtime.h $(EXTRA_LIBGNAT_SRCS)
# memtrack.o is special as not put into libgnat.
GNATRTL_OBJS = $(GNATRTL_NONTASKING_OBJS) $(GNATRTL_TASKING_OBJS) \
@@ -2634,7 +2649,8 @@ GNATRTL_OBJS = $(GNATRTL_NONTASKING_OBJS) $(GNATRTL_TASKING_OBJS) \
ADA_INCLUDE_SRCS =\
libgnat/ada.ads libgnat/calendar.ads libgnat/directio.ads libgnat/gnat.ads libgnat/interfac.ads libgnat/ioexcept.ads \
libgnat/machcode.ads libgnat/text_io.ads libgnat/unchconv.ads libgnat/unchdeal.ads \
- libgnat/sequenio.ads libgnat/system.ads Makefile.adalib libgnat/memtrack.adb \
+ libgnat/sequenio.ads libgnat/system.ads libgnat/memtrack.adb \
+ libgna*/*.gpr \
libgnat/a-[a-o]*.adb libgnat/a-[a-o]*.ads \
libgnat/a-[p-z]*.adb libgnat/a-[p-z]*.ads \
libgnat/g-[a-o]*.adb libgnat/g-[a-o]*.ads \
@@ -2680,7 +2696,7 @@ setup-rts: force
$(MKDIR) $(RTSDIR)
$(CHMOD) u+w $(RTSDIR)
# Copy target independent sources
- $(foreach f,$(ADA_INCLUDE_SRCS) $(LIBGNAT_SRCS), \
+ $(foreach f,$(ADA_INCLUDE_SRCS) $(LIBGNAT_SRCS) libgnarl/thread.c, \
$(LN_S) $(GNAT_SRC)/$(f) $(RTSDIR) ;) true
# Remove files not used
$(RM) $(patsubst %,$(RTSDIR)/%,$(ADA_EXCLUDE_FILES))
@@ -2688,15 +2704,31 @@ setup-rts: force
$(RM) $(foreach PAIR,$(LIBGNAT_TARGET_PAIRS), \
$(RTSDIR)/$(word 1,$(subst <, ,$(PAIR))))
for f in $(RTSDIR)/*-*__*.ads $(RTSDIR)/*-*__*.adb; do \
- case "$$f" in \
- $(RTSDIR)/s-stratt__*) ;; \
- *) $(RM) $$f ;; \
- esac; \
+ $(RM) $$f ; \
done
# Copy new target dependent sources
$(foreach PAIR,$(LIBGNAT_TARGET_PAIRS), \
$(LN_S) $(GNAT_SRC)/$(word 2,$(subst <, ,$(PAIR))) \
$(RTSDIR)/$(word 1,$(subst <, ,$(PAIR)));)
+# And finally generate libgnat.lst and libgnarl.lst
+ @for f in \
+ $(foreach F,$(GNATRTL_TASKING_OBJS),$(subst $(objext),.ads,$(F))) \
+ $(foreach F,$(GNATRTL_TASKING_OBJS),$(subst $(objext),.adb,$(F))); \
+ do \
+ if [ -f $(RTSDIR)/$$f ]; then echo $$f >> $(RTSDIR)/libgnarl.lst; fi \
+ done
+ @echo thread.c >> $(RTSDIR)/libgnarl.lst
+ @for f in \
+ $(foreach F,$(GNATRTL_NONTASKING_OBJS),$(subst $(objext),.ads,$(F))) \
+ $(foreach F,$(GNATRTL_NONTASKING_OBJS),$(subst $(objext),.adb,$(F))); \
+ do \
+ if [ -f $(RTSDIR)/$$f ]; then echo $$f >> $(RTSDIR)/libgnat.lst; fi \
+ done
+# s-oscons.ads is generated later, so hardcode it here
+ @echo s-oscons.ads >> $(RTSDIR)/libgnat.lst
+ @for f in $(LIBGNAT_SRCS); do \
+ echo $$f >> $(RTSDIR)/libgnat.lst; \
+ done
# Special flags. It is recommended not to change the compilation flags
# without a careful analysis of the consequences because (part of) the
@@ -2773,3 +2805,10 @@ a-tags.o : a-tags.adb a-tags.ads
s-memory.o : s-memory.adb s-memory.ads
$(ADAC) -c $(ALL_ADAFLAGS) $(NO_SIBLING_ADAFLAGS) $(ADA_INCLUDES) \
$< $(OUTPUT_OPTION)
+
+# Need to keep functions ordered on g-debpoo.o since labels are used to
+# exclude subprograms from traceback computation.
+
+g-debpoo.o: g-debpoo.adb g-debpoo.ads
+ $(ADAC) -c $(ALL_ADAFLAGS) $(NO_REORDER_ADAFLAGS) $(ADA_INCLUDES) \
+ $< $(OUTPUT_OPTION)
diff --git a/gcc/ada/ada_get_targ.adb b/gcc/ada/ada_get_targ.adb
index 64480a1..cb2d81f 100644
--- a/gcc/ada/ada_get_targ.adb
+++ b/gcc/ada/ada_get_targ.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/adabkend.adb b/gcc/ada/adabkend.adb
index 3e1b14d..6fb4a84 100644
--- a/gcc/ada/adabkend.adb
+++ b/gcc/ada/adabkend.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -189,7 +189,6 @@ package body Adabkend is
elsif Switch_Chars (First .. Last) = "fno-inline" then
Lib.Store_Compilation_Switch (Switch_Chars);
Opt.Disable_FE_Inline := True;
- Opt.Disable_FE_Inline_Always := True;
return;
-- Similar processing for -fpreserve-control-flow
diff --git a/gcc/ada/adabkend.ads b/gcc/ada/adabkend.ads
index 9fa7871..c641cb0 100644
--- a/gcc/ada/adabkend.ads
+++ b/gcc/ada/adabkend.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/adadecode.c b/gcc/ada/adadecode.c
index f87d421..43a378f 100644
--- a/gcc/ada/adadecode.c
+++ b/gcc/ada/adadecode.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2001-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2001-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/adadecode.h b/gcc/ada/adadecode.h
index 9e468d3..0db7040 100644
--- a/gcc/ada/adadecode.h
+++ b/gcc/ada/adadecode.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2001-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2001-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c
index 595abf8..c44d193 100644
--- a/gcc/ada/adaint.c
+++ b/gcc/ada/adaint.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -264,6 +264,9 @@ UINT __gnat_current_ccs_encoding;
#ifndef DIR_SEPARATOR
#define DIR_SEPARATOR '/'
+#define IS_DIRECTORY_SEPARATOR(c) ((c) == DIR_SEPARATOR)
+#else
+#define IS_DIRECTORY_SEPARATOR(c) ((c) == '/' || (c) == DIR_SEPARATOR)
#endif
/* Check for cross-compilation. */
@@ -1709,9 +1712,10 @@ __gnat_is_absolute_path (char *name, int length)
return 0;
#else
return (length != 0) &&
- (*name == '/' || *name == DIR_SEPARATOR
+ (IS_DIRECTORY_SEPARATOR(*name)
#if defined (WINNT) || defined(__DJGPP__)
- || (length > 1 && ISALPHA (name[0]) && name[1] == ':')
+ || (length > 2 && ISALPHA (name[0]) && name[1] == ':'
+ && IS_DIRECTORY_SEPARATOR(name[2]))
#endif
);
#endif
@@ -2845,7 +2849,7 @@ __gnat_locate_file_with_predicate (char *file_name, char *path_val,
/* If file_name include directory separator(s), try it first as
a path name relative to the current directory */
- for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
+ for (ptr = file_name; *ptr && !IS_DIRECTORY_SEPARATOR(*ptr); ptr++)
;
if (*ptr != 0)
@@ -2886,7 +2890,7 @@ __gnat_locate_file_with_predicate (char *file_name, char *path_val,
if (*ptr == '"')
ptr--;
- if (*ptr != '/' && *ptr != DIR_SEPARATOR)
+ if (!IS_DIRECTORY_SEPARATOR(*ptr))
*++ptr = DIR_SEPARATOR;
strcpy (++ptr, file_name);
diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h
index 311e240..4f42f6c 100644
--- a/gcc/ada/adaint.h
+++ b/gcc/ada/adaint.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -282,9 +282,10 @@ extern char *mktemp (char *);
extern void __gnat_set_exit_status (int);
extern int __gnat_expect_fork (void);
-extern void __gnat_expect_portable_execvp (char *, char *[]);
+extern void __gnat_expect_portable_execvp (int *, char *, char *[]);
extern int __gnat_pipe (int *);
-extern int __gnat_expect_poll (int *, int, int, int *);
+extern int __gnat_expect_poll (int *, int, int, int *,
+ int *);
extern void __gnat_set_binary_mode (int);
extern void __gnat_set_text_mode (int);
extern void __gnat_set_mode (int,int);
diff --git a/gcc/ada/affinity.c b/gcc/ada/affinity.c
index 1c0a18b..10fdd35 100644
--- a/gcc/ada/affinity.c
+++ b/gcc/ada/affinity.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2005-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2005-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb
index 1efad4d..ec7ec2f 100644
--- a/gcc/ada/ali-util.adb
+++ b/gcc/ada/ali-util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/ali-util.ads b/gcc/ada/ali-util.ads
index 7b3f9a5..dfa5efe4 100644
--- a/gcc/ada/ali-util.ads
+++ b/gcc/ada/ali-util.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb
index 8d1d54a..6b0d6c7 100644
--- a/gcc/ada/ali.adb
+++ b/gcc/ada/ali.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -242,31 +242,33 @@ package body ALI is
-- The following variable records which characters currently are used as
-- line type markers in the ALI file. This is used in Scan_ALI to detect
- -- (or skip) invalid lines. The following letters are still available:
- --
- -- B F H J K O Q Z
+ -- (or skip) invalid lines.
Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean :=
- ('A' => True, -- argument
- 'C' => True, -- SCO information
- 'D' => True, -- dependency
- 'E' => True, -- external
- 'G' => True, -- invocation graph
- 'I' => True, -- interrupt
- 'L' => True, -- linker option
- 'M' => True, -- main program
- 'N' => True, -- notes
- 'P' => True, -- program
- 'R' => True, -- restriction
- 'S' => True, -- specific dispatching
- 'T' => True, -- task stack information
- 'U' => True, -- unit
- 'V' => True, -- version
- 'W' => True, -- with
- 'X' => True, -- xref
- 'Y' => True, -- limited_with
- 'Z' => True, -- implicit with from instantiation
- others => False);
+ ('A' | -- argument
+ 'C' | -- SCO information
+ 'D' | -- dependency
+ 'E' | -- external
+ 'G' | -- invocation graph
+ 'I' | -- interrupt
+ 'L' | -- linker option
+ 'M' | -- main program
+ 'N' | -- notes
+ 'P' | -- program
+ 'R' | -- restriction
+ 'S' | -- specific dispatching
+ 'T' | -- task stack information
+ 'U' | -- unit
+ 'V' | -- version
+ 'W' | -- with
+ 'X' | -- xref
+ 'Y' | -- limited_with
+ 'Z' -- implicit with from instantiation
+ => True,
+
+ -- Still available:
+
+ 'B' | 'F' | 'H' | 'J' | 'K' | 'O' | 'Q' => False);
------------------------------
-- Add_Invocation_Construct --
diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads
index 7e12c7b..928fdbd 100644
--- a/gcc/ada/ali.ads
+++ b/gcc/ada/ali.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads
index f5faecb..4578d56 100644
--- a/gcc/ada/alloc.ads
+++ b/gcc/ada/alloc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/argv-lynxos178-raven-cert.c b/gcc/ada/argv-lynxos178-raven-cert.c
index be9fe54..cd5aa6e 100644
--- a/gcc/ada/argv-lynxos178-raven-cert.c
+++ b/gcc/ada/argv-lynxos178-raven-cert.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/argv.c b/gcc/ada/argv.c
index ca82ed5..2b298fc 100644
--- a/gcc/ada/argv.c
+++ b/gcc/ada/argv.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb
index 3b8b7c4..c222c33 100644
--- a/gcc/ada/aspects.adb
+++ b/gcc/ada/aspects.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,7 +33,6 @@ with Atree; use Atree;
with Einfo; use Einfo;
with Nlists; use Nlists;
with Sinfo; use Sinfo;
-with Tree_IO; use Tree_IO;
with GNAT.HTable;
@@ -70,16 +69,6 @@ package body Aspects is
Aspect_Variable_Indexing => True,
others => False);
- procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id);
- -- Same as Set_Aspect_Specifications, but does not contain the assertion
- -- that checks that N does not already have aspect specifications. This
- -- subprogram is supposed to be used as a part of Tree_Read. When reading
- -- tree, first read nodes with their basic properties (as Atree.Tree_Read),
- -- this includes reading the Has_Aspects flag for each node, then we reed
- -- all the list tables and only after that we call Tree_Read for Aspects.
- -- That is, when reading the tree, the list of aspects is attached to the
- -- node that already has Has_Aspects flag set ON.
-
------------------------------------------
-- Hash Table for Aspect Specifications --
------------------------------------------
@@ -153,12 +142,9 @@ package body Aspects is
-- The routine should be invoked on a body [stub] with aspects
pragma Assert (Has_Aspects (N));
- pragma Assert (Nkind (N) in N_Body_Stub
- or else Nkind_In (N, N_Entry_Body,
- N_Package_Body,
- N_Protected_Body,
- N_Subprogram_Body,
- N_Task_Body));
+ pragma Assert
+ (Nkind (N) in N_Body_Stub | N_Entry_Body | N_Package_Body |
+ N_Protected_Body | N_Subprogram_Body | N_Task_Body);
-- Look through all aspects and see whether they can be applied to a
-- body [stub].
@@ -412,9 +398,8 @@ package body Aspects is
-- Note: It is better to use Is_Single_Concurrent_Type_Declaration
-- here, but Aspects and Sem_Util have incompatible licenses.
- elsif Nkind_In
- (Original_Node (From), N_Single_Protected_Declaration,
- N_Single_Task_Declaration)
+ elsif Nkind (Original_Node (From)) in
+ N_Single_Protected_Declaration | N_Single_Task_Declaration
then
Asp_Id := Get_Aspect_Id (Asp);
@@ -511,136 +496,36 @@ package body Aspects is
-- Table used for Same_Aspect, maps aspect to canonical aspect
- Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id :=
- (No_Aspect => No_Aspect,
- Aspect_Abstract_State => Aspect_Abstract_State,
- Aspect_Address => Aspect_Address,
- Aspect_Alignment => Aspect_Alignment,
- Aspect_All_Calls_Remote => Aspect_All_Calls_Remote,
- Aspect_Annotate => Aspect_Annotate,
- Aspect_Async_Readers => Aspect_Async_Readers,
- Aspect_Async_Writers => Aspect_Async_Writers,
- Aspect_Asynchronous => Aspect_Asynchronous,
- Aspect_Atomic => Aspect_Atomic,
- Aspect_Atomic_Components => Aspect_Atomic_Components,
- Aspect_Attach_Handler => Aspect_Attach_Handler,
- Aspect_Bit_Order => Aspect_Bit_Order,
- Aspect_Component_Size => Aspect_Component_Size,
- Aspect_Constant_After_Elaboration => Aspect_Constant_After_Elaboration,
- Aspect_Constant_Indexing => Aspect_Constant_Indexing,
- Aspect_Contract_Cases => Aspect_Contract_Cases,
- Aspect_Convention => Aspect_Convention,
- Aspect_CPU => Aspect_CPU,
- Aspect_Default_Component_Value => Aspect_Default_Component_Value,
- Aspect_Default_Initial_Condition => Aspect_Default_Initial_Condition,
- Aspect_Default_Iterator => Aspect_Default_Iterator,
- Aspect_Default_Storage_Pool => Aspect_Default_Storage_Pool,
- Aspect_Default_Value => Aspect_Default_Value,
- Aspect_Depends => Aspect_Depends,
- Aspect_Dimension => Aspect_Dimension,
- Aspect_Dimension_System => Aspect_Dimension_System,
- Aspect_Disable_Controlled => Aspect_Disable_Controlled,
- Aspect_Discard_Names => Aspect_Discard_Names,
- Aspect_Dispatching_Domain => Aspect_Dispatching_Domain,
- Aspect_Dynamic_Predicate => Aspect_Predicate,
- Aspect_Effective_Reads => Aspect_Effective_Reads,
- Aspect_Effective_Writes => Aspect_Effective_Writes,
- Aspect_Elaborate_Body => Aspect_Elaborate_Body,
- Aspect_Export => Aspect_Export,
- Aspect_Extensions_Visible => Aspect_Extensions_Visible,
- Aspect_External_Name => Aspect_External_Name,
- Aspect_External_Tag => Aspect_External_Tag,
- Aspect_Favor_Top_Level => Aspect_Favor_Top_Level,
- Aspect_Ghost => Aspect_Ghost,
- Aspect_Global => Aspect_Global,
- Aspect_Implicit_Dereference => Aspect_Implicit_Dereference,
- Aspect_Import => Aspect_Import,
- Aspect_Independent => Aspect_Independent,
- Aspect_Independent_Components => Aspect_Independent_Components,
- Aspect_Inline => Aspect_Inline,
- Aspect_Inline_Always => Aspect_Inline,
- Aspect_Initial_Condition => Aspect_Initial_Condition,
- Aspect_Initializes => Aspect_Initializes,
- Aspect_Input => Aspect_Input,
- Aspect_Interrupt_Handler => Aspect_Interrupt_Handler,
- Aspect_Interrupt_Priority => Aspect_Priority,
- Aspect_Invariant => Aspect_Invariant,
- Aspect_Iterable => Aspect_Iterable,
- Aspect_Iterator_Element => Aspect_Iterator_Element,
- Aspect_Link_Name => Aspect_Link_Name,
- Aspect_Linker_Section => Aspect_Linker_Section,
- Aspect_Lock_Free => Aspect_Lock_Free,
- Aspect_Machine_Radix => Aspect_Machine_Radix,
- Aspect_Max_Entry_Queue_Depth => Aspect_Max_Entry_Queue_Depth,
- Aspect_Max_Entry_Queue_Length => Aspect_Max_Entry_Queue_Length,
- Aspect_Max_Queue_Length => Aspect_Max_Queue_Length,
- Aspect_No_Caching => Aspect_No_Caching,
- Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All,
- Aspect_No_Inline => Aspect_No_Inline,
- Aspect_No_Return => Aspect_No_Return,
- Aspect_No_Tagged_Streams => Aspect_No_Tagged_Streams,
- Aspect_Obsolescent => Aspect_Obsolescent,
- Aspect_Object_Size => Aspect_Object_Size,
- Aspect_Output => Aspect_Output,
- Aspect_Pack => Aspect_Pack,
- Aspect_Part_Of => Aspect_Part_Of,
- Aspect_Persistent_BSS => Aspect_Persistent_BSS,
- Aspect_Post => Aspect_Post,
- Aspect_Postcondition => Aspect_Post,
- Aspect_Pre => Aspect_Pre,
- Aspect_Precondition => Aspect_Pre,
- Aspect_Predicate => Aspect_Predicate,
- Aspect_Predicate_Failure => Aspect_Predicate_Failure,
- Aspect_Preelaborate => Aspect_Preelaborate,
- Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization,
- Aspect_Priority => Aspect_Priority,
- Aspect_Pure => Aspect_Pure,
- Aspect_Pure_Function => Aspect_Pure_Function,
- Aspect_Refined_Depends => Aspect_Refined_Depends,
- Aspect_Refined_Global => Aspect_Refined_Global,
- Aspect_Refined_Post => Aspect_Refined_Post,
- Aspect_Refined_State => Aspect_Refined_State,
- Aspect_Remote_Access_Type => Aspect_Remote_Access_Type,
- Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface,
- Aspect_Remote_Types => Aspect_Remote_Types,
- Aspect_Read => Aspect_Read,
- Aspect_Relative_Deadline => Aspect_Relative_Deadline,
- Aspect_Scalar_Storage_Order => Aspect_Scalar_Storage_Order,
- Aspect_Secondary_Stack_Size => Aspect_Secondary_Stack_Size,
- Aspect_Shared => Aspect_Atomic,
- Aspect_Shared_Passive => Aspect_Shared_Passive,
- Aspect_Simple_Storage_Pool => Aspect_Simple_Storage_Pool,
- Aspect_Simple_Storage_Pool_Type => Aspect_Simple_Storage_Pool_Type,
- Aspect_Size => Aspect_Size,
- Aspect_Small => Aspect_Small,
- Aspect_SPARK_Mode => Aspect_SPARK_Mode,
- Aspect_Static_Predicate => Aspect_Predicate,
- Aspect_Storage_Pool => Aspect_Storage_Pool,
- Aspect_Storage_Size => Aspect_Storage_Size,
- Aspect_Stream_Size => Aspect_Stream_Size,
- Aspect_Suppress => Aspect_Suppress,
- Aspect_Suppress_Debug_Info => Aspect_Suppress_Debug_Info,
- Aspect_Suppress_Initialization => Aspect_Suppress_Initialization,
- Aspect_Synchronization => Aspect_Synchronization,
- Aspect_Test_Case => Aspect_Test_Case,
- Aspect_Thread_Local_Storage => Aspect_Thread_Local_Storage,
- Aspect_Type_Invariant => Aspect_Invariant,
- Aspect_Unchecked_Union => Aspect_Unchecked_Union,
- Aspect_Unimplemented => Aspect_Unimplemented,
- Aspect_Universal_Aliasing => Aspect_Universal_Aliasing,
- Aspect_Universal_Data => Aspect_Universal_Data,
- Aspect_Unmodified => Aspect_Unmodified,
- Aspect_Unreferenced => Aspect_Unreferenced,
- Aspect_Unreferenced_Objects => Aspect_Unreferenced_Objects,
- Aspect_Unsuppress => Aspect_Unsuppress,
- Aspect_Variable_Indexing => Aspect_Variable_Indexing,
- Aspect_Value_Size => Aspect_Value_Size,
- Aspect_Volatile => Aspect_Volatile,
- Aspect_Volatile_Components => Aspect_Volatile_Components,
- Aspect_Volatile_Full_Access => Aspect_Volatile_Full_Access,
- Aspect_Volatile_Function => Aspect_Volatile_Function,
- Aspect_Warnings => Aspect_Warnings,
- Aspect_Write => Aspect_Write);
+ type Aspect_To_Aspect_Mapping is array (Aspect_Id) of Aspect_Id;
+
+ function Init_Canonical_Aspect return Aspect_To_Aspect_Mapping;
+ -- Initialize the Canonical_Aspect mapping below
+
+ function Init_Canonical_Aspect return Aspect_To_Aspect_Mapping is
+ Result : Aspect_To_Aspect_Mapping;
+ begin
+ -- They all map to themselves...
+
+ for Aspect in Aspect_Id loop
+ Result (Aspect) := Aspect;
+ end loop;
+
+ -- ...except for these:
+
+ Result (Aspect_Dynamic_Predicate) := Aspect_Predicate;
+ Result (Aspect_Inline_Always) := Aspect_Inline;
+ Result (Aspect_Interrupt_Priority) := Aspect_Priority;
+ Result (Aspect_Postcondition) := Aspect_Post;
+ Result (Aspect_Precondition) := Aspect_Pre;
+ Result (Aspect_Shared) := Aspect_Atomic;
+ Result (Aspect_Static_Predicate) := Aspect_Predicate;
+ Result (Aspect_Type_Invariant) := Aspect_Invariant;
+
+ return Result;
+ end Init_Canonical_Aspect;
+
+ Canonical_Aspect : constant Aspect_To_Aspect_Mapping :=
+ Init_Canonical_Aspect;
function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is
begin
@@ -662,53 +547,6 @@ package body Aspects is
Aspect_Specifications_Hash_Table.Set (N, L);
end Set_Aspect_Specifications;
- ----------------------------------------
- -- Set_Aspect_Specifications_No_Check --
- ----------------------------------------
-
- procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id) is
- begin
- pragma Assert (Permits_Aspect_Specifications (N));
- pragma Assert (L /= No_List);
-
- Set_Has_Aspects (N);
- Set_Parent (L, N);
- Aspect_Specifications_Hash_Table.Set (N, L);
- end Set_Aspect_Specifications_No_Check;
-
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- Node : Node_Id;
- List : List_Id;
- begin
- loop
- Tree_Read_Int (Int (Node));
- Tree_Read_Int (Int (List));
- exit when List = No_List;
- Set_Aspect_Specifications_No_Check (Node, List);
- end loop;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- Node : Node_Id := Empty;
- List : List_Id;
- begin
- Aspect_Specifications_Hash_Table.Get_First (Node, List);
- loop
- Tree_Write_Int (Int (Node));
- Tree_Write_Int (Int (List));
- exit when List = No_List;
- Aspect_Specifications_Hash_Table.Get_Next (Node, List);
- end loop;
- end Tree_Write;
-
-- Package initialization sets up Aspect Id hash table
begin
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 64b0ff7..0394106 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -38,11 +38,11 @@
-- Adding New Aspects --
------------------------
--- In general, each aspect should have a corresponding pragma, so that the
--- newly developed functionality is available for Ada versions < Ada 2012.
+-- In general, each aspect should have a corresponding pragma or attribute, so
+-- that the newly developed functionality is available for old Ada versions.
-- When both are defined, it is convenient to first transform the aspect into
--- an equivalent pragma in Sem_Ch13.Analyze_Aspect_Specifications, and then
--- analyze the pragma in Sem_Prag.Analyze_Pragma.
+-- an equivalent pragma or attribute in Sem_Ch13.Analyze_Aspect_Specifications
+-- and then analyze that.
-- To add a new aspect, you need to do the following
@@ -57,7 +57,7 @@
-- treatments later.
-- 5. If the semantic analysis of expressions/names in the aspect should not
--- occur at the point the aspect is defined, add code in the adequate
+-- occur at the point the aspect is defined, add code in the appropriate
-- semantic analysis procedure for the aspect. For example, this is the
-- case for aspects Pre and Post on subprograms, which are preanalyzed
-- at the end of the declaration list to which the subprogram belongs,
@@ -76,6 +76,7 @@ package Aspects is
(No_Aspect, -- Dummy entry for no aspect
Aspect_Abstract_State, -- GNAT
Aspect_Address,
+ Aspect_Aggregate,
Aspect_Alignment,
Aspect_Annotate, -- GNAT
Aspect_Async_Readers, -- GNAT
@@ -109,6 +110,7 @@ package Aspects is
Aspect_Initial_Condition, -- GNAT
Aspect_Initializes, -- GNAT
Aspect_Input,
+ Aspect_Integer_Literal,
Aspect_Interrupt_Priority,
Aspect_Invariant, -- GNAT
Aspect_Iterator_Element,
@@ -131,12 +133,15 @@ package Aspects is
Aspect_Predicate, -- GNAT
Aspect_Predicate_Failure,
Aspect_Priority,
+ Aspect_Put_Image,
Aspect_Read,
+ Aspect_Real_Literal,
Aspect_Refined_Depends, -- GNAT
Aspect_Refined_Global, -- GNAT
Aspect_Refined_Post, -- GNAT
Aspect_Refined_State, -- GNAT
Aspect_Relative_Deadline,
+ Aspect_Relaxed_Initialization, -- GNAT
Aspect_Scalar_Storage_Order, -- GNAT
Aspect_Secondary_Stack_Size, -- GNAT
Aspect_Simple_Storage_Pool, -- GNAT
@@ -147,6 +152,7 @@ package Aspects is
Aspect_Storage_Pool,
Aspect_Storage_Size,
Aspect_Stream_Size,
+ Aspect_String_Literal,
Aspect_Suppress,
Aspect_Synchronization,
Aspect_Test_Case, -- GNAT
@@ -183,6 +189,7 @@ package Aspects is
Aspect_Atomic_Components,
Aspect_Disable_Controlled, -- GNAT
Aspect_Discard_Names,
+ Aspect_CUDA_Global, -- GNAT
Aspect_Export,
Aspect_Favor_Top_Level, -- GNAT
Aspect_Independent,
@@ -202,6 +209,7 @@ package Aspects is
Aspect_Remote_Access_Type, -- GNAT
Aspect_Shared, -- GNAT (equivalent to Atomic)
Aspect_Simple_Storage_Pool_Type, -- GNAT
+ Aspect_Static,
Aspect_Suppress_Debug_Info, -- GNAT
Aspect_Suppress_Initialization, -- GNAT
Aspect_Thread_Local_Storage, -- GNAT
@@ -212,7 +220,8 @@ package Aspects is
Aspect_Unreferenced_Objects, -- GNAT
Aspect_Volatile,
Aspect_Volatile_Components,
- Aspect_Volatile_Full_Access); -- GNAT
+ Aspect_Volatile_Full_Access, -- GNAT
+ Aspect_Yield);
subtype Aspect_Id_Exclude_No_Aspect is
Aspect_Id range Aspect_Id'Succ (No_Aspect) .. Aspect_Id'Last;
@@ -260,6 +269,7 @@ package Aspects is
Aspect_Persistent_BSS => True,
Aspect_Predicate => True,
Aspect_Pure_Function => True,
+ Aspect_Relaxed_Initialization => True,
Aspect_Remote_Access_Type => True,
Aspect_Scalar_Storage_Order => True,
Aspect_Secondary_Stack_Size => True,
@@ -292,6 +302,7 @@ package Aspects is
Aspect_Iterator_Element => True,
Aspect_Iterable => True,
Aspect_Variable_Indexing => True,
+ Aspect_Aggregate => True,
others => False);
-- The following array indicates aspects for which multiple occurrences of
@@ -337,6 +348,7 @@ package Aspects is
(No_Aspect => Optional_Expression,
Aspect_Abstract_State => Expression,
Aspect_Address => Expression,
+ Aspect_Aggregate => Expression,
Aspect_Alignment => Expression,
Aspect_Annotate => Expression,
Aspect_Async_Readers => Optional_Expression,
@@ -370,6 +382,7 @@ package Aspects is
Aspect_Initial_Condition => Expression,
Aspect_Initializes => Expression,
Aspect_Input => Name,
+ Aspect_Integer_Literal => Name,
Aspect_Interrupt_Priority => Expression,
Aspect_Invariant => Expression,
Aspect_Iterable => Expression,
@@ -392,12 +405,15 @@ package Aspects is
Aspect_Predicate => Expression,
Aspect_Predicate_Failure => Expression,
Aspect_Priority => Expression,
+ Aspect_Put_Image => Name,
Aspect_Read => Name,
+ Aspect_Real_Literal => Name,
Aspect_Refined_Depends => Expression,
Aspect_Refined_Global => Expression,
Aspect_Refined_Post => Expression,
Aspect_Refined_State => Expression,
Aspect_Relative_Deadline => Expression,
+ Aspect_Relaxed_Initialization => Optional_Expression,
Aspect_Scalar_Storage_Order => Expression,
Aspect_Secondary_Stack_Size => Expression,
Aspect_Simple_Storage_Pool => Name,
@@ -408,6 +424,7 @@ package Aspects is
Aspect_Storage_Pool => Name,
Aspect_Storage_Size => Expression,
Aspect_Stream_Size => Expression,
+ Aspect_String_Literal => Name,
Aspect_Suppress => Name,
Aspect_Synchronization => Name,
Aspect_Test_Case => Expression,
@@ -423,6 +440,142 @@ package Aspects is
Boolean_Aspects => Optional_Expression,
Library_Unit_Aspects => Optional_Expression);
+ -- The following array indicates what aspects are representation aspects
+
+ Is_Representation_Aspect : constant array (Aspect_Id) of Boolean :=
+ (No_Aspect => False,
+ Aspect_Abstract_State => False,
+ Aspect_Address => True,
+ Aspect_Aggregate => False,
+ Aspect_Alignment => True,
+ Aspect_Annotate => False,
+ Aspect_Async_Readers => False,
+ Aspect_Async_Writers => False,
+ Aspect_Attach_Handler => False,
+ Aspect_Bit_Order => True,
+ Aspect_Component_Size => True,
+ Aspect_Constant_After_Elaboration => False,
+ Aspect_Constant_Indexing => False,
+ Aspect_Contract_Cases => False,
+ Aspect_Convention => True,
+ Aspect_CPU => False,
+ Aspect_CUDA_Global => False,
+ Aspect_Default_Component_Value => True,
+ Aspect_Default_Initial_Condition => False,
+ Aspect_Default_Iterator => False,
+ Aspect_Default_Storage_Pool => True,
+ Aspect_Default_Value => True,
+ Aspect_Depends => False,
+ Aspect_Dimension => False,
+ Aspect_Dimension_System => False,
+ Aspect_Dispatching_Domain => False,
+ Aspect_Dynamic_Predicate => False,
+ Aspect_Effective_Reads => False,
+ Aspect_Effective_Writes => False,
+ Aspect_Extensions_Visible => False,
+ Aspect_External_Name => False,
+ Aspect_External_Tag => False,
+ Aspect_Ghost => False,
+ Aspect_Global => False,
+ Aspect_Implicit_Dereference => False,
+ Aspect_Initial_Condition => False,
+ Aspect_Initializes => False,
+ Aspect_Input => False,
+ Aspect_Integer_Literal => False,
+ Aspect_Interrupt_Priority => False,
+ Aspect_Invariant => False,
+ Aspect_Iterable => False,
+ Aspect_Iterator_Element => False,
+ Aspect_Link_Name => True,
+ Aspect_Linker_Section => True,
+ Aspect_Machine_Radix => True,
+ Aspect_Max_Entry_Queue_Depth => False,
+ Aspect_Max_Entry_Queue_Length => False,
+ Aspect_Max_Queue_Length => False,
+ Aspect_No_Caching => False,
+ Aspect_Object_Size => True,
+ Aspect_Obsolescent => False,
+ Aspect_Output => False,
+ Aspect_Part_Of => False,
+ Aspect_Post => False,
+ Aspect_Postcondition => False,
+ Aspect_Pre => False,
+ Aspect_Precondition => False,
+ Aspect_Predicate => False,
+ Aspect_Predicate_Failure => False,
+ Aspect_Priority => False,
+ Aspect_Put_Image => False,
+ Aspect_Read => False,
+ Aspect_Real_Literal => False,
+ Aspect_Refined_Depends => False,
+ Aspect_Refined_Global => False,
+ Aspect_Refined_Post => False,
+ Aspect_Refined_State => False,
+ Aspect_Relative_Deadline => False,
+ Aspect_Relaxed_Initialization => False,
+ Aspect_Scalar_Storage_Order => True,
+ Aspect_Secondary_Stack_Size => True,
+ Aspect_Simple_Storage_Pool => True,
+ Aspect_Size => True,
+ Aspect_Small => True,
+ Aspect_SPARK_Mode => False,
+ Aspect_Static_Predicate => False,
+ Aspect_Storage_Pool => True,
+ Aspect_Storage_Size => True,
+ Aspect_Stream_Size => True,
+ Aspect_String_Literal => False,
+ Aspect_Suppress => False,
+ Aspect_Synchronization => False,
+ Aspect_Test_Case => False,
+ Aspect_Type_Invariant => False,
+ Aspect_Unimplemented => False,
+ Aspect_Unsuppress => False,
+ Aspect_Value_Size => True,
+ Aspect_Variable_Indexing => False,
+ Aspect_Volatile_Function => False,
+ Aspect_Warnings => False,
+ Aspect_Write => False,
+
+ Library_Unit_Aspects => False,
+
+ Aspect_Asynchronous => True,
+ Aspect_Atomic => True,
+ Aspect_Atomic_Components => True,
+ Aspect_Disable_Controlled => False,
+ Aspect_Discard_Names => True,
+ Aspect_Export => True,
+ Aspect_Favor_Top_Level => False,
+ Aspect_Independent => True,
+ Aspect_Independent_Components => True,
+ Aspect_Import => True,
+ Aspect_Inline => False,
+ Aspect_Inline_Always => False,
+ Aspect_Interrupt_Handler => False,
+ Aspect_Lock_Free => False,
+ Aspect_No_Inline => False,
+ Aspect_No_Return => False,
+ Aspect_No_Tagged_Streams => False,
+ Aspect_Pack => True,
+ Aspect_Persistent_BSS => True,
+ Aspect_Preelaborable_Initialization => False,
+ Aspect_Pure_Function => False,
+ Aspect_Remote_Access_Type => False,
+ Aspect_Shared => True,
+ Aspect_Simple_Storage_Pool_Type => True,
+ Aspect_Static => False,
+ Aspect_Suppress_Debug_Info => False,
+ Aspect_Suppress_Initialization => False,
+ Aspect_Thread_Local_Storage => True,
+ Aspect_Unchecked_Union => True,
+ Aspect_Universal_Aliasing => False,
+ Aspect_Unmodified => False,
+ Aspect_Unreferenced => False,
+ Aspect_Unreferenced_Objects => False,
+ Aspect_Volatile => True,
+ Aspect_Volatile_Components => True,
+ Aspect_Volatile_Full_Access => True,
+ Aspect_Yield => False);
+
-----------------------------------------
-- Table Linking Names and Aspect_Id's --
-----------------------------------------
@@ -433,6 +586,7 @@ package Aspects is
(No_Aspect => No_Name,
Aspect_Abstract_State => Name_Abstract_State,
Aspect_Address => Name_Address,
+ Aspect_Aggregate => Name_Aggregate,
Aspect_Alignment => Name_Alignment,
Aspect_All_Calls_Remote => Name_All_Calls_Remote,
Aspect_Annotate => Name_Annotate,
@@ -449,6 +603,7 @@ package Aspects is
Aspect_Contract_Cases => Name_Contract_Cases,
Aspect_Convention => Name_Convention,
Aspect_CPU => Name_CPU,
+ Aspect_CUDA_Global => Name_CUDA_Global,
Aspect_Default_Component_Value => Name_Default_Component_Value,
Aspect_Default_Initial_Condition => Name_Default_Initial_Condition,
Aspect_Default_Iterator => Name_Default_Iterator,
@@ -480,6 +635,7 @@ package Aspects is
Aspect_Initial_Condition => Name_Initial_Condition,
Aspect_Initializes => Name_Initializes,
Aspect_Input => Name_Input,
+ Aspect_Integer_Literal => Name_Integer_Literal,
Aspect_Interrupt_Handler => Name_Interrupt_Handler,
Aspect_Interrupt_Priority => Name_Interrupt_Priority,
Aspect_Invariant => Name_Invariant,
@@ -514,12 +670,15 @@ package Aspects is
Aspect_Priority => Name_Priority,
Aspect_Pure => Name_Pure,
Aspect_Pure_Function => Name_Pure_Function,
+ Aspect_Put_Image => Name_Put_Image,
Aspect_Read => Name_Read,
+ Aspect_Real_Literal => Name_Real_Literal,
Aspect_Refined_Depends => Name_Refined_Depends,
Aspect_Refined_Global => Name_Refined_Global,
Aspect_Refined_Post => Name_Refined_Post,
Aspect_Refined_State => Name_Refined_State,
Aspect_Relative_Deadline => Name_Relative_Deadline,
+ Aspect_Relaxed_Initialization => Name_Relaxed_Initialization,
Aspect_Remote_Access_Type => Name_Remote_Access_Type,
Aspect_Remote_Call_Interface => Name_Remote_Call_Interface,
Aspect_Remote_Types => Name_Remote_Types,
@@ -532,10 +691,12 @@ package Aspects is
Aspect_Size => Name_Size,
Aspect_Small => Name_Small,
Aspect_SPARK_Mode => Name_SPARK_Mode,
+ Aspect_Static => Name_Static,
Aspect_Static_Predicate => Name_Static_Predicate,
Aspect_Storage_Pool => Name_Storage_Pool,
Aspect_Storage_Size => Name_Storage_Size,
Aspect_Stream_Size => Name_Stream_Size,
+ Aspect_String_Literal => Name_String_Literal,
Aspect_Suppress => Name_Suppress,
Aspect_Suppress_Debug_Info => Name_Suppress_Debug_Info,
Aspect_Suppress_Initialization => Name_Suppress_Initialization,
@@ -558,7 +719,8 @@ package Aspects is
Aspect_Volatile_Full_Access => Name_Volatile_Full_Access,
Aspect_Volatile_Function => Name_Volatile_Function,
Aspect_Warnings => Name_Warnings,
- Aspect_Write => Name_Write);
+ Aspect_Write => Name_Write,
+ Aspect_Yield => Name_Yield);
function Get_Aspect_Id (Name : Name_Id) return Aspect_Id;
pragma Inline (Get_Aspect_Id);
@@ -674,11 +836,13 @@ package Aspects is
Aspect_Delay : constant array (Aspect_Id) of Delay_Type :=
(No_Aspect => Always_Delay,
Aspect_Address => Always_Delay,
+ Aspect_Aggregate => Always_Delay,
Aspect_All_Calls_Remote => Always_Delay,
Aspect_Asynchronous => Always_Delay,
Aspect_Attach_Handler => Always_Delay,
Aspect_Constant_Indexing => Always_Delay,
Aspect_CPU => Always_Delay,
+ Aspect_CUDA_Global => Always_Delay,
Aspect_Default_Iterator => Always_Delay,
Aspect_Default_Storage_Pool => Always_Delay,
Aspect_Default_Value => Always_Delay,
@@ -696,6 +860,7 @@ package Aspects is
Aspect_Inline => Always_Delay,
Aspect_Inline_Always => Always_Delay,
Aspect_Input => Always_Delay,
+ Aspect_Integer_Literal => Always_Delay,
Aspect_Interrupt_Handler => Always_Delay,
Aspect_Interrupt_Priority => Always_Delay,
Aspect_Invariant => Always_Delay,
@@ -719,7 +884,9 @@ package Aspects is
Aspect_Priority => Always_Delay,
Aspect_Pure => Always_Delay,
Aspect_Pure_Function => Always_Delay,
+ Aspect_Put_Image => Always_Delay,
Aspect_Read => Always_Delay,
+ Aspect_Real_Literal => Always_Delay,
Aspect_Relative_Deadline => Always_Delay,
Aspect_Remote_Access_Type => Always_Delay,
Aspect_Remote_Call_Interface => Always_Delay,
@@ -732,6 +899,7 @@ package Aspects is
Aspect_Static_Predicate => Always_Delay,
Aspect_Storage_Pool => Always_Delay,
Aspect_Stream_Size => Always_Delay,
+ Aspect_String_Literal => Always_Delay,
Aspect_Suppress => Always_Delay,
Aspect_Suppress_Debug_Info => Always_Delay,
Aspect_Suppress_Initialization => Always_Delay,
@@ -780,12 +948,15 @@ package Aspects is
Aspect_Refined_Global => Never_Delay,
Aspect_Refined_Post => Never_Delay,
Aspect_Refined_State => Never_Delay,
+ Aspect_Relaxed_Initialization => Never_Delay,
Aspect_SPARK_Mode => Never_Delay,
+ Aspect_Static => Never_Delay,
Aspect_Synchronization => Never_Delay,
Aspect_Test_Case => Never_Delay,
Aspect_Unimplemented => Never_Delay,
Aspect_Volatile_Function => Never_Delay,
Aspect_Warnings => Never_Delay,
+ Aspect_Yield => Never_Delay,
Aspect_Alignment => Rep_Aspect,
Aspect_Atomic => Rep_Aspect,
@@ -959,10 +1130,4 @@ package Aspects is
-- node that has its Has_Aspects flag set True on entry, or with L being an
-- empty list or No_List.
- procedure Tree_Read;
- -- Reads contents of Aspect_Specifications hash table from the tree file
-
- procedure Tree_Write;
- -- Writes contents of Aspect_Specifications hash table to the tree file
-
end Aspects;
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index ef1d885..7e05a48 100644
--- a/gcc/ada/atree.adb
+++ b/gcc/ada/atree.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,7 +42,6 @@ with Nlists; use Nlists;
with Opt; use Opt;
with Output; use Output;
with Sinput; use Sinput;
-with Tree_IO; use Tree_IO;
with GNAT.Heap_Sort_G;
@@ -961,9 +960,9 @@ package body Atree is
-- The following code is a bit kludgy. It would be cleaner to
-- Add an entry Change_Expanded_Name_To_Selected_Component to
- -- Sinfo.CN, but that's an earthquake, because it has the wrong
- -- license, and Atree is used outside the compiler, e.g. in the
- -- binder and in ASIS, so we don't want to add that dependency.
+ -- Sinfo.CN, but that's delicate because Atree is used in the
+ -- binder, so we don't want to add that dependency.
+ -- ??? Revisit now that ASIS is no longer using this unit.
-- Consequently we have no choice but to hold our noses and do
-- the change manually. At least we are Atree, so this odd use
@@ -995,336 +994,6 @@ package body Atree is
return N_To_E (Nodes.Table (E + 1).Nkind);
end Ekind;
- --------------
- -- Ekind_In --
- --------------
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2;
- end Ekind_In;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3;
- end Ekind_In;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4;
- end Ekind_In;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5;
- end Ekind_In;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6;
- end Ekind_In;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7;
- end Ekind_In;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind;
- V8 : Entity_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7 or else
- T = V8;
- end Ekind_In;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind;
- V8 : Entity_Kind;
- V9 : Entity_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7 or else
- T = V8 or else
- T = V9;
- end Ekind_In;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind;
- V8 : Entity_Kind;
- V9 : Entity_Kind;
- V10 : Entity_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7 or else
- T = V8 or else
- T = V9 or else
- T = V10;
- end Ekind_In;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind;
- V8 : Entity_Kind;
- V9 : Entity_Kind;
- V10 : Entity_Kind;
- V11 : Entity_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7 or else
- T = V8 or else
- T = V9 or else
- T = V10 or else
- T = V11;
- end Ekind_In;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind) return Boolean
- is
- begin
- return Ekind_In (Ekind (E), V1, V2);
- end Ekind_In;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind) return Boolean
- is
- begin
- return Ekind_In (Ekind (E), V1, V2, V3);
- end Ekind_In;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind) return Boolean
- is
- begin
- return Ekind_In (Ekind (E), V1, V2, V3, V4);
- end Ekind_In;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind) return Boolean
- is
- begin
- return Ekind_In (Ekind (E), V1, V2, V3, V4, V5);
- end Ekind_In;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind) return Boolean
- is
- begin
- return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6);
- end Ekind_In;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind) return Boolean
- is
- begin
- return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7);
- end Ekind_In;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind;
- V8 : Entity_Kind) return Boolean
- is
- begin
- return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7, V8);
- end Ekind_In;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind;
- V8 : Entity_Kind;
- V9 : Entity_Kind) return Boolean
- is
- begin
- return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7, V8, V9);
- end Ekind_In;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind;
- V8 : Entity_Kind;
- V9 : Entity_Kind;
- V10 : Entity_Kind) return Boolean
- is
- begin
- return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10);
- end Ekind_In;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind;
- V8 : Entity_Kind;
- V9 : Entity_Kind;
- V10 : Entity_Kind;
- V11 : Entity_Kind) return Boolean
- is
- begin
- return
- Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10, V11);
- end Ekind_In;
-
------------------
-- Error_Posted --
------------------
@@ -1784,170 +1453,6 @@ package body Atree is
return Nodes.Table (N).Nkind;
end Nkind;
- --------------
- -- Nkind_In --
- --------------
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind) return Boolean
- is
- begin
- return Nkind_In (Nkind (N), V1, V2);
- end Nkind_In;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind) return Boolean
- is
- begin
- return Nkind_In (Nkind (N), V1, V2, V3);
- end Nkind_In;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind) return Boolean
- is
- begin
- return Nkind_In (Nkind (N), V1, V2, V3, V4);
- end Nkind_In;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind) return Boolean
- is
- begin
- return Nkind_In (Nkind (N), V1, V2, V3, V4, V5);
- end Nkind_In;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind) return Boolean
- is
- begin
- return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6);
- end Nkind_In;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind) return Boolean
- is
- begin
- return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7);
- end Nkind_In;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind) return Boolean
- is
- begin
- return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8);
- end Nkind_In;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind;
- V9 : Node_Kind) return Boolean
- is
- begin
- return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9);
- end Nkind_In;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind;
- V9 : Node_Kind;
- V10 : Node_Kind) return Boolean
- is
- begin
- return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10);
- end Nkind_In;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind;
- V9 : Node_Kind;
- V10 : Node_Kind;
- V11 : Node_Kind) return Boolean
- is
- begin
- return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10,
- V11);
- end Nkind_In;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind;
- V9 : Node_Kind;
- V10 : Node_Kind;
- V11 : Node_Kind;
- V12 : Node_Kind;
- V13 : Node_Kind;
- V14 : Node_Kind;
- V15 : Node_Kind;
- V16 : Node_Kind) return Boolean
- is
- begin
- return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10,
- V11, V12, V13, V14, V15, V16);
- end Nkind_In;
-
--------
-- No --
--------
@@ -2071,8 +1576,7 @@ package body Atree is
procedure Preserve_Comes_From_Source (NewN, OldN : Node_Id) is
begin
- Nodes.Table (NewN).Comes_From_Source :=
- Nodes.Table (OldN).Comes_From_Source;
+ Set_Comes_From_Source (NewN, Comes_From_Source (OldN));
end Preserve_Comes_From_Source;
----------------------
@@ -2686,32 +2190,6 @@ package body Atree is
Discard := Traverse (Node);
end Traverse_Proc;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- Tree_Read_Int (Node_Count);
- Nodes.Tree_Read;
- Flags.Tree_Read;
- Orig_Nodes.Tree_Read;
- Paren_Counts.Tree_Read;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Tree_Write_Int (Node_Count);
- Nodes.Tree_Write;
- Flags.Tree_Write;
- Orig_Nodes.Tree_Write;
- Paren_Counts.Tree_Write;
- end Tree_Write;
-
------------------------------
-- Unchecked Access Package --
------------------------------
diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index 491cde3..e958a9b 100644
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -406,8 +406,7 @@ package Atree is
procedure Initialize;
-- Called at the start of compilation to initialize the allocation of
-- the node and list tables and make the standard entries for Empty,
- -- Error and Error_List. Note that Initialize must not be called if
- -- Tree_Read is used.
+ -- Error and Error_List.
procedure Lock;
-- Called before the back end is invoked to lock the nodes table
@@ -425,15 +424,6 @@ package Atree is
-- Called to unlock entity modifications when assertions are enabled; if
-- assertions are not enabled calling this subprogram has no effect.
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines. Note that Initialize should not be called if
- -- Tree_Read is used. Tree_Read includes all necessary initialization.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
function New_Node
(New_Node_Kind : Node_Kind;
New_Sloc : Source_Ptr) return Node_Id;
@@ -680,334 +670,6 @@ package Atree is
function Sloc (N : Node_Id) return Source_Ptr;
pragma Inline (Sloc);
- ---------------------
- -- Node_Kind Tests --
- ---------------------
-
- -- These are like the functions in Sinfo, but the first argument is a
- -- Node_Id, and the tested field is Nkind (N).
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind) return Boolean;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind) return Boolean;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind) return Boolean;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind) return Boolean;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind) return Boolean;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind) return Boolean;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind) return Boolean;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind;
- V9 : Node_Kind) return Boolean;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind;
- V9 : Node_Kind;
- V10 : Node_Kind) return Boolean;
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind;
- V9 : Node_Kind;
- V10 : Node_Kind;
- V11 : Node_Kind) return Boolean;
-
- -- 12..15-parameter versions are not yet needed
-
- function Nkind_In
- (N : Node_Id;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind;
- V9 : Node_Kind;
- V10 : Node_Kind;
- V11 : Node_Kind;
- V12 : Node_Kind;
- V13 : Node_Kind;
- V14 : Node_Kind;
- V15 : Node_Kind;
- V16 : Node_Kind) return Boolean;
-
- pragma Inline (Nkind_In);
- -- Inline all above functions
-
- -----------------------
- -- Entity_Kind_Tests --
- -----------------------
-
- -- Utility functions to test whether an Entity_Kind value, either given
- -- directly as the first argument, or the Ekind field of an Entity given
- -- as the first argument, matches any of the given list of Entity_Kind
- -- values. Return True if any match, False if no match.
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind;
- V8 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind;
- V8 : Entity_Kind;
- V9 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind;
- V8 : Entity_Kind;
- V9 : Entity_Kind;
- V10 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (E : Entity_Id;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind;
- V8 : Entity_Kind;
- V9 : Entity_Kind;
- V10 : Entity_Kind;
- V11 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind;
- V8 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind;
- V8 : Entity_Kind;
- V9 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind;
- V8 : Entity_Kind;
- V9 : Entity_Kind;
- V10 : Entity_Kind) return Boolean;
-
- function Ekind_In
- (T : Entity_Kind;
- V1 : Entity_Kind;
- V2 : Entity_Kind;
- V3 : Entity_Kind;
- V4 : Entity_Kind;
- V5 : Entity_Kind;
- V6 : Entity_Kind;
- V7 : Entity_Kind;
- V8 : Entity_Kind;
- V9 : Entity_Kind;
- V10 : Entity_Kind;
- V11 : Entity_Kind) return Boolean;
-
- pragma Inline (Ekind_In);
- -- Inline all above functions
-
-----------------------------
-- Entity Access Functions --
-----------------------------
@@ -1055,10 +717,7 @@ package Atree is
procedure Set_Original_Node (N : Node_Id; Val : Node_Id);
pragma Inline (Set_Original_Node);
-- Note that this routine is used only in very peculiar cases. In normal
- -- cases, the Original_Node link is set by calls to Rewrite. We currently
- -- use it in ASIS mode to manually set the link from pragma expressions to
- -- their aspect original source expressions, so that the original source
- -- expressions accessed by ASIS are also semantically analyzed.
+ -- cases, the Original_Node link is set by calls to Rewrite.
procedure Set_Parent (N : Node_Id; Val : Node_Id);
pragma Inline (Set_Parent);
@@ -1180,10 +839,9 @@ package Atree is
function Original_Node (Node : Node_Id) return Node_Id;
pragma Inline (Original_Node);
-- If Node has not been rewritten, then returns its input argument
- -- unchanged, else returns the Node for the original subtree. Note that
- -- this is used extensively by ASIS on the trees constructed in ASIS mode
- -- to reconstruct the original semantic tree. See section in sinfo.ads
- -- for requirements on original nodes returned by this function.
+ -- unchanged, else returns the Node for the original subtree. See section
+ -- in sinfo.ads for requirements on original nodes returned by this
+ -- function.
--
-- Note: Parents are not preserved in original tree nodes that are
-- retrieved in this way (i.e. their children may have children whose
diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h
index 9187583..c63c535 100644
--- a/gcc/ada/atree.h
+++ b/gcc/ada/atree.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/aux-io.c b/gcc/ada/aux-io.c
index e022b65..f559c39 100644
--- a/gcc/ada/aux-io.c
+++ b/gcc/ada/aux-io.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb
index 34f24d9..38266fc 100644
--- a/gcc/ada/back_end.adb
+++ b/gcc/ada/back_end.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -385,9 +385,6 @@ package body Back_End is
elsif Is_Front_End_Switch (Argv) then
Scan_Front_End_Switches (Argv, Args, Next_Arg);
- elsif Argv (Argv'First + 1 .. Argv'Last) = "fopenacc" then
- Opt.OpenAcc_Enabled := True;
-
-- All non-front-end switches are back-end switches
else
diff --git a/gcc/ada/back_end.ads b/gcc/ada/back_end.ads
index 0d13b3f..05f6e5bc 100644
--- a/gcc/ada/back_end.ads
+++ b/gcc/ada/back_end.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -67,7 +67,6 @@ package Back_End is
-- default for all of these in Opt is False).
--
-- Opt.Disable_FE_Inline
- -- Opt.Disable_FE_Inline_Always
-- Opt.Suppress_Control_Float_Optimizations
-- Opt.Generate_SCO
-- Opt.Generate_SCO_Instance_Table
diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb
index 2324630..000f73d 100644
--- a/gcc/ada/bcheck.adb
+++ b/gcc/ada/bcheck.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -771,7 +771,7 @@ package body Bcheck is
-- Reset when we find a unit that depends on the default and does
-- not have a local specification of the Optimize_Alignment setting.
- OA_Unit : Unit_Id;
+ OA_Unit : Unit_Id := No_Unit_Id;
-- Id of unit from which OA_Setting was set
C : Character;
@@ -789,6 +789,7 @@ package body Bcheck is
null;
else
+ pragma Assert (Present (OA_Unit));
Error_Msg_Unit_1 := Units.Table (OA_Unit).Uname;
Error_Msg_Unit_2 := Units.Table (U).Uname;
diff --git a/gcc/ada/bcheck.ads b/gcc/ada/bcheck.ads
index 6d757d4..3cd62b6 100644
--- a/gcc/ada/bcheck.ads
+++ b/gcc/ada/bcheck.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb
index 5caee49..97b2764 100644
--- a/gcc/ada/binde.adb
+++ b/gcc/ada/binde.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1056,6 +1056,8 @@ package body Binde is
-- becomes zero, then add to no-predecessor list.
S := UNR.Table (Chosen).Successors;
+ pragma Annotate (CodePeer, Modified, S);
+
while S /= No_Successor loop
U := Succ.Table (S).After;
UNR.Table (U).Num_Pred := UNR.Table (U).Num_Pred - 1;
@@ -2390,6 +2392,8 @@ package body Binde is
begin
if ST.Reason in Elab_All .. Elab_All_Desirable then
L := ST.Elab_All_Link;
+ pragma Annotate (CodePeer, Modified, L);
+
while L /= No_Elab_All_Link loop
Nam := Elab_All_Entries.Table (L).Needed_By;
Error_Msg_Unit_1 := Nam;
diff --git a/gcc/ada/binde.ads b/gcc/ada/binde.ads
index bdea7dc..c0830c9 100644
--- a/gcc/ada/binde.ads
+++ b/gcc/ada/binde.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/binderr.adb b/gcc/ada/binderr.adb
index 236d7c7..1169e43 100644
--- a/gcc/ada/binderr.adb
+++ b/gcc/ada/binderr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/binderr.ads b/gcc/ada/binderr.ads
index 20e991c..4b538fd 100644
--- a/gcc/ada/binderr.ads
+++ b/gcc/ada/binderr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb
index 9ac50fe..91b4cb3 100644
--- a/gcc/ada/bindgen.adb
+++ b/gcc/ada/bindgen.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -197,6 +197,7 @@ package body Bindgen is
-- Main_CPU : Integer;
-- Default_Sized_SS_Pool : System.Address;
-- Binder_Sec_Stacks_Count : Natural;
+ -- XDR_Stream : Integer;
-- Main_Priority is the priority value set by pragma Priority in the main
-- program. If no such pragma is present, the value is -1.
@@ -295,6 +296,9 @@ package body Bindgen is
-- Binder_Sec_Stacks_Count is the number of generated secondary stacks in
-- the Default_Sized_SS_Pool.
+ -- XDR_Stream indicates whether streaming should be performed using the
+ -- XDR protocol. A value of one indicates that XDR streaming is enabled.
+
procedure WBI (Info : String) renames Osint.B.Write_Binder_Info;
-- Convenient shorthand used throughout
@@ -457,7 +461,7 @@ package body Bindgen is
if not Bind_For_Library and not CodePeer_Mode then
WBI (" procedure s_stalib_adafinal;");
- Set_String (" pragma Import (C, s_stalib_adafinal, ");
+ Set_String (" pragma Import (Ada, s_stalib_adafinal, ");
Set_String ("""system__standard_library__adafinal"");");
Write_Statement_Buffer;
end if;
@@ -758,13 +762,21 @@ package body Bindgen is
"""__gnat_default_ss_size"");");
end if;
- WBI (" Leap_Seconds_Support : Integer;");
- WBI (" pragma Import (C, Leap_Seconds_Support, " &
- """__gl_leap_seconds_support"");");
+ if Leap_Seconds_Support then
+ WBI (" Leap_Seconds_Support : Integer;");
+ WBI (" pragma Import (C, Leap_Seconds_Support, " &
+ """__gl_leap_seconds_support"");");
+ end if;
+
WBI (" Bind_Env_Addr : System.Address;");
WBI (" pragma Import (C, Bind_Env_Addr, " &
"""__gl_bind_env_addr"");");
+ if XDR_Stream then
+ WBI (" XDR_Stream : Integer;");
+ WBI (" pragma Import (C, XDR_Stream, ""__gl_xdr_stream"");");
+ end if;
+
-- Import entry point for elaboration time signal handler
-- installation, and indication of if it's been called previously.
@@ -978,16 +990,13 @@ package body Bindgen is
Set_String (";");
Write_Statement_Buffer;
- Set_String (" Leap_Seconds_Support := ");
-
if Leap_Seconds_Support then
- Set_Int (1);
- else
- Set_Int (0);
+ WBI (" Leap_Seconds_Support := 1;");
end if;
- Set_String (";");
- Write_Statement_Buffer;
+ if XDR_Stream then
+ WBI (" XDR_Stream := 1;");
+ end if;
if Bind_Env_String_Built then
WBI (" Bind_Env_Addr := Bind_Env'Address;");
diff --git a/gcc/ada/bindgen.ads b/gcc/ada/bindgen.ads
index 722cfad..c70cd09 100644
--- a/gcc/ada/bindgen.ads
+++ b/gcc/ada/bindgen.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/bindo-augmentors.adb b/gcc/ada/bindo-augmentors.adb
index 57fb541..a2a1de0 100644
--- a/gcc/ada/bindo-augmentors.adb
+++ b/gcc/ada/bindo-augmentors.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -57,7 +57,6 @@ package body Bindo.Augmentors is
procedure Visit_Elaboration_Root
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Root : Invocation_Graph_Vertex_Id);
pragma Inline (Visit_Elaboration_Root);
-- Start a DFS traversal from elaboration root Root to:
@@ -67,9 +66,7 @@ package body Bindo.Augmentors is
-- * Create invocation edges for each such transition where the
-- successor is Root.
- procedure Visit_Elaboration_Roots
- (Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph);
+ procedure Visit_Elaboration_Roots (Inv_Graph : Invocation_Graph);
pragma Inline (Visit_Elaboration_Roots);
-- Start a DFS traversal from all elaboration roots to:
--
@@ -80,7 +77,6 @@ package body Bindo.Augmentors is
procedure Visit_Vertex
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Invoker : Invocation_Graph_Vertex_Id;
Last_Vertex : Library_Graph_Vertex_Id;
Root_Vertex : Library_Graph_Vertex_Id;
@@ -113,10 +109,8 @@ package body Bindo.Augmentors is
-- Augment_Library_Graph --
---------------------------
- procedure Augment_Library_Graph
- (Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph)
- is
+ procedure Augment_Library_Graph (Inv_Graph : Invocation_Graph) is
+ Lib_Graph : constant Library_Graph := Get_Lib_Graph (Inv_Graph);
begin
pragma Assert (Present (Lib_Graph));
@@ -133,7 +127,7 @@ package body Bindo.Augmentors is
Longest_Path := 0;
Total_Visited := 0;
- Visit_Elaboration_Roots (Inv_Graph, Lib_Graph);
+ Visit_Elaboration_Roots (Inv_Graph);
Write_Statistics;
End_Phase (Library_Graph_Augmentation);
@@ -145,9 +139,9 @@ package body Bindo.Augmentors is
procedure Visit_Elaboration_Root
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Root : Invocation_Graph_Vertex_Id)
is
+ Lib_Graph : constant Library_Graph := Get_Lib_Graph (Inv_Graph);
pragma Assert (Present (Inv_Graph));
pragma Assert (Present (Lib_Graph));
pragma Assert (Present (Root));
@@ -173,7 +167,6 @@ package body Bindo.Augmentors is
Visit_Vertex
(Inv_Graph => Inv_Graph,
- Lib_Graph => Lib_Graph,
Invoker => Root,
Last_Vertex => Root_Vertex,
Root_Vertex => Root_Vertex,
@@ -189,25 +182,20 @@ package body Bindo.Augmentors is
-- Visit_Elaboration_Roots --
-----------------------------
- procedure Visit_Elaboration_Roots
- (Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph)
- is
+ procedure Visit_Elaboration_Roots (Inv_Graph : Invocation_Graph) is
+ Lib_Graph : constant Library_Graph := Get_Lib_Graph (Inv_Graph);
+ pragma Assert (Present (Inv_Graph));
+ pragma Assert (Present (Lib_Graph));
+
Iter : Elaboration_Root_Iterator;
Root : Invocation_Graph_Vertex_Id;
begin
- pragma Assert (Present (Inv_Graph));
- pragma Assert (Present (Lib_Graph));
-
Iter := Iterate_Elaboration_Roots (Inv_Graph);
while Has_Next (Iter) loop
Next (Iter, Root);
- Visit_Elaboration_Root
- (Inv_Graph => Inv_Graph,
- Lib_Graph => Lib_Graph,
- Root => Root);
+ Visit_Elaboration_Root (Inv_Graph => Inv_Graph, Root => Root);
end loop;
end Visit_Elaboration_Roots;
@@ -217,7 +205,6 @@ package body Bindo.Augmentors is
procedure Visit_Vertex
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Invoker : Invocation_Graph_Vertex_Id;
Last_Vertex : Library_Graph_Vertex_Id;
Root_Vertex : Library_Graph_Vertex_Id;
@@ -226,6 +213,8 @@ package body Bindo.Augmentors is
Internal_Controlled_Action : Boolean;
Path : Natural)
is
+ Lib_Graph : constant Library_Graph := Get_Lib_Graph (Inv_Graph);
+
New_Path : constant Natural := Path + 1;
Edge : Invocation_Graph_Edge_Id;
@@ -300,7 +289,6 @@ package body Bindo.Augmentors is
Visit_Vertex
(Inv_Graph => Inv_Graph,
- Lib_Graph => Lib_Graph,
Invoker => Target (Inv_Graph, Edge),
Last_Vertex => Invoker_Vertex,
Root_Vertex => Root_Vertex,
diff --git a/gcc/ada/bindo-augmentors.ads b/gcc/ada/bindo-augmentors.ads
index c00d5c0..a8fa158 100644
--- a/gcc/ada/bindo-augmentors.ads
+++ b/gcc/ada/bindo-augmentors.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,11 +42,9 @@ package Bindo.Augmentors is
------------------------------
package Library_Graph_Augmentors is
- procedure Augment_Library_Graph
- (Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph);
- -- Augment library graph Lib_Graph with information from invocation
- -- graph Inv_Graph as follows:
+ procedure Augment_Library_Graph (Inv_Graph : Invocation_Graph);
+ -- Augment the library graph of Inv_Graph with information from
+ -- invocation graph Inv_Graph as follows:
--
-- 1) Traverse the invocation graph starting from each elaboration
-- procedure of unit Root.
diff --git a/gcc/ada/bindo-builders.adb b/gcc/ada/bindo-builders.adb
index 9919007..66801f4 100644
--- a/gcc/ada/bindo-builders.adb
+++ b/gcc/ada/bindo-builders.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -110,7 +110,8 @@ package body Bindo.Builders is
Inv_Graph :=
Create
(Initial_Vertices => Number_Of_Elaborable_Units,
- Initial_Edges => Number_Of_Elaborable_Units);
+ Initial_Edges => Number_Of_Elaborable_Units,
+ Lib_Graph => Lib_G);
Lib_Graph := Lib_G;
For_Each_Elaborable_Unit (Create_Vertices'Access);
diff --git a/gcc/ada/bindo-builders.ads b/gcc/ada/bindo-builders.ads
index 54c39e4..e3cbe63 100644
--- a/gcc/ada/bindo-builders.ads
+++ b/gcc/ada/bindo-builders.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/bindo-diagnostics.adb b/gcc/ada/bindo-diagnostics.adb
index 6f19ac0..ed1abf8 100644
--- a/gcc/ada/bindo-diagnostics.adb
+++ b/gcc/ada/bindo-diagnostics.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -25,7 +25,6 @@
with Binderr; use Binderr;
with Debug; use Debug;
-with Restrict; use Restrict;
with Rident; use Rident;
with Types; use Types;
@@ -44,22 +43,18 @@ package body Bindo.Diagnostics is
-- Local subprograms --
-----------------------
- procedure Diagnose_All_Cycles
- (Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph);
+ procedure Diagnose_All_Cycles (Inv_Graph : Invocation_Graph);
pragma Inline (Diagnose_All_Cycles);
-- Emit diagnostics for all cycles of library graph G
procedure Diagnose_Cycle
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Cycle : Library_Graph_Cycle_Id);
pragma Inline (Diagnose_Cycle);
-- Emit diagnostics for cycle Cycle of library graph G
procedure Find_And_Output_Invocation_Paths
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Source : Library_Graph_Vertex_Id;
Destination : Library_Graph_Vertex_Id);
pragma Inline (Find_And_Output_Invocation_Paths);
@@ -69,7 +64,6 @@ package body Bindo.Diagnostics is
function Find_Elaboration_Root
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Vertex : Library_Graph_Vertex_Id) return Invocation_Graph_Vertex_Id;
pragma Inline (Find_Elaboration_Root);
-- Find the elaboration root in invocation graph Inv_Graph that corresponds
@@ -171,7 +165,6 @@ package body Bindo.Diagnostics is
procedure Output_Invocation_Path
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Elaborated_Vertex : Library_Graph_Vertex_Id;
Path : IGE_Lists.Doubly_Linked_List;
Path_Id : in out Nat);
@@ -182,11 +175,10 @@ package body Bindo.Diagnostics is
procedure Output_Invocation_Path_Transition
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Edge : Invocation_Graph_Edge_Id);
pragma Inline (Output_Invocation_Path_Transition);
-- Output a transition through edge Edge of invocation graph G, which is
- -- part of an invocation path. Lib_Graph is the related library graph.
+ -- part of an invocation path.
procedure Output_Invocation_Related_Suggestions
(G : Library_Graph;
@@ -197,7 +189,6 @@ package body Bindo.Diagnostics is
procedure Output_Invocation_Transition
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Source : Library_Graph_Vertex_Id;
Destination : Library_Graph_Vertex_Id);
pragma Inline (Output_Invocation_Transition);
@@ -222,7 +213,6 @@ package body Bindo.Diagnostics is
procedure Output_Transition
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Current_Edge : Library_Graph_Edge_Id;
Next_Edge : Library_Graph_Edge_Id;
Elaborate_All_Active : Boolean);
@@ -247,7 +237,6 @@ package body Bindo.Diagnostics is
procedure Visit_Vertex
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Invoker : Invocation_Graph_Vertex_Id;
Invoker_Vertex : Library_Graph_Vertex_Id;
Last_Vertex : Library_Graph_Vertex_Id;
@@ -269,10 +258,9 @@ package body Bindo.Diagnostics is
-- Diagnose_All_Cycles --
-------------------------
- procedure Diagnose_All_Cycles
- (Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph)
- is
+ procedure Diagnose_All_Cycles (Inv_Graph : Invocation_Graph) is
+ Lib_Graph : constant Library_Graph := Get_Lib_Graph (Inv_Graph);
+
Cycle : Library_Graph_Cycle_Id;
Iter : All_Cycle_Iterator;
@@ -284,10 +272,7 @@ package body Bindo.Diagnostics is
while Has_Next (Iter) loop
Next (Iter, Cycle);
- Diagnose_Cycle
- (Inv_Graph => Inv_Graph,
- Lib_Graph => Lib_Graph,
- Cycle => Cycle);
+ Diagnose_Cycle (Inv_Graph => Inv_Graph, Cycle => Cycle);
end loop;
end Diagnose_All_Cycles;
@@ -295,10 +280,8 @@ package body Bindo.Diagnostics is
-- Diagnose_Circularities --
----------------------------
- procedure Diagnose_Circularities
- (Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph)
- is
+ procedure Diagnose_Circularities (Inv_Graph : Invocation_Graph) is
+ Lib_Graph : constant Library_Graph := Get_Lib_Graph (Inv_Graph);
begin
pragma Assert (Present (Inv_Graph));
pragma Assert (Present (Lib_Graph));
@@ -313,14 +296,13 @@ package body Bindo.Diagnostics is
-- switch -d_C (diagnose all cycles) is in effect.
if Debug_Flag_Underscore_CC then
- Diagnose_All_Cycles (Inv_Graph, Lib_Graph);
+ Diagnose_All_Cycles (Inv_Graph);
-- Otherwise diagnose the most important cycle in the graph
else
Diagnose_Cycle
(Inv_Graph => Inv_Graph,
- Lib_Graph => Lib_Graph,
Cycle => Highest_Precedence_Cycle (Lib_Graph));
end if;
end Diagnose_Circularities;
@@ -331,9 +313,10 @@ package body Bindo.Diagnostics is
procedure Diagnose_Cycle
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Cycle : Library_Graph_Cycle_Id)
is
+ Lib_Graph : constant Library_Graph := Get_Lib_Graph (Inv_Graph);
+
pragma Assert (Present (Inv_Graph));
pragma Assert (Present (Lib_Graph));
pragma Assert (Present (Cycle));
@@ -343,7 +326,7 @@ package body Bindo.Diagnostics is
(G => Lib_Graph,
Cycle => Cycle);
- Current_Edge : Library_Graph_Edge_Id;
+ Current_Edge : Library_Graph_Edge_Id := No_Library_Graph_Edge;
First_Edge : Library_Graph_Edge_Id;
Iter : Edges_Of_Cycle_Iterator;
Next_Edge : Library_Graph_Edge_Id;
@@ -382,7 +365,6 @@ package body Bindo.Diagnostics is
Output_Transition
(Inv_Graph => Inv_Graph,
- Lib_Graph => Lib_Graph,
Current_Edge => Current_Edge,
Next_Edge => Next_Edge,
Elaborate_All_Active => Elaborate_All_Active);
@@ -394,7 +376,6 @@ package body Bindo.Diagnostics is
Output_Transition
(Inv_Graph => Inv_Graph,
- Lib_Graph => Lib_Graph,
Current_Edge => Current_Edge,
Next_Edge => First_Edge,
Elaborate_All_Active => Elaborate_All_Active);
@@ -415,10 +396,11 @@ package body Bindo.Diagnostics is
procedure Find_And_Output_Invocation_Paths
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Source : Library_Graph_Vertex_Id;
Destination : Library_Graph_Vertex_Id)
is
+ Lib_Graph : constant Library_Graph := Get_Lib_Graph (Inv_Graph);
+
Path : IGE_Lists.Doubly_Linked_List;
Path_Id : Nat;
Visited : IGV_Sets.Membership_Set;
@@ -449,11 +431,9 @@ package body Bindo.Diagnostics is
Visit_Vertex
(Inv_Graph => Inv_Graph,
- Lib_Graph => Lib_Graph,
Invoker =>
Find_Elaboration_Root
(Inv_Graph => Inv_Graph,
- Lib_Graph => Lib_Graph,
Vertex => Source),
Invoker_Vertex => Source,
Last_Vertex => Source,
@@ -473,9 +453,10 @@ package body Bindo.Diagnostics is
function Find_Elaboration_Root
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Vertex : Library_Graph_Vertex_Id) return Invocation_Graph_Vertex_Id
is
+ Lib_Graph : constant Library_Graph := Get_Lib_Graph (Inv_Graph);
+
Current_Vertex : Invocation_Graph_Vertex_Id;
Iter : Elaboration_Root_Iterator;
Root_Vertex : Invocation_Graph_Vertex_Id;
@@ -982,11 +963,12 @@ package body Bindo.Diagnostics is
procedure Output_Invocation_Path
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Elaborated_Vertex : Library_Graph_Vertex_Id;
Path : IGE_Lists.Doubly_Linked_List;
Path_Id : in out Nat)
is
+ Lib_Graph : constant Library_Graph := Get_Lib_Graph (Inv_Graph);
+
Edge : Invocation_Graph_Edge_Id;
Iter : IGE_Lists.Iterator;
@@ -1007,9 +989,7 @@ package body Bindo.Diagnostics is
IGE_Lists.Next (Iter, Edge);
Output_Invocation_Path_Transition
- (Inv_Graph => Inv_Graph,
- Lib_Graph => Lib_Graph,
- Edge => Edge);
+ (Inv_Graph => Inv_Graph, Edge => Edge);
end loop;
Path_Id := Path_Id + 1;
@@ -1021,9 +1001,10 @@ package body Bindo.Diagnostics is
procedure Output_Invocation_Path_Transition
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Edge : Invocation_Graph_Edge_Id)
is
+ Lib_Graph : constant Library_Graph := Get_Lib_Graph (Inv_Graph);
+
pragma Assert (Present (Inv_Graph));
pragma Assert (Present (Lib_Graph));
pragma Assert (Present (Edge));
@@ -1162,7 +1143,7 @@ package body Bindo.Diagnostics is
-- within the task body on a select or accept statement, eliminating
-- subsequent invocation edges, thus breaking the cycle.
- if not Restriction_Active (No_Entry_Calls_In_Elaboration_Code)
+ if not Cumulative_Restrictions.Set (No_Entry_Calls_In_Elaboration_Code)
and then Contains_Task_Activation (G, Cycle)
then
Error_Msg_Info
@@ -1186,10 +1167,10 @@ package body Bindo.Diagnostics is
procedure Output_Invocation_Transition
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Source : Library_Graph_Vertex_Id;
Destination : Library_Graph_Vertex_Id)
is
+ Lib_Graph : constant Library_Graph := Get_Lib_Graph (Inv_Graph);
begin
pragma Assert (Present (Inv_Graph));
pragma Assert (Present (Lib_Graph));
@@ -1203,7 +1184,6 @@ package body Bindo.Diagnostics is
Find_And_Output_Invocation_Paths
(Inv_Graph => Inv_Graph,
- Lib_Graph => Lib_Graph,
Source => Source,
Destination => Destination);
end Output_Invocation_Transition;
@@ -1302,11 +1282,12 @@ package body Bindo.Diagnostics is
procedure Output_Transition
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Current_Edge : Library_Graph_Edge_Id;
Next_Edge : Library_Graph_Edge_Id;
Elaborate_All_Active : Boolean)
is
+ Lib_Graph : constant Library_Graph := Get_Lib_Graph (Inv_Graph);
+
pragma Assert (Present (Inv_Graph));
pragma Assert (Present (Lib_Graph));
pragma Assert (Present (Current_Edge));
@@ -1353,7 +1334,6 @@ package body Bindo.Diagnostics is
elsif Is_Invocation_Edge (Lib_Graph, Current_Edge) then
Output_Invocation_Transition
(Inv_Graph => Inv_Graph,
- Lib_Graph => Lib_Graph,
Source => Source,
Destination => Expected_Destination);
@@ -1466,7 +1446,6 @@ package body Bindo.Diagnostics is
procedure Visit_Vertex
(Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph;
Invoker : Invocation_Graph_Vertex_Id;
Invoker_Vertex : Library_Graph_Vertex_Id;
Last_Vertex : Library_Graph_Vertex_Id;
@@ -1476,6 +1455,8 @@ package body Bindo.Diagnostics is
Path : IGE_Lists.Doubly_Linked_List;
Path_Id : in out Nat)
is
+ Lib_Graph : constant Library_Graph := Get_Lib_Graph (Inv_Graph);
+
Edge : Invocation_Graph_Edge_Id;
Iter : Edges_To_Targets_Iterator;
Targ : Invocation_Graph_Vertex_Id;
@@ -1500,7 +1481,6 @@ package body Bindo.Diagnostics is
then
Output_Invocation_Path
(Inv_Graph => Inv_Graph,
- Lib_Graph => Lib_Graph,
Elaborated_Vertex => Elaborated_Vertex,
Path => Path,
Path_Id => Path_Id);
@@ -1531,7 +1511,6 @@ package body Bindo.Diagnostics is
Visit_Vertex
(Inv_Graph => Inv_Graph,
- Lib_Graph => Lib_Graph,
Invoker => Targ,
Invoker_Vertex => Body_Vertex (Inv_Graph, Targ),
Last_Vertex => Invoker_Vertex,
diff --git a/gcc/ada/bindo-diagnostics.ads b/gcc/ada/bindo-diagnostics.ads
index 3835a68..24f4f52 100644
--- a/gcc/ada/bindo-diagnostics.ads
+++ b/gcc/ada/bindo-diagnostics.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -51,11 +51,9 @@ package Bindo.Diagnostics is
-- API --
---------
- procedure Diagnose_Circularities
- (Inv_Graph : Invocation_Graph;
- Lib_Graph : Library_Graph);
+ procedure Diagnose_Circularities (Inv_Graph : Invocation_Graph);
pragma Inline (Diagnose_Circularities);
- -- Diagnose all cycles of library graph Lib_Graph with matching invocation
- -- graph Inv_Graph.
+ -- Diagnose all cycles of the library graph of Inv_Graph with matching
+ -- invocation graph Inv_Graph.
end Bindo.Diagnostics;
diff --git a/gcc/ada/bindo-elaborators.adb b/gcc/ada/bindo-elaborators.adb
index 9e207e1..f36b915 100644
--- a/gcc/ada/bindo-elaborators.adb
+++ b/gcc/ada/bindo-elaborators.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -733,7 +733,7 @@ package body Bindo.Elaborators is
-- order to discover transitions of the execution flow from a unit
-- to a unit that result in extra edges within the library graph.
- Augment_Library_Graph (Inv_Graph, Lib_Graph);
+ Augment_Library_Graph (Inv_Graph);
-- Create the component graph by collapsing all library items into
-- library units and traversing the library graph.
@@ -780,7 +780,7 @@ package body Bindo.Elaborators is
-- Otherwise the library graph contains at least one circularity
else
- Diagnose_Circularities (Inv_Graph, Lib_Graph);
+ Diagnose_Circularities (Inv_Graph);
end if;
Destroy (Inv_Graph);
diff --git a/gcc/ada/bindo-elaborators.ads b/gcc/ada/bindo-elaborators.ads
index c65f593..7cbd9c9 100644
--- a/gcc/ada/bindo-elaborators.ads
+++ b/gcc/ada/bindo-elaborators.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/bindo-graphs.adb b/gcc/ada/bindo-graphs.adb
index 7802e7d..3b2b753 100644
--- a/gcc/ada/bindo-graphs.adb
+++ b/gcc/ada/bindo-graphs.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -172,867 +172,6 @@ package body Bindo.Graphs is
return Bucket_Range_Type (Vertex);
end Hash_Library_Graph_Vertex;
- -----------------------
- -- Invocation_Graphs --
- -----------------------
-
- package body Invocation_Graphs is
-
- -----------------------
- -- Local subprograms --
- -----------------------
-
- procedure Free is
- new Ada.Unchecked_Deallocation
- (Invocation_Graph_Attributes, Invocation_Graph);
-
- function Get_IGE_Attributes
- (G : Invocation_Graph;
- Edge : Invocation_Graph_Edge_Id)
- return Invocation_Graph_Edge_Attributes;
- pragma Inline (Get_IGE_Attributes);
- -- Obtain the attributes of edge Edge of invocation graph G
-
- function Get_IGV_Attributes
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id)
- return Invocation_Graph_Vertex_Attributes;
- pragma Inline (Get_IGV_Attributes);
- -- Obtain the attributes of vertex Vertex of invocation graph G
-
- procedure Increment_Invocation_Graph_Edge_Count
- (G : Invocation_Graph;
- Kind : Invocation_Kind);
- pragma Inline (Increment_Invocation_Graph_Edge_Count);
- -- Increment the number of edges of king Kind in invocation graph G by
- -- one.
-
- function Is_Elaboration_Root
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Boolean;
- pragma Inline (Is_Elaboration_Root);
- -- Determine whether vertex Vertex of invocation graph denotes the
- -- elaboration procedure of a spec or a body.
-
- function Is_Existing_Source_Target_Relation
- (G : Invocation_Graph;
- Rel : Source_Target_Relation) return Boolean;
- pragma Inline (Is_Existing_Source_Target_Relation);
- -- Determine whether a source vertex and a target vertex described by
- -- relation Rel are already related in invocation graph G.
-
- procedure Save_Elaboration_Root
- (G : Invocation_Graph;
- Root : Invocation_Graph_Vertex_Id);
- pragma Inline (Save_Elaboration_Root);
- -- Save elaboration root Root of invocation graph G
-
- procedure Set_Corresponding_Vertex
- (G : Invocation_Graph;
- IS_Id : Invocation_Signature_Id;
- Vertex : Invocation_Graph_Vertex_Id);
- pragma Inline (Set_Corresponding_Vertex);
- -- Associate vertex Vertex of invocation graph G with signature IS_Id
-
- procedure Set_Is_Existing_Source_Target_Relation
- (G : Invocation_Graph;
- Rel : Source_Target_Relation;
- Val : Boolean := True);
- pragma Inline (Set_Is_Existing_Source_Target_Relation);
- -- Mark a source vertex and a target vertex described by relation Rel as
- -- already related in invocation graph G depending on value Val.
-
- procedure Set_IGE_Attributes
- (G : Invocation_Graph;
- Edge : Invocation_Graph_Edge_Id;
- Val : Invocation_Graph_Edge_Attributes);
- pragma Inline (Set_IGE_Attributes);
- -- Set the attributes of edge Edge of invocation graph G to value Val
-
- procedure Set_IGV_Attributes
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id;
- Val : Invocation_Graph_Vertex_Attributes);
- pragma Inline (Set_IGV_Attributes);
- -- Set the attributes of vertex Vertex of invocation graph G to value
- -- Val.
-
- --------------
- -- Add_Edge --
- --------------
-
- procedure Add_Edge
- (G : Invocation_Graph;
- Source : Invocation_Graph_Vertex_Id;
- Target : Invocation_Graph_Vertex_Id;
- IR_Id : Invocation_Relation_Id)
- is
- pragma Assert (Present (G));
- pragma Assert (Present (Source));
- pragma Assert (Present (Target));
- pragma Assert (Present (IR_Id));
-
- Rel : constant Source_Target_Relation :=
- (Source => Source,
- Target => Target);
-
- Edge : Invocation_Graph_Edge_Id;
-
- begin
- -- Nothing to do when the source and target are already related by an
- -- edge.
-
- if Is_Existing_Source_Target_Relation (G, Rel) then
- return;
- end if;
-
- Edge := Sequence_Next_Edge;
-
- -- Add the edge to the underlying graph
-
- DG.Add_Edge
- (G => G.Graph,
- E => Edge,
- Source => Source,
- Destination => Target);
-
- -- Build and save the attributes of the edge
-
- Set_IGE_Attributes
- (G => G,
- Edge => Edge,
- Val => (Relation => IR_Id));
-
- -- Mark the source and target as related by the new edge. This
- -- prevents all further attempts to link the same source and target.
-
- Set_Is_Existing_Source_Target_Relation (G, Rel);
-
- -- Update the edge statistics
-
- Increment_Invocation_Graph_Edge_Count (G, Kind (IR_Id));
- end Add_Edge;
-
- ----------------
- -- Add_Vertex --
- ----------------
-
- procedure Add_Vertex
- (G : Invocation_Graph;
- IC_Id : Invocation_Construct_Id;
- Body_Vertex : Library_Graph_Vertex_Id;
- Spec_Vertex : Library_Graph_Vertex_Id)
- is
- pragma Assert (Present (G));
- pragma Assert (Present (IC_Id));
- pragma Assert (Present (Body_Vertex));
- pragma Assert (Present (Spec_Vertex));
-
- Construct_Signature : constant Invocation_Signature_Id :=
- Signature (IC_Id);
- Vertex : Invocation_Graph_Vertex_Id;
-
- begin
- -- Nothing to do when the construct already has a vertex
-
- if Present (Corresponding_Vertex (G, Construct_Signature)) then
- return;
- end if;
-
- Vertex := Sequence_Next_Vertex;
-
- -- Add the vertex to the underlying graph
-
- DG.Add_Vertex (G.Graph, Vertex);
-
- -- Build and save the attributes of the vertex
-
- Set_IGV_Attributes
- (G => G,
- Vertex => Vertex,
- Val => (Body_Vertex => Body_Vertex,
- Construct => IC_Id,
- Spec_Vertex => Spec_Vertex));
-
- -- Associate the construct with its corresponding vertex
-
- Set_Corresponding_Vertex (G, Construct_Signature, Vertex);
-
- -- Save the vertex for later processing when it denotes a spec or
- -- body elaboration procedure.
-
- if Is_Elaboration_Root (G, Vertex) then
- Save_Elaboration_Root (G, Vertex);
- end if;
- end Add_Vertex;
-
- -----------------
- -- Body_Vertex --
- -----------------
-
- function Body_Vertex
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Vertex));
-
- return Get_IGV_Attributes (G, Vertex).Body_Vertex;
- end Body_Vertex;
-
- ------------
- -- Column --
- ------------
-
- function Column
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Nat
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Vertex));
-
- return Column (Signature (Construct (G, Vertex)));
- end Column;
-
- ---------------
- -- Construct --
- ---------------
-
- function Construct
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Invocation_Construct_Id
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Vertex));
-
- return Get_IGV_Attributes (G, Vertex).Construct;
- end Construct;
-
- --------------------------
- -- Corresponding_Vertex --
- --------------------------
-
- function Corresponding_Vertex
- (G : Invocation_Graph;
- IS_Id : Invocation_Signature_Id) return Invocation_Graph_Vertex_Id
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (IS_Id));
-
- return Signature_Tables.Get (G.Signature_To_Vertex, IS_Id);
- end Corresponding_Vertex;
-
- ------------
- -- Create --
- ------------
-
- function Create
- (Initial_Vertices : Positive;
- Initial_Edges : Positive) return Invocation_Graph
- is
- G : constant Invocation_Graph := new Invocation_Graph_Attributes;
-
- begin
- G.Edge_Attributes := IGE_Tables.Create (Initial_Edges);
- G.Graph :=
- DG.Create
- (Initial_Vertices => Initial_Vertices,
- Initial_Edges => Initial_Edges);
- G.Relations := Relation_Sets.Create (Initial_Edges);
- G.Roots := IGV_Sets.Create (Initial_Vertices);
- G.Signature_To_Vertex := Signature_Tables.Create (Initial_Vertices);
- G.Vertex_Attributes := IGV_Tables.Create (Initial_Vertices);
-
- return G;
- end Create;
-
- -------------
- -- Destroy --
- -------------
-
- procedure Destroy (G : in out Invocation_Graph) is
- begin
- pragma Assert (Present (G));
-
- IGE_Tables.Destroy (G.Edge_Attributes);
- DG.Destroy (G.Graph);
- Relation_Sets.Destroy (G.Relations);
- IGV_Sets.Destroy (G.Roots);
- Signature_Tables.Destroy (G.Signature_To_Vertex);
- IGV_Tables.Destroy (G.Vertex_Attributes);
-
- Free (G);
- end Destroy;
-
- -----------------------------------
- -- Destroy_Invocation_Graph_Edge --
- -----------------------------------
-
- procedure Destroy_Invocation_Graph_Edge
- (Edge : in out Invocation_Graph_Edge_Id)
- is
- pragma Unreferenced (Edge);
- begin
- null;
- end Destroy_Invocation_Graph_Edge;
-
- ----------------------------------------------
- -- Destroy_Invocation_Graph_Edge_Attributes --
- ----------------------------------------------
-
- procedure Destroy_Invocation_Graph_Edge_Attributes
- (Attrs : in out Invocation_Graph_Edge_Attributes)
- is
- pragma Unreferenced (Attrs);
- begin
- null;
- end Destroy_Invocation_Graph_Edge_Attributes;
-
- -------------------------------------
- -- Destroy_Invocation_Graph_Vertex --
- -------------------------------------
-
- procedure Destroy_Invocation_Graph_Vertex
- (Vertex : in out Invocation_Graph_Vertex_Id)
- is
- pragma Unreferenced (Vertex);
- begin
- null;
- end Destroy_Invocation_Graph_Vertex;
-
- ------------------------------------------------
- -- Destroy_Invocation_Graph_Vertex_Attributes --
- ------------------------------------------------
-
- procedure Destroy_Invocation_Graph_Vertex_Attributes
- (Attrs : in out Invocation_Graph_Vertex_Attributes)
- is
- pragma Unreferenced (Attrs);
- begin
- null;
- end Destroy_Invocation_Graph_Vertex_Attributes;
-
- -----------
- -- Extra --
- -----------
-
- function Extra
- (G : Invocation_Graph;
- Edge : Invocation_Graph_Edge_Id) return Name_Id
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Edge));
-
- return Extra (Relation (G, Edge));
- end Extra;
-
- ------------------------
- -- Get_IGE_Attributes --
- ------------------------
-
- function Get_IGE_Attributes
- (G : Invocation_Graph;
- Edge : Invocation_Graph_Edge_Id)
- return Invocation_Graph_Edge_Attributes
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Edge));
-
- return IGE_Tables.Get (G.Edge_Attributes, Edge);
- end Get_IGE_Attributes;
-
- ------------------------
- -- Get_IGV_Attributes --
- ------------------------
-
- function Get_IGV_Attributes
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id)
- return Invocation_Graph_Vertex_Attributes
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Vertex));
-
- return IGV_Tables.Get (G.Vertex_Attributes, Vertex);
- end Get_IGV_Attributes;
-
- --------------
- -- Has_Next --
- --------------
-
- function Has_Next (Iter : All_Edge_Iterator) return Boolean is
- begin
- return DG.Has_Next (DG.All_Edge_Iterator (Iter));
- end Has_Next;
-
- --------------
- -- Has_Next --
- --------------
-
- function Has_Next (Iter : All_Vertex_Iterator) return Boolean is
- begin
- return DG.Has_Next (DG.All_Vertex_Iterator (Iter));
- end Has_Next;
-
- --------------
- -- Has_Next --
- --------------
-
- function Has_Next (Iter : Edges_To_Targets_Iterator) return Boolean is
- begin
- return DG.Has_Next (DG.Outgoing_Edge_Iterator (Iter));
- end Has_Next;
-
- --------------
- -- Has_Next --
- --------------
-
- function Has_Next (Iter : Elaboration_Root_Iterator) return Boolean is
- begin
- return IGV_Sets.Has_Next (IGV_Sets.Iterator (Iter));
- end Has_Next;
-
- -------------------------------
- -- Hash_Invocation_Signature --
- -------------------------------
-
- function Hash_Invocation_Signature
- (IS_Id : Invocation_Signature_Id) return Bucket_Range_Type
- is
- begin
- pragma Assert (Present (IS_Id));
-
- return Bucket_Range_Type (IS_Id);
- end Hash_Invocation_Signature;
-
- ---------------------------------
- -- Hash_Source_Target_Relation --
- ---------------------------------
-
- function Hash_Source_Target_Relation
- (Rel : Source_Target_Relation) return Bucket_Range_Type
- is
- begin
- pragma Assert (Present (Rel.Source));
- pragma Assert (Present (Rel.Target));
-
- return
- Hash_Two_Keys
- (Bucket_Range_Type (Rel.Source),
- Bucket_Range_Type (Rel.Target));
- end Hash_Source_Target_Relation;
-
- -------------------------------------------
- -- Increment_Invocation_Graph_Edge_Count --
- -------------------------------------------
-
- procedure Increment_Invocation_Graph_Edge_Count
- (G : Invocation_Graph;
- Kind : Invocation_Kind)
- is
- pragma Assert (Present (G));
-
- Count : Natural renames G.Counts (Kind);
-
- begin
- Count := Count + 1;
- end Increment_Invocation_Graph_Edge_Count;
-
- ---------------------------------
- -- Invocation_Graph_Edge_Count --
- ---------------------------------
-
- function Invocation_Graph_Edge_Count
- (G : Invocation_Graph;
- Kind : Invocation_Kind) return Natural
- is
- begin
- pragma Assert (Present (G));
-
- return G.Counts (Kind);
- end Invocation_Graph_Edge_Count;
-
- -------------------------
- -- Is_Elaboration_Root --
- -------------------------
-
- function Is_Elaboration_Root
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Boolean
- is
- pragma Assert (Present (G));
- pragma Assert (Present (Vertex));
-
- Vertex_Kind : constant Invocation_Construct_Kind :=
- Kind (Construct (G, Vertex));
-
- begin
- return
- Vertex_Kind = Elaborate_Body_Procedure
- or else
- Vertex_Kind = Elaborate_Spec_Procedure;
- end Is_Elaboration_Root;
-
- ----------------------------------------
- -- Is_Existing_Source_Target_Relation --
- ----------------------------------------
-
- function Is_Existing_Source_Target_Relation
- (G : Invocation_Graph;
- Rel : Source_Target_Relation) return Boolean
- is
- begin
- pragma Assert (Present (G));
-
- return Relation_Sets.Contains (G.Relations, Rel);
- end Is_Existing_Source_Target_Relation;
-
- -----------------------
- -- Iterate_All_Edges --
- -----------------------
-
- function Iterate_All_Edges
- (G : Invocation_Graph) return All_Edge_Iterator
- is
- begin
- pragma Assert (Present (G));
-
- return All_Edge_Iterator (DG.Iterate_All_Edges (G.Graph));
- end Iterate_All_Edges;
-
- --------------------------
- -- Iterate_All_Vertices --
- --------------------------
-
- function Iterate_All_Vertices
- (G : Invocation_Graph) return All_Vertex_Iterator
- is
- begin
- pragma Assert (Present (G));
-
- return All_Vertex_Iterator (DG.Iterate_All_Vertices (G.Graph));
- end Iterate_All_Vertices;
-
- ------------------------------
- -- Iterate_Edges_To_Targets --
- ------------------------------
-
- function Iterate_Edges_To_Targets
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Edges_To_Targets_Iterator
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Vertex));
-
- return
- Edges_To_Targets_Iterator
- (DG.Iterate_Outgoing_Edges (G.Graph, Vertex));
- end Iterate_Edges_To_Targets;
-
- -------------------------------
- -- Iterate_Elaboration_Roots --
- -------------------------------
-
- function Iterate_Elaboration_Roots
- (G : Invocation_Graph) return Elaboration_Root_Iterator
- is
- begin
- pragma Assert (Present (G));
-
- return Elaboration_Root_Iterator (IGV_Sets.Iterate (G.Roots));
- end Iterate_Elaboration_Roots;
-
- ----------
- -- Kind --
- ----------
-
- function Kind
- (G : Invocation_Graph;
- Edge : Invocation_Graph_Edge_Id) return Invocation_Kind
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Edge));
-
- return Kind (Relation (G, Edge));
- end Kind;
-
- ----------
- -- Line --
- ----------
-
- function Line
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Nat
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Vertex));
-
- return Line (Signature (Construct (G, Vertex)));
- end Line;
-
- ----------
- -- Name --
- ----------
-
- function Name
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Name_Id
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Vertex));
-
- return Name (Signature (Construct (G, Vertex)));
- end Name;
-
- ----------
- -- Next --
- ----------
-
- procedure Next
- (Iter : in out All_Edge_Iterator;
- Edge : out Invocation_Graph_Edge_Id)
- is
- begin
- DG.Next (DG.All_Edge_Iterator (Iter), Edge);
- end Next;
-
- ----------
- -- Next --
- ----------
-
- procedure Next
- (Iter : in out All_Vertex_Iterator;
- Vertex : out Invocation_Graph_Vertex_Id)
- is
- begin
- DG.Next (DG.All_Vertex_Iterator (Iter), Vertex);
- end Next;
-
- ----------
- -- Next --
- ----------
-
- procedure Next
- (Iter : in out Edges_To_Targets_Iterator;
- Edge : out Invocation_Graph_Edge_Id)
- is
- begin
- DG.Next (DG.Outgoing_Edge_Iterator (Iter), Edge);
- end Next;
-
- ----------
- -- Next --
- ----------
-
- procedure Next
- (Iter : in out Elaboration_Root_Iterator;
- Root : out Invocation_Graph_Vertex_Id)
- is
- begin
- IGV_Sets.Next (IGV_Sets.Iterator (Iter), Root);
- end Next;
-
- ---------------------
- -- Number_Of_Edges --
- ---------------------
-
- function Number_Of_Edges (G : Invocation_Graph) return Natural is
- begin
- pragma Assert (Present (G));
-
- return DG.Number_Of_Edges (G.Graph);
- end Number_Of_Edges;
-
- --------------------------------
- -- Number_Of_Edges_To_Targets --
- --------------------------------
-
- function Number_Of_Edges_To_Targets
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Natural
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Vertex));
-
- return DG.Number_Of_Outgoing_Edges (G.Graph, Vertex);
- end Number_Of_Edges_To_Targets;
-
- ---------------------------------
- -- Number_Of_Elaboration_Roots --
- ---------------------------------
-
- function Number_Of_Elaboration_Roots
- (G : Invocation_Graph) return Natural
- is
- begin
- pragma Assert (Present (G));
-
- return IGV_Sets.Size (G.Roots);
- end Number_Of_Elaboration_Roots;
-
- ------------------------
- -- Number_Of_Vertices --
- ------------------------
-
- function Number_Of_Vertices (G : Invocation_Graph) return Natural is
- begin
- pragma Assert (Present (G));
-
- return DG.Number_Of_Vertices (G.Graph);
- end Number_Of_Vertices;
-
- -------------
- -- Present --
- -------------
-
- function Present (G : Invocation_Graph) return Boolean is
- begin
- return G /= Nil;
- end Present;
-
- --------------
- -- Relation --
- --------------
-
- function Relation
- (G : Invocation_Graph;
- Edge : Invocation_Graph_Edge_Id) return Invocation_Relation_Id
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Edge));
-
- return Get_IGE_Attributes (G, Edge).Relation;
- end Relation;
-
- ---------------------------
- -- Save_Elaboration_Root --
- ---------------------------
-
- procedure Save_Elaboration_Root
- (G : Invocation_Graph;
- Root : Invocation_Graph_Vertex_Id)
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Root));
-
- IGV_Sets.Insert (G.Roots, Root);
- end Save_Elaboration_Root;
-
- ------------------------------
- -- Set_Corresponding_Vertex --
- ------------------------------
-
- procedure Set_Corresponding_Vertex
- (G : Invocation_Graph;
- IS_Id : Invocation_Signature_Id;
- Vertex : Invocation_Graph_Vertex_Id)
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (IS_Id));
- pragma Assert (Present (Vertex));
-
- Signature_Tables.Put (G.Signature_To_Vertex, IS_Id, Vertex);
- end Set_Corresponding_Vertex;
-
- --------------------------------------------
- -- Set_Is_Existing_Source_Target_Relation --
- --------------------------------------------
-
- procedure Set_Is_Existing_Source_Target_Relation
- (G : Invocation_Graph;
- Rel : Source_Target_Relation;
- Val : Boolean := True)
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Rel.Source));
- pragma Assert (Present (Rel.Target));
-
- if Val then
- Relation_Sets.Insert (G.Relations, Rel);
- else
- Relation_Sets.Delete (G.Relations, Rel);
- end if;
- end Set_Is_Existing_Source_Target_Relation;
-
- ------------------------
- -- Set_IGE_Attributes --
- ------------------------
-
- procedure Set_IGE_Attributes
- (G : Invocation_Graph;
- Edge : Invocation_Graph_Edge_Id;
- Val : Invocation_Graph_Edge_Attributes)
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Edge));
-
- IGE_Tables.Put (G.Edge_Attributes, Edge, Val);
- end Set_IGE_Attributes;
-
- ------------------------
- -- Set_IGV_Attributes --
- ------------------------
-
- procedure Set_IGV_Attributes
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id;
- Val : Invocation_Graph_Vertex_Attributes)
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Vertex));
-
- IGV_Tables.Put (G.Vertex_Attributes, Vertex, Val);
- end Set_IGV_Attributes;
-
- -----------------
- -- Spec_Vertex --
- -----------------
-
- function Spec_Vertex
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Vertex));
-
- return Get_IGV_Attributes (G, Vertex).Spec_Vertex;
- end Spec_Vertex;
-
- ------------
- -- Target --
- ------------
-
- function Target
- (G : Invocation_Graph;
- Edge : Invocation_Graph_Edge_Id) return Invocation_Graph_Vertex_Id
- is
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Edge));
-
- return DG.Destination_Vertex (G.Graph, Edge);
- end Target;
- end Invocation_Graphs;
-
--------------------
-- Library_Graphs --
--------------------
@@ -1060,18 +199,30 @@ package body Bindo.Graphs is
-- corresponding specs or bodies, where the body is a predecessor
-- and the spec is a successor. Add all edges to list Edges.
- function Add_Edge_With_Return
+ procedure Add_Edge_Kind_Check
+ (G : Library_Graph;
+ Pred : Library_Graph_Vertex_Id;
+ Succ : Library_Graph_Vertex_Id;
+ New_Kind : Library_Graph_Edge_Kind);
+ -- This is called by Add_Edge in the case where there is already a
+ -- Pred-->Succ edge, to assert that the New_Kind is appropriate. Raises
+ -- Program_Error if a bug is detected. The purpose is to prevent bugs
+ -- where calling Add_Edge in different orders produces different output.
+
+ function Add_Edge
(G : Library_Graph;
Pred : Library_Graph_Vertex_Id;
Succ : Library_Graph_Vertex_Id;
Kind : Library_Graph_Edge_Kind;
Activates_Task : Boolean) return Library_Graph_Edge_Id;
- pragma Inline (Add_Edge_With_Return);
+ pragma Inline (Add_Edge);
-- Create a new edge in library graph G with source vertex Pred and
-- destination vertex Succ, and return its handle. Kind denotes the
-- nature of the edge. Activates_Task should be set when the edge
-- involves a task activation. If Pred and Succ are already related,
- -- no edge is created and No_Library_Graph_Edge is returned.
+ -- no edge is created and No_Library_Graph_Edge is returned, but if
+ -- Activates_Task is True, then the flag of the existing edge is
+ -- updated.
function At_Least_One_Edge_Satisfies
(G : Library_Graph;
@@ -1277,6 +428,12 @@ package body Bindo.Graphs is
-- * Cycle_Limit is the upper bound of the number of cycles to be
-- discovered.
+ function Find_Edge
+ (G : Library_Graph;
+ Pred : Library_Graph_Vertex_Id;
+ Succ : Library_Graph_Vertex_Id) return Library_Graph_Edge_Id;
+ -- There must be an edge Pred-->Succ; this returns it
+
function Find_First_Lower_Precedence_Cycle
(G : Library_Graph;
Cycle : Library_Graph_Cycle_Id) return Library_Graph_Cycle_Id;
@@ -1502,6 +659,11 @@ package body Bindo.Graphs is
-- is the number of invocation edges along the cycle path. Indent is
-- the desired indentation level for tracing.
+ procedure Set_Activates_Task
+ (G : Library_Graph;
+ Edge : Library_Graph_Edge_Id);
+ -- Set the Activates_Task flag of the Edge to True
+
procedure Set_Component_Attributes
(G : Library_Graph;
Comp : Component_Id;
@@ -1518,11 +680,10 @@ package body Bindo.Graphs is
procedure Set_Is_Recorded_Edge
(G : Library_Graph;
- Rel : Predecessor_Successor_Relation;
- Val : Boolean := True);
+ Rel : Predecessor_Successor_Relation);
pragma Inline (Set_Is_Recorded_Edge);
-- Mark a predecessor vertex and a successor vertex described by
- -- relation Rel as already linked depending on value Val.
+ -- relation Rel as already linked.
procedure Set_LGC_Attributes
(G : Library_Graph;
@@ -1635,12 +796,7 @@ package body Bindo.Graphs is
Edge : Library_Graph_Edge_Id) return Boolean
is
begin
- pragma Assert (Present (G));
- pragma Assert (Present (Edge));
-
- return
- Kind (G, Edge) = Invocation_Edge
- and then Get_LGE_Attributes (G, Edge).Activates_Task;
+ return Get_LGE_Attributes (G, Edge).Activates_Task;
end Activates_Task;
-------------------------------
@@ -1674,7 +830,7 @@ package body Bindo.Graphs is
-- the body may be visited first, yet Corresponding_Item will still
-- attempt to create the Body_Before_Spec edge. This is OK because
-- successor and predecessor are kept consistent in both cases, and
- -- Add_Edge_With_Return will prevent the creation of the second edge.
+ -- Add_Edge will prevent the creation of the second edge.
-- Assume that no Body_Before_Spec is necessary
@@ -1684,7 +840,7 @@ package body Bindo.Graphs is
if Is_Body_With_Spec (G, Vertex) then
Edge :=
- Add_Edge_With_Return
+ Add_Edge
(G => G,
Pred => Vertex,
Succ => Corresponding_Item (G, Vertex),
@@ -1695,7 +851,7 @@ package body Bindo.Graphs is
elsif Is_Spec_With_Body (G, Vertex) then
Edge :=
- Add_Edge_With_Return
+ Add_Edge
(G => G,
Pred => Corresponding_Item (G, Vertex),
Succ => Vertex,
@@ -1745,30 +901,72 @@ package body Bindo.Graphs is
Kind : Library_Graph_Edge_Kind;
Activates_Task : Boolean)
is
- Edge : Library_Graph_Edge_Id;
- pragma Unreferenced (Edge);
-
- begin
- pragma Assert (Present (G));
- pragma Assert (Present (Pred));
- pragma Assert (Present (Succ));
- pragma Assert (Kind /= No_Edge);
- pragma Assert (not Activates_Task or else Kind = Invocation_Edge);
-
- Edge :=
- Add_Edge_With_Return
+ Ignore : constant Library_Graph_Edge_Id :=
+ Add_Edge
(G => G,
Pred => Pred,
Succ => Succ,
Kind => Kind,
Activates_Task => Activates_Task);
+ begin
+ null;
end Add_Edge;
- --------------------------
- -- Add_Edge_With_Return --
- --------------------------
+ -------------------------
+ -- Add_Edge_Kind_Check --
+ -------------------------
- function Add_Edge_With_Return
+ procedure Add_Edge_Kind_Check
+ (G : Library_Graph;
+ Pred : Library_Graph_Vertex_Id;
+ Succ : Library_Graph_Vertex_Id;
+ New_Kind : Library_Graph_Edge_Kind)
+ is
+ Old_Edge : constant Library_Graph_Edge_Id :=
+ Find_Edge (G, Pred, Succ);
+ Old_Kind : constant Library_Graph_Edge_Kind :=
+ Get_LGE_Attributes (G, Old_Edge).Kind;
+ OK : Boolean;
+ begin
+ case New_Kind is
+ when Spec_Before_Body_Edge =>
+ OK := False;
+ -- Spec_Before_Body_Edge comes first, and there is never more
+ -- than one Spec_Before_Body_Edge for a given unit, so we can't
+ -- have a preexisting edge in the Spec_Before_Body_Edge case.
+
+ when With_Edge | Elaborate_Edge | Elaborate_All_Edge
+ | Forced_Edge | Invocation_Edge =>
+ OK := Old_Kind <= New_Kind;
+ -- These edges are created in the order of the enumeration
+ -- type, and there can be duplicates; hence "<=".
+
+ when Body_Before_Spec_Edge =>
+ OK := Old_Kind = Body_Before_Spec_Edge
+ -- We call Add_Edge with Body_Before_Spec_Edge twice -- once
+ -- for the spec and once for the body.
+
+ or else Old_Kind = Forced_Edge
+ or else Old_Kind = Invocation_Edge;
+ -- The old one can be Forced_Edge or Invocation_Edge, which
+ -- necessarily results in an elaboration cycle (in the static
+ -- model), but this assertion happens before cycle detection,
+ -- so we need to allow these cases.
+
+ when No_Edge =>
+ OK := False;
+ end case;
+
+ if not OK then
+ raise Program_Error with Old_Kind'Img & "-->" & New_Kind'Img;
+ end if;
+ end Add_Edge_Kind_Check;
+
+ --------------
+ -- Add_Edge --
+ --------------
+
+ function Add_Edge
(G : Library_Graph;
Pred : Library_Graph_Vertex_Id;
Succ : Library_Graph_Vertex_Id;
@@ -1778,19 +976,29 @@ package body Bindo.Graphs is
pragma Assert (Present (G));
pragma Assert (Present (Pred));
pragma Assert (Present (Succ));
- pragma Assert (Kind /= No_Edge);
+ pragma Assert (Kind = Invocation_Edge or else not Activates_Task);
+ -- Only invocation edges can activate tasks
Rel : constant Predecessor_Successor_Relation :=
- (Predecessor => Pred,
- Successor => Succ);
+ (Predecessor => Pred, Successor => Succ);
Edge : Library_Graph_Edge_Id;
begin
- -- Nothing to do when the predecessor and successor are already
- -- related by an edge.
+ -- If we already have a Pred-->Succ edge, we don't add another
+ -- one. But we need to update Activates_Task, in order to avoid
+ -- depending on the order of processing of edges. If we have
+ -- Pred-->Succ with Activates_Task=True, and another Pred-->Succ with
+ -- Activates_Task=False, we want Activates_Task to be True no matter
+ -- which order we processed those two Add_Edge calls.
if Is_Recorded_Edge (G, Rel) then
+ pragma Debug (Add_Edge_Kind_Check (G, Pred, Succ, Kind));
+
+ if Activates_Task then
+ Set_Activates_Task (G, Find_Edge (G, Pred, Succ));
+ end if;
+
return No_Library_Graph_Edge;
end if;
@@ -1834,7 +1042,7 @@ package body Bindo.Graphs is
Increment_Library_Graph_Edge_Count (G, Kind);
return Edge;
- end Add_Edge_With_Return;
+ end Add_Edge;
----------------
-- Add_Vertex --
@@ -3141,6 +2349,44 @@ package body Bindo.Graphs is
LGV_Lists.Destroy (Visited_Stack);
end Find_Cycles_In_Component;
+ ---------------
+ -- Find_Edge --
+ ---------------
+
+ function Find_Edge
+ (G : Library_Graph;
+ Pred : Library_Graph_Vertex_Id;
+ Succ : Library_Graph_Vertex_Id) return Library_Graph_Edge_Id
+ is
+ Result : Library_Graph_Edge_Id := No_Library_Graph_Edge;
+ Edge : Library_Graph_Edge_Id;
+ Iter : Edges_To_Successors_Iterator :=
+ Iterate_Edges_To_Successors (G, Pred);
+
+ begin
+ -- IMPORTANT:
+ --
+ -- * The iteration must run to completion in order to unlock the
+ -- edges to successors.
+
+ -- This does a linear search through the successors of Pred.
+ -- Efficiency is not a problem, because this is called only when
+ -- Activates_Task is True, which is rare, and anyway, there aren't
+ -- usually large numbers of successors.
+
+ while Has_Next (Iter) loop
+ Next (Iter, Edge);
+
+ if Succ = Successor (G, Edge) then
+ pragma Assert (not Present (Result));
+ Result := Edge;
+ end if;
+ end loop;
+
+ pragma Assert (Present (Result));
+ return Result;
+ end Find_Edge;
+
---------------------------------------
-- Find_First_Lower_Precedence_Cycle --
---------------------------------------
@@ -4459,9 +3705,6 @@ package body Bindo.Graphs is
Edge : Library_Graph_Edge_Id) return Library_Graph_Edge_Kind
is
begin
- pragma Assert (Present (G));
- pragma Assert (Present (Edge));
-
return Get_LGE_Attributes (G, Edge).Kind;
end Kind;
@@ -5097,6 +4340,21 @@ package body Bindo.Graphs is
and then LGE_Lists.Equal (Left.Path, Right.Path);
end Same_Library_Graph_Cycle_Attributes;
+ ------------------------
+ -- Set_Activates_Task --
+ ------------------------
+
+ procedure Set_Activates_Task
+ (G : Library_Graph;
+ Edge : Library_Graph_Edge_Id)
+ is
+ Attributes : Library_Graph_Edge_Attributes :=
+ Get_LGE_Attributes (G, Edge);
+ begin
+ Attributes.Activates_Task := True;
+ Set_LGE_Attributes (G, Edge, Attributes);
+ end Set_Activates_Task;
+
------------------------------
-- Set_Component_Attributes --
------------------------------
@@ -5175,19 +4433,14 @@ package body Bindo.Graphs is
procedure Set_Is_Recorded_Edge
(G : Library_Graph;
- Rel : Predecessor_Successor_Relation;
- Val : Boolean := True)
+ Rel : Predecessor_Successor_Relation)
is
begin
pragma Assert (Present (G));
pragma Assert (Present (Rel.Predecessor));
pragma Assert (Present (Rel.Successor));
- if Val then
- RE_Sets.Insert (G.Recorded_Edges, Rel);
- else
- RE_Sets.Delete (G.Recorded_Edges, Rel);
- end if;
+ RE_Sets.Insert (G.Recorded_Edges, Rel);
end Set_Is_Recorded_Edge;
------------------------
@@ -5211,9 +4464,9 @@ package body Bindo.Graphs is
------------------------
procedure Set_LGE_Attributes
- (G : Library_Graph;
+ (G : Library_Graph;
Edge : Library_Graph_Edge_Id;
- Val : Library_Graph_Edge_Attributes)
+ Val : Library_Graph_Edge_Attributes)
is
begin
pragma Assert (Present (G));
@@ -5586,6 +4839,881 @@ package body Bindo.Graphs is
end Visit;
end Library_Graphs;
+ -----------------------
+ -- Invocation_Graphs --
+ -----------------------
+
+ package body Invocation_Graphs is
+
+ -----------------------
+ -- Local subprograms --
+ -----------------------
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation
+ (Invocation_Graph_Attributes, Invocation_Graph);
+
+ function Get_IGE_Attributes
+ (G : Invocation_Graph;
+ Edge : Invocation_Graph_Edge_Id)
+ return Invocation_Graph_Edge_Attributes;
+ pragma Inline (Get_IGE_Attributes);
+ -- Obtain the attributes of edge Edge of invocation graph G
+
+ function Get_IGV_Attributes
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id)
+ return Invocation_Graph_Vertex_Attributes;
+ pragma Inline (Get_IGV_Attributes);
+ -- Obtain the attributes of vertex Vertex of invocation graph G
+
+ procedure Increment_Invocation_Graph_Edge_Count
+ (G : Invocation_Graph;
+ Kind : Invocation_Kind);
+ pragma Inline (Increment_Invocation_Graph_Edge_Count);
+ -- Increment the number of edges of king Kind in invocation graph G by
+ -- one.
+
+ function Is_Elaboration_Root
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Boolean;
+ pragma Inline (Is_Elaboration_Root);
+ -- Determine whether vertex Vertex of invocation graph denotes the
+ -- elaboration procedure of a spec or a body.
+
+ function Is_Existing_Source_Target_Relation
+ (G : Invocation_Graph;
+ Rel : Source_Target_Relation) return Boolean;
+ pragma Inline (Is_Existing_Source_Target_Relation);
+ -- Determine whether a source vertex and a target vertex described by
+ -- relation Rel are already related in invocation graph G.
+
+ procedure Save_Elaboration_Root
+ (G : Invocation_Graph;
+ Root : Invocation_Graph_Vertex_Id);
+ pragma Inline (Save_Elaboration_Root);
+ -- Save elaboration root Root of invocation graph G
+
+ procedure Set_Corresponding_Vertex
+ (G : Invocation_Graph;
+ IS_Id : Invocation_Signature_Id;
+ Vertex : Invocation_Graph_Vertex_Id);
+ pragma Inline (Set_Corresponding_Vertex);
+ -- Associate vertex Vertex of invocation graph G with signature IS_Id
+
+ procedure Set_Is_Existing_Source_Target_Relation
+ (G : Invocation_Graph;
+ Rel : Source_Target_Relation;
+ Val : Boolean := True);
+ pragma Inline (Set_Is_Existing_Source_Target_Relation);
+ -- Mark a source vertex and a target vertex described by relation Rel as
+ -- already related in invocation graph G depending on value Val.
+
+ procedure Set_IGE_Attributes
+ (G : Invocation_Graph;
+ Edge : Invocation_Graph_Edge_Id;
+ Val : Invocation_Graph_Edge_Attributes);
+ pragma Inline (Set_IGE_Attributes);
+ -- Set the attributes of edge Edge of invocation graph G to value Val
+
+ procedure Set_IGV_Attributes
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id;
+ Val : Invocation_Graph_Vertex_Attributes);
+ pragma Inline (Set_IGV_Attributes);
+ -- Set the attributes of vertex Vertex of invocation graph G to value
+ -- Val.
+
+ --------------
+ -- Add_Edge --
+ --------------
+
+ procedure Add_Edge
+ (G : Invocation_Graph;
+ Source : Invocation_Graph_Vertex_Id;
+ Target : Invocation_Graph_Vertex_Id;
+ IR_Id : Invocation_Relation_Id)
+ is
+ pragma Assert (Present (G));
+ pragma Assert (Present (Source));
+ pragma Assert (Present (Target));
+ pragma Assert (Present (IR_Id));
+
+ Rel : constant Source_Target_Relation :=
+ (Source => Source,
+ Target => Target);
+
+ Edge : Invocation_Graph_Edge_Id;
+
+ begin
+ -- Nothing to do when the source and target are already related by an
+ -- edge.
+
+ if Is_Existing_Source_Target_Relation (G, Rel) then
+ return;
+ end if;
+
+ Edge := Sequence_Next_Edge;
+
+ -- Add the edge to the underlying graph
+
+ DG.Add_Edge
+ (G => G.Graph,
+ E => Edge,
+ Source => Source,
+ Destination => Target);
+
+ -- Build and save the attributes of the edge
+
+ Set_IGE_Attributes
+ (G => G,
+ Edge => Edge,
+ Val => (Relation => IR_Id));
+
+ -- Mark the source and target as related by the new edge. This
+ -- prevents all further attempts to link the same source and target.
+
+ Set_Is_Existing_Source_Target_Relation (G, Rel);
+
+ -- Update the edge statistics
+
+ Increment_Invocation_Graph_Edge_Count (G, Kind (IR_Id));
+ end Add_Edge;
+
+ ----------------
+ -- Add_Vertex --
+ ----------------
+
+ procedure Add_Vertex
+ (G : Invocation_Graph;
+ IC_Id : Invocation_Construct_Id;
+ Body_Vertex : Library_Graph_Vertex_Id;
+ Spec_Vertex : Library_Graph_Vertex_Id)
+ is
+ pragma Assert (Present (G));
+ pragma Assert (Present (IC_Id));
+ pragma Assert (Present (Body_Vertex));
+ pragma Assert (Present (Spec_Vertex));
+
+ Construct_Signature : constant Invocation_Signature_Id :=
+ Signature (IC_Id);
+ Vertex : Invocation_Graph_Vertex_Id;
+
+ begin
+ -- Nothing to do when the construct already has a vertex
+
+ if Present (Corresponding_Vertex (G, Construct_Signature)) then
+ return;
+ end if;
+
+ Vertex := Sequence_Next_Vertex;
+
+ -- Add the vertex to the underlying graph
+
+ DG.Add_Vertex (G.Graph, Vertex);
+
+ -- Build and save the attributes of the vertex
+
+ Set_IGV_Attributes
+ (G => G,
+ Vertex => Vertex,
+ Val => (Body_Vertex => Body_Vertex,
+ Construct => IC_Id,
+ Spec_Vertex => Spec_Vertex));
+
+ -- Associate the construct with its corresponding vertex
+
+ Set_Corresponding_Vertex (G, Construct_Signature, Vertex);
+
+ -- Save the vertex for later processing when it denotes a spec or
+ -- body elaboration procedure.
+
+ if Is_Elaboration_Root (G, Vertex) then
+ Save_Elaboration_Root (G, Vertex);
+ end if;
+ end Add_Vertex;
+
+ -----------------
+ -- Body_Vertex --
+ -----------------
+
+ function Body_Vertex
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Vertex));
+
+ return Get_IGV_Attributes (G, Vertex).Body_Vertex;
+ end Body_Vertex;
+
+ ------------
+ -- Column --
+ ------------
+
+ function Column
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Nat
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Vertex));
+
+ return Column (Signature (Construct (G, Vertex)));
+ end Column;
+
+ ---------------
+ -- Construct --
+ ---------------
+
+ function Construct
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Invocation_Construct_Id
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Vertex));
+
+ return Get_IGV_Attributes (G, Vertex).Construct;
+ end Construct;
+
+ --------------------------
+ -- Corresponding_Vertex --
+ --------------------------
+
+ function Corresponding_Vertex
+ (G : Invocation_Graph;
+ IS_Id : Invocation_Signature_Id) return Invocation_Graph_Vertex_Id
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (IS_Id));
+
+ return Signature_Tables.Get (G.Signature_To_Vertex, IS_Id);
+ end Corresponding_Vertex;
+
+ ------------
+ -- Create --
+ ------------
+
+ function Create
+ (Initial_Vertices : Positive;
+ Initial_Edges : Positive;
+ Lib_Graph : Library_Graphs.Library_Graph)
+ return Invocation_Graph
+ is
+ G : constant Invocation_Graph := new Invocation_Graph_Attributes'
+ (Counts => <>,
+ Edge_Attributes => IGE_Tables.Create (Initial_Edges),
+ Graph =>
+ DG.Create
+ (Initial_Vertices => Initial_Vertices,
+ Initial_Edges => Initial_Edges),
+ Relations => Relation_Sets.Create (Initial_Edges),
+ Roots => IGV_Sets.Create (Initial_Vertices),
+ Signature_To_Vertex => Signature_Tables.Create (Initial_Vertices),
+ Vertex_Attributes => IGV_Tables.Create (Initial_Vertices),
+ Lib_Graph => Lib_Graph);
+ begin
+ return G;
+ end Create;
+
+ -------------
+ -- Destroy --
+ -------------
+
+ procedure Destroy (G : in out Invocation_Graph) is
+ begin
+ pragma Assert (Present (G));
+
+ IGE_Tables.Destroy (G.Edge_Attributes);
+ DG.Destroy (G.Graph);
+ Relation_Sets.Destroy (G.Relations);
+ IGV_Sets.Destroy (G.Roots);
+ Signature_Tables.Destroy (G.Signature_To_Vertex);
+ IGV_Tables.Destroy (G.Vertex_Attributes);
+
+ Free (G);
+ end Destroy;
+
+ -----------------------------------
+ -- Destroy_Invocation_Graph_Edge --
+ -----------------------------------
+
+ procedure Destroy_Invocation_Graph_Edge
+ (Edge : in out Invocation_Graph_Edge_Id)
+ is
+ pragma Unreferenced (Edge);
+ begin
+ null;
+ end Destroy_Invocation_Graph_Edge;
+
+ ----------------------------------------------
+ -- Destroy_Invocation_Graph_Edge_Attributes --
+ ----------------------------------------------
+
+ procedure Destroy_Invocation_Graph_Edge_Attributes
+ (Attrs : in out Invocation_Graph_Edge_Attributes)
+ is
+ pragma Unreferenced (Attrs);
+ begin
+ null;
+ end Destroy_Invocation_Graph_Edge_Attributes;
+
+ -------------------------------------
+ -- Destroy_Invocation_Graph_Vertex --
+ -------------------------------------
+
+ procedure Destroy_Invocation_Graph_Vertex
+ (Vertex : in out Invocation_Graph_Vertex_Id)
+ is
+ pragma Unreferenced (Vertex);
+ begin
+ null;
+ end Destroy_Invocation_Graph_Vertex;
+
+ ------------------------------------------------
+ -- Destroy_Invocation_Graph_Vertex_Attributes --
+ ------------------------------------------------
+
+ procedure Destroy_Invocation_Graph_Vertex_Attributes
+ (Attrs : in out Invocation_Graph_Vertex_Attributes)
+ is
+ pragma Unreferenced (Attrs);
+ begin
+ null;
+ end Destroy_Invocation_Graph_Vertex_Attributes;
+
+ -----------
+ -- Extra --
+ -----------
+
+ function Extra
+ (G : Invocation_Graph;
+ Edge : Invocation_Graph_Edge_Id) return Name_Id
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Edge));
+
+ return Extra (Relation (G, Edge));
+ end Extra;
+
+ ------------------------
+ -- Get_IGE_Attributes --
+ ------------------------
+
+ function Get_IGE_Attributes
+ (G : Invocation_Graph;
+ Edge : Invocation_Graph_Edge_Id)
+ return Invocation_Graph_Edge_Attributes
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Edge));
+
+ return IGE_Tables.Get (G.Edge_Attributes, Edge);
+ end Get_IGE_Attributes;
+
+ ------------------------
+ -- Get_IGV_Attributes --
+ ------------------------
+
+ function Get_IGV_Attributes
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id)
+ return Invocation_Graph_Vertex_Attributes
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Vertex));
+
+ return IGV_Tables.Get (G.Vertex_Attributes, Vertex);
+ end Get_IGV_Attributes;
+
+ --------------
+ -- Has_Next --
+ --------------
+
+ function Has_Next (Iter : All_Edge_Iterator) return Boolean is
+ begin
+ return DG.Has_Next (DG.All_Edge_Iterator (Iter));
+ end Has_Next;
+
+ --------------
+ -- Has_Next --
+ --------------
+
+ function Has_Next (Iter : All_Vertex_Iterator) return Boolean is
+ begin
+ return DG.Has_Next (DG.All_Vertex_Iterator (Iter));
+ end Has_Next;
+
+ --------------
+ -- Has_Next --
+ --------------
+
+ function Has_Next (Iter : Edges_To_Targets_Iterator) return Boolean is
+ begin
+ return DG.Has_Next (DG.Outgoing_Edge_Iterator (Iter));
+ end Has_Next;
+
+ --------------
+ -- Has_Next --
+ --------------
+
+ function Has_Next (Iter : Elaboration_Root_Iterator) return Boolean is
+ begin
+ return IGV_Sets.Has_Next (IGV_Sets.Iterator (Iter));
+ end Has_Next;
+
+ -------------------------------
+ -- Hash_Invocation_Signature --
+ -------------------------------
+
+ function Hash_Invocation_Signature
+ (IS_Id : Invocation_Signature_Id) return Bucket_Range_Type
+ is
+ begin
+ pragma Assert (Present (IS_Id));
+
+ return Bucket_Range_Type (IS_Id);
+ end Hash_Invocation_Signature;
+
+ ---------------------------------
+ -- Hash_Source_Target_Relation --
+ ---------------------------------
+
+ function Hash_Source_Target_Relation
+ (Rel : Source_Target_Relation) return Bucket_Range_Type
+ is
+ begin
+ pragma Assert (Present (Rel.Source));
+ pragma Assert (Present (Rel.Target));
+
+ return
+ Hash_Two_Keys
+ (Bucket_Range_Type (Rel.Source),
+ Bucket_Range_Type (Rel.Target));
+ end Hash_Source_Target_Relation;
+
+ -------------------------------------------
+ -- Increment_Invocation_Graph_Edge_Count --
+ -------------------------------------------
+
+ procedure Increment_Invocation_Graph_Edge_Count
+ (G : Invocation_Graph;
+ Kind : Invocation_Kind)
+ is
+ pragma Assert (Present (G));
+
+ Count : Natural renames G.Counts (Kind);
+
+ begin
+ Count := Count + 1;
+ end Increment_Invocation_Graph_Edge_Count;
+
+ ---------------------------------
+ -- Invocation_Graph_Edge_Count --
+ ---------------------------------
+
+ function Invocation_Graph_Edge_Count
+ (G : Invocation_Graph;
+ Kind : Invocation_Kind) return Natural
+ is
+ begin
+ pragma Assert (Present (G));
+
+ return G.Counts (Kind);
+ end Invocation_Graph_Edge_Count;
+
+ -------------------------
+ -- Is_Elaboration_Root --
+ -------------------------
+
+ function Is_Elaboration_Root
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Boolean
+ is
+ pragma Assert (Present (G));
+ pragma Assert (Present (Vertex));
+
+ Vertex_Kind : constant Invocation_Construct_Kind :=
+ Kind (Construct (G, Vertex));
+
+ begin
+ return
+ Vertex_Kind = Elaborate_Body_Procedure
+ or else
+ Vertex_Kind = Elaborate_Spec_Procedure;
+ end Is_Elaboration_Root;
+
+ ----------------------------------------
+ -- Is_Existing_Source_Target_Relation --
+ ----------------------------------------
+
+ function Is_Existing_Source_Target_Relation
+ (G : Invocation_Graph;
+ Rel : Source_Target_Relation) return Boolean
+ is
+ begin
+ pragma Assert (Present (G));
+
+ return Relation_Sets.Contains (G.Relations, Rel);
+ end Is_Existing_Source_Target_Relation;
+
+ -----------------------
+ -- Iterate_All_Edges --
+ -----------------------
+
+ function Iterate_All_Edges
+ (G : Invocation_Graph) return All_Edge_Iterator
+ is
+ begin
+ pragma Assert (Present (G));
+
+ return All_Edge_Iterator (DG.Iterate_All_Edges (G.Graph));
+ end Iterate_All_Edges;
+
+ --------------------------
+ -- Iterate_All_Vertices --
+ --------------------------
+
+ function Iterate_All_Vertices
+ (G : Invocation_Graph) return All_Vertex_Iterator
+ is
+ begin
+ pragma Assert (Present (G));
+
+ return All_Vertex_Iterator (DG.Iterate_All_Vertices (G.Graph));
+ end Iterate_All_Vertices;
+
+ ------------------------------
+ -- Iterate_Edges_To_Targets --
+ ------------------------------
+
+ function Iterate_Edges_To_Targets
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Edges_To_Targets_Iterator
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Vertex));
+
+ return
+ Edges_To_Targets_Iterator
+ (DG.Iterate_Outgoing_Edges (G.Graph, Vertex));
+ end Iterate_Edges_To_Targets;
+
+ -------------------------------
+ -- Iterate_Elaboration_Roots --
+ -------------------------------
+
+ function Iterate_Elaboration_Roots
+ (G : Invocation_Graph) return Elaboration_Root_Iterator
+ is
+ begin
+ pragma Assert (Present (G));
+
+ return Elaboration_Root_Iterator (IGV_Sets.Iterate (G.Roots));
+ end Iterate_Elaboration_Roots;
+
+ ----------
+ -- Kind --
+ ----------
+
+ function Kind
+ (G : Invocation_Graph;
+ Edge : Invocation_Graph_Edge_Id) return Invocation_Kind
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Edge));
+
+ return Kind (Relation (G, Edge));
+ end Kind;
+
+ -------------------
+ -- Get_Lib_Graph --
+ -------------------
+
+ function Get_Lib_Graph
+ (G : Invocation_Graph) return Library_Graphs.Library_Graph
+ is
+ pragma Assert (Present (G));
+ begin
+ return G.Lib_Graph;
+ end Get_Lib_Graph;
+
+ ----------
+ -- Line --
+ ----------
+
+ function Line
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Nat
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Vertex));
+
+ return Line (Signature (Construct (G, Vertex)));
+ end Line;
+
+ ----------
+ -- Name --
+ ----------
+
+ function Name
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Name_Id
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Vertex));
+
+ return Name (Signature (Construct (G, Vertex)));
+ end Name;
+
+ ----------
+ -- Next --
+ ----------
+
+ procedure Next
+ (Iter : in out All_Edge_Iterator;
+ Edge : out Invocation_Graph_Edge_Id)
+ is
+ begin
+ DG.Next (DG.All_Edge_Iterator (Iter), Edge);
+ end Next;
+
+ ----------
+ -- Next --
+ ----------
+
+ procedure Next
+ (Iter : in out All_Vertex_Iterator;
+ Vertex : out Invocation_Graph_Vertex_Id)
+ is
+ begin
+ DG.Next (DG.All_Vertex_Iterator (Iter), Vertex);
+ end Next;
+
+ ----------
+ -- Next --
+ ----------
+
+ procedure Next
+ (Iter : in out Edges_To_Targets_Iterator;
+ Edge : out Invocation_Graph_Edge_Id)
+ is
+ begin
+ DG.Next (DG.Outgoing_Edge_Iterator (Iter), Edge);
+ end Next;
+
+ ----------
+ -- Next --
+ ----------
+
+ procedure Next
+ (Iter : in out Elaboration_Root_Iterator;
+ Root : out Invocation_Graph_Vertex_Id)
+ is
+ begin
+ IGV_Sets.Next (IGV_Sets.Iterator (Iter), Root);
+ end Next;
+
+ ---------------------
+ -- Number_Of_Edges --
+ ---------------------
+
+ function Number_Of_Edges (G : Invocation_Graph) return Natural is
+ begin
+ pragma Assert (Present (G));
+
+ return DG.Number_Of_Edges (G.Graph);
+ end Number_Of_Edges;
+
+ --------------------------------
+ -- Number_Of_Edges_To_Targets --
+ --------------------------------
+
+ function Number_Of_Edges_To_Targets
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Natural
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Vertex));
+
+ return DG.Number_Of_Outgoing_Edges (G.Graph, Vertex);
+ end Number_Of_Edges_To_Targets;
+
+ ---------------------------------
+ -- Number_Of_Elaboration_Roots --
+ ---------------------------------
+
+ function Number_Of_Elaboration_Roots
+ (G : Invocation_Graph) return Natural
+ is
+ begin
+ pragma Assert (Present (G));
+
+ return IGV_Sets.Size (G.Roots);
+ end Number_Of_Elaboration_Roots;
+
+ ------------------------
+ -- Number_Of_Vertices --
+ ------------------------
+
+ function Number_Of_Vertices (G : Invocation_Graph) return Natural is
+ begin
+ pragma Assert (Present (G));
+
+ return DG.Number_Of_Vertices (G.Graph);
+ end Number_Of_Vertices;
+
+ -------------
+ -- Present --
+ -------------
+
+ function Present (G : Invocation_Graph) return Boolean is
+ begin
+ return G /= Nil;
+ end Present;
+
+ --------------
+ -- Relation --
+ --------------
+
+ function Relation
+ (G : Invocation_Graph;
+ Edge : Invocation_Graph_Edge_Id) return Invocation_Relation_Id
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Edge));
+
+ return Get_IGE_Attributes (G, Edge).Relation;
+ end Relation;
+
+ ---------------------------
+ -- Save_Elaboration_Root --
+ ---------------------------
+
+ procedure Save_Elaboration_Root
+ (G : Invocation_Graph;
+ Root : Invocation_Graph_Vertex_Id)
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Root));
+
+ IGV_Sets.Insert (G.Roots, Root);
+ end Save_Elaboration_Root;
+
+ ------------------------------
+ -- Set_Corresponding_Vertex --
+ ------------------------------
+
+ procedure Set_Corresponding_Vertex
+ (G : Invocation_Graph;
+ IS_Id : Invocation_Signature_Id;
+ Vertex : Invocation_Graph_Vertex_Id)
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (IS_Id));
+ pragma Assert (Present (Vertex));
+
+ Signature_Tables.Put (G.Signature_To_Vertex, IS_Id, Vertex);
+ end Set_Corresponding_Vertex;
+
+ --------------------------------------------
+ -- Set_Is_Existing_Source_Target_Relation --
+ --------------------------------------------
+
+ procedure Set_Is_Existing_Source_Target_Relation
+ (G : Invocation_Graph;
+ Rel : Source_Target_Relation;
+ Val : Boolean := True)
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Rel.Source));
+ pragma Assert (Present (Rel.Target));
+
+ if Val then
+ Relation_Sets.Insert (G.Relations, Rel);
+ else
+ Relation_Sets.Delete (G.Relations, Rel);
+ end if;
+ end Set_Is_Existing_Source_Target_Relation;
+
+ ------------------------
+ -- Set_IGE_Attributes --
+ ------------------------
+
+ procedure Set_IGE_Attributes
+ (G : Invocation_Graph;
+ Edge : Invocation_Graph_Edge_Id;
+ Val : Invocation_Graph_Edge_Attributes)
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Edge));
+
+ IGE_Tables.Put (G.Edge_Attributes, Edge, Val);
+ end Set_IGE_Attributes;
+
+ ------------------------
+ -- Set_IGV_Attributes --
+ ------------------------
+
+ procedure Set_IGV_Attributes
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id;
+ Val : Invocation_Graph_Vertex_Attributes)
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Vertex));
+
+ IGV_Tables.Put (G.Vertex_Attributes, Vertex, Val);
+ end Set_IGV_Attributes;
+
+ -----------------
+ -- Spec_Vertex --
+ -----------------
+
+ function Spec_Vertex
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Vertex));
+
+ return Get_IGV_Attributes (G, Vertex).Spec_Vertex;
+ end Spec_Vertex;
+
+ ------------
+ -- Target --
+ ------------
+
+ function Target
+ (G : Invocation_Graph;
+ Edge : Invocation_Graph_Edge_Id) return Invocation_Graph_Vertex_Id
+ is
+ begin
+ pragma Assert (Present (G));
+ pragma Assert (Present (Edge));
+
+ return DG.Destination_Vertex (G.Graph, Edge);
+ end Target;
+ end Invocation_Graphs;
+
-------------
-- Present --
-------------
diff --git a/gcc/ada/bindo-graphs.ads b/gcc/ada/bindo-graphs.ads
index 339c7f8..e284369 100644
--- a/gcc/ada/bindo-graphs.ads
+++ b/gcc/ada/bindo-graphs.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -198,478 +198,6 @@ package Bindo.Graphs is
"=" => "=",
Hash => Hash_Library_Graph_Vertex);
- -----------------------
- -- Invocation_Graphs --
- -----------------------
-
- package Invocation_Graphs is
-
- -----------
- -- Graph --
- -----------
-
- -- The following type denotes an invocation graph handle. Each instance
- -- must be created using routine Create.
-
- type Invocation_Graph is private;
- Nil : constant Invocation_Graph;
-
- ----------------------
- -- Graph operations --
- ----------------------
-
- procedure Add_Edge
- (G : Invocation_Graph;
- Source : Invocation_Graph_Vertex_Id;
- Target : Invocation_Graph_Vertex_Id;
- IR_Id : Invocation_Relation_Id);
- pragma Inline (Add_Edge);
- -- Create a new edge in invocation graph G with source vertex Source and
- -- destination vertex Target. IR_Id is the invocation relation the edge
- -- describes.
-
- procedure Add_Vertex
- (G : Invocation_Graph;
- IC_Id : Invocation_Construct_Id;
- Body_Vertex : Library_Graph_Vertex_Id;
- Spec_Vertex : Library_Graph_Vertex_Id);
- pragma Inline (Add_Vertex);
- -- Create a new vertex in invocation graph G. IC_Id is the invocation
- -- construct the vertex describes. Body_Vertex denotes the library graph
- -- vertex where the invocation construct's body is declared. Spec_Vertex
- -- is the library graph vertex where the invocation construct's spec is
- -- declared.
-
- function Create
- (Initial_Vertices : Positive;
- Initial_Edges : Positive) return Invocation_Graph;
- pragma Inline (Create);
- -- Create a new empty graph with vertex capacity Initial_Vertices and
- -- edge capacity Initial_Edges.
-
- procedure Destroy (G : in out Invocation_Graph);
- pragma Inline (Destroy);
- -- Destroy the contents of invocation graph G, rendering it unusable
-
- function Present (G : Invocation_Graph) return Boolean;
- pragma Inline (Present);
- -- Determine whether invocation graph G exists
-
- -----------------------
- -- Vertex attributes --
- -----------------------
-
- function Body_Vertex
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id;
- pragma Inline (Body_Vertex);
- -- Obtain the library graph vertex where the body of the invocation
- -- construct represented by vertex Vertex of invocation graph G is
- -- declared.
-
- function Column
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Nat;
- pragma Inline (Column);
- -- Obtain the column number where the invocation construct vertex Vertex
- -- of invocation graph G describes.
-
- function Construct
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Invocation_Construct_Id;
- pragma Inline (Construct);
- -- Obtain the invocation construct vertex Vertex of invocation graph G
- -- describes.
-
- function Corresponding_Vertex
- (G : Invocation_Graph;
- IS_Id : Invocation_Signature_Id) return Invocation_Graph_Vertex_Id;
- pragma Inline (Corresponding_Vertex);
- -- Obtain the vertex of invocation graph G that corresponds to signature
- -- IS_Id.
-
- function Line
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Nat;
- pragma Inline (Line);
- -- Obtain the line number where the invocation construct vertex Vertex
- -- of invocation graph G describes.
-
- function Name
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Name_Id;
- pragma Inline (Name);
- -- Obtain the name of the construct vertex Vertex of invocation graph G
- -- describes.
-
- function Spec_Vertex
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id;
- pragma Inline (Spec_Vertex);
- -- Obtain the library graph vertex where the spec of the invocation
- -- construct represented by vertex Vertex of invocation graph G is
- -- declared.
-
- ---------------------
- -- Edge attributes --
- ---------------------
-
- function Extra
- (G : Invocation_Graph;
- Edge : Invocation_Graph_Edge_Id) return Name_Id;
- pragma Inline (Extra);
- -- Obtain the extra name used in error diagnostics of edge Edge of
- -- invocation graph G.
-
- function Kind
- (G : Invocation_Graph;
- Edge : Invocation_Graph_Edge_Id) return Invocation_Kind;
- pragma Inline (Kind);
- -- Obtain the nature of edge Edge of invocation graph G
-
- function Relation
- (G : Invocation_Graph;
- Edge : Invocation_Graph_Edge_Id) return Invocation_Relation_Id;
- pragma Inline (Relation);
- -- Obtain the relation edge Edge of invocation graph G describes
-
- function Target
- (G : Invocation_Graph;
- Edge : Invocation_Graph_Edge_Id) return Invocation_Graph_Vertex_Id;
- pragma Inline (Target);
- -- Obtain the target vertex edge Edge of invocation graph G designates
-
- ----------------
- -- Statistics --
- ----------------
-
- function Invocation_Graph_Edge_Count
- (G : Invocation_Graph;
- Kind : Invocation_Kind) return Natural;
- pragma Inline (Invocation_Graph_Edge_Count);
- -- Obtain the total number of edges of kind Kind in invocation graph G
-
- function Number_Of_Edges (G : Invocation_Graph) return Natural;
- pragma Inline (Number_Of_Edges);
- -- Obtain the total number of edges in invocation graph G
-
- function Number_Of_Edges_To_Targets
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Natural;
- pragma Inline (Number_Of_Edges_To_Targets);
- -- Obtain the total number of edges to targets vertex Vertex of
- -- invocation graph G has.
-
- function Number_Of_Elaboration_Roots
- (G : Invocation_Graph) return Natural;
- pragma Inline (Number_Of_Elaboration_Roots);
- -- Obtain the total number of elaboration roots in invocation graph G
-
- function Number_Of_Vertices (G : Invocation_Graph) return Natural;
- pragma Inline (Number_Of_Vertices);
- -- Obtain the total number of vertices in invocation graph G
-
- ---------------
- -- Iterators --
- ---------------
-
- -- The following type represents an iterator over all edges of an
- -- invocation graph.
-
- type All_Edge_Iterator is private;
-
- function Has_Next (Iter : All_Edge_Iterator) return Boolean;
- pragma Inline (Has_Next);
- -- Determine whether iterator Iter has more edges to examine
-
- function Iterate_All_Edges
- (G : Invocation_Graph) return All_Edge_Iterator;
- pragma Inline (Iterate_All_Edges);
- -- Obtain an iterator over all edges of invocation graph G
-
- procedure Next
- (Iter : in out All_Edge_Iterator;
- Edge : out Invocation_Graph_Edge_Id);
- pragma Inline (Next);
- -- Return the current edge referenced by iterator Iter and advance to
- -- the next available edge.
-
- -- The following type represents an iterator over all vertices of an
- -- invocation graph.
-
- type All_Vertex_Iterator is private;
-
- function Has_Next (Iter : All_Vertex_Iterator) return Boolean;
- pragma Inline (Has_Next);
- -- Determine whether iterator Iter has more vertices to examine
-
- function Iterate_All_Vertices
- (G : Invocation_Graph) return All_Vertex_Iterator;
- pragma Inline (Iterate_All_Vertices);
- -- Obtain an iterator over all vertices of invocation graph G
-
- procedure Next
- (Iter : in out All_Vertex_Iterator;
- Vertex : out Invocation_Graph_Vertex_Id);
- pragma Inline (Next);
- -- Return the current vertex referenced by iterator Iter and advance
- -- to the next available vertex.
-
- -- The following type represents an iterator over all edges that reach
- -- targets starting from a particular source vertex.
-
- type Edges_To_Targets_Iterator is private;
-
- function Has_Next (Iter : Edges_To_Targets_Iterator) return Boolean;
- pragma Inline (Has_Next);
- -- Determine whether iterator Iter has more edges to examine
-
- function Iterate_Edges_To_Targets
- (G : Invocation_Graph;
- Vertex : Invocation_Graph_Vertex_Id) return Edges_To_Targets_Iterator;
- pragma Inline (Iterate_Edges_To_Targets);
- -- Obtain an iterator over all edges to targets with source vertex
- -- Vertex of invocation graph G.
-
- procedure Next
- (Iter : in out Edges_To_Targets_Iterator;
- Edge : out Invocation_Graph_Edge_Id);
- pragma Inline (Next);
- -- Return the current edge referenced by iterator Iter and advance to
- -- the next available edge.
-
- -- The following type represents an iterator over all vertices of an
- -- invocation graph that denote the elaboration procedure or a spec or
- -- a body, referred to as elaboration root.
-
- type Elaboration_Root_Iterator is private;
-
- function Has_Next (Iter : Elaboration_Root_Iterator) return Boolean;
- pragma Inline (Has_Next);
- -- Determine whether iterator Iter has more elaboration roots to examine
-
- function Iterate_Elaboration_Roots
- (G : Invocation_Graph) return Elaboration_Root_Iterator;
- pragma Inline (Iterate_Elaboration_Roots);
- -- Obtain an iterator over all elaboration roots of invocation graph G
-
- procedure Next
- (Iter : in out Elaboration_Root_Iterator;
- Root : out Invocation_Graph_Vertex_Id);
- pragma Inline (Next);
- -- Return the current elaboration root referenced by iterator Iter and
- -- advance to the next available elaboration root.
-
- private
-
- --------------
- -- Vertices --
- --------------
-
- procedure Destroy_Invocation_Graph_Vertex
- (Vertex : in out Invocation_Graph_Vertex_Id);
- pragma Inline (Destroy_Invocation_Graph_Vertex);
- -- Destroy invocation graph vertex Vertex
-
- -- The following type represents the attributes of an invocation graph
- -- vertex.
-
- type Invocation_Graph_Vertex_Attributes is record
- Body_Vertex : Library_Graph_Vertex_Id := No_Library_Graph_Vertex;
- -- Reference to the library graph vertex where the body of this
- -- vertex resides.
-
- Construct : Invocation_Construct_Id := No_Invocation_Construct;
- -- Reference to the invocation construct this vertex represents
-
- Spec_Vertex : Library_Graph_Vertex_Id := No_Library_Graph_Vertex;
- -- Reference to the library graph vertex where the spec of this
- -- vertex resides.
- end record;
-
- No_Invocation_Graph_Vertex_Attributes :
- constant Invocation_Graph_Vertex_Attributes :=
- (Body_Vertex => No_Library_Graph_Vertex,
- Construct => No_Invocation_Construct,
- Spec_Vertex => No_Library_Graph_Vertex);
-
- procedure Destroy_Invocation_Graph_Vertex_Attributes
- (Attrs : in out Invocation_Graph_Vertex_Attributes);
- pragma Inline (Destroy_Invocation_Graph_Vertex_Attributes);
- -- Destroy the contents of attributes Attrs
-
- package IGV_Tables is new Dynamic_Hash_Tables
- (Key_Type => Invocation_Graph_Vertex_Id,
- Value_Type => Invocation_Graph_Vertex_Attributes,
- No_Value => No_Invocation_Graph_Vertex_Attributes,
- Expansion_Threshold => 1.5,
- Expansion_Factor => 2,
- Compression_Threshold => 0.3,
- Compression_Factor => 2,
- "=" => "=",
- Destroy_Value => Destroy_Invocation_Graph_Vertex_Attributes,
- Hash => Hash_Invocation_Graph_Vertex);
-
- -----------
- -- Edges --
- -----------
-
- procedure Destroy_Invocation_Graph_Edge
- (Edge : in out Invocation_Graph_Edge_Id);
- pragma Inline (Destroy_Invocation_Graph_Edge);
- -- Destroy invocation graph edge Edge
-
- -- The following type represents the attributes of an invocation graph
- -- edge.
-
- type Invocation_Graph_Edge_Attributes is record
- Relation : Invocation_Relation_Id := No_Invocation_Relation;
- -- Reference to the invocation relation this edge represents
- end record;
-
- No_Invocation_Graph_Edge_Attributes :
- constant Invocation_Graph_Edge_Attributes :=
- (Relation => No_Invocation_Relation);
-
- procedure Destroy_Invocation_Graph_Edge_Attributes
- (Attrs : in out Invocation_Graph_Edge_Attributes);
- pragma Inline (Destroy_Invocation_Graph_Edge_Attributes);
- -- Destroy the contents of attributes Attrs
-
- package IGE_Tables is new Dynamic_Hash_Tables
- (Key_Type => Invocation_Graph_Edge_Id,
- Value_Type => Invocation_Graph_Edge_Attributes,
- No_Value => No_Invocation_Graph_Edge_Attributes,
- Expansion_Threshold => 1.5,
- Expansion_Factor => 2,
- Compression_Threshold => 0.3,
- Compression_Factor => 2,
- "=" => "=",
- Destroy_Value => Destroy_Invocation_Graph_Edge_Attributes,
- Hash => Hash_Invocation_Graph_Edge);
-
- ---------------
- -- Relations --
- ---------------
-
- -- The following type represents a relation between a source and target
- -- vertices.
-
- type Source_Target_Relation is record
- Source : Invocation_Graph_Vertex_Id := No_Invocation_Graph_Vertex;
- -- The source vertex
-
- Target : Invocation_Graph_Vertex_Id := No_Invocation_Graph_Vertex;
- -- The destination vertex
- end record;
-
- No_Source_Target_Relation :
- constant Source_Target_Relation :=
- (Source => No_Invocation_Graph_Vertex,
- Target => No_Invocation_Graph_Vertex);
-
- function Hash_Source_Target_Relation
- (Rel : Source_Target_Relation) return Bucket_Range_Type;
- pragma Inline (Hash_Source_Target_Relation);
- -- Obtain the hash value of key Rel
-
- package Relation_Sets is new Membership_Sets
- (Element_Type => Source_Target_Relation,
- "=" => "=",
- Hash => Hash_Source_Target_Relation);
-
- ----------------
- -- Statistics --
- ----------------
-
- type Invocation_Graph_Edge_Counts is array (Invocation_Kind) of Natural;
-
- ----------------
- -- Signatures --
- ----------------
-
- function Hash_Invocation_Signature
- (IS_Id : Invocation_Signature_Id) return Bucket_Range_Type;
- pragma Inline (Hash_Invocation_Signature);
- -- Obtain the hash value of key IS_Id
-
- package Signature_Tables is new Dynamic_Hash_Tables
- (Key_Type => Invocation_Signature_Id,
- Value_Type => Invocation_Graph_Vertex_Id,
- No_Value => No_Invocation_Graph_Vertex,
- Expansion_Threshold => 1.5,
- Expansion_Factor => 2,
- Compression_Threshold => 0.3,
- Compression_Factor => 2,
- "=" => "=",
- Destroy_Value => Destroy_Invocation_Graph_Vertex,
- Hash => Hash_Invocation_Signature);
-
- -----------------------
- -- Elaboration roots --
- -----------------------
-
- package IGV_Sets is new Membership_Sets
- (Element_Type => Invocation_Graph_Vertex_Id,
- "=" => "=",
- Hash => Hash_Invocation_Graph_Vertex);
-
- -----------
- -- Graph --
- -----------
-
- package DG is new Directed_Graphs
- (Vertex_Id => Invocation_Graph_Vertex_Id,
- No_Vertex => No_Invocation_Graph_Vertex,
- Hash_Vertex => Hash_Invocation_Graph_Vertex,
- Same_Vertex => "=",
- Edge_id => Invocation_Graph_Edge_Id,
- No_Edge => No_Invocation_Graph_Edge,
- Hash_Edge => Hash_Invocation_Graph_Edge,
- Same_Edge => "=");
-
- -- The following type represents the attributes of an invocation graph
-
- type Invocation_Graph_Attributes is record
- Counts : Invocation_Graph_Edge_Counts := (others => 0);
- -- Edge statistics
-
- Edge_Attributes : IGE_Tables.Dynamic_Hash_Table := IGE_Tables.Nil;
- -- The map of edge -> edge attributes for all edges in the graph
-
- Graph : DG.Directed_Graph := DG.Nil;
- -- The underlying graph describing the relations between edges and
- -- vertices.
-
- Relations : Relation_Sets.Membership_Set := Relation_Sets.Nil;
- -- The set of relations between source and targets, used to prevent
- -- duplicate edges in the graph.
-
- Roots : IGV_Sets.Membership_Set := IGV_Sets.Nil;
- -- The set of elaboration root vertices
-
- Signature_To_Vertex : Signature_Tables.Dynamic_Hash_Table :=
- Signature_Tables.Nil;
- -- The map of signature -> vertex
-
- Vertex_Attributes : IGV_Tables.Dynamic_Hash_Table := IGV_Tables.Nil;
- -- The map of vertex -> vertex attributes for all vertices in the
- -- graph.
- end record;
-
- type Invocation_Graph is access Invocation_Graph_Attributes;
- Nil : constant Invocation_Graph := null;
-
- ---------------
- -- Iterators --
- ---------------
-
- type All_Edge_Iterator is new DG.All_Edge_Iterator;
- type All_Vertex_Iterator is new DG.All_Vertex_Iterator;
- type Edges_To_Targets_Iterator is new DG.Outgoing_Edge_Iterator;
- type Elaboration_Root_Iterator is new IGV_Sets.Iterator;
- end Invocation_Graphs;
-
--------------------
-- Library_Graphs --
--------------------
@@ -702,13 +230,18 @@ package Bindo.Graphs is
No_Cycle_Kind);
- -- The following type represents the various kinds of library edges
+ -- The following type represents the various kinds of library edges. The
+ -- order is important here, and corresponds to the order in which edges
+ -- are added to the graph. See Add_Edge_Kind_Check for details. If
+ -- changes are made such that new edge kinds are added or similar, we
+ -- need to make sure this type matches the code in Add_Edge_Kind_Check,
+ -- and Add_Edge_Kind_Check matches the order of edge adding. Likewise,
+ -- if the edge-adding order changes, we need consistency between this
+ -- enumeration type, the edge-adding order, and Add_Edge_Kind_Check.
type Library_Graph_Edge_Kind is
- (Body_Before_Spec_Edge,
- -- Successor denotes spec, Predecessor denotes a body. This is a
- -- special edge kind used only during the discovery of components.
- -- Note that a body can never be elaborated before its spec.
+ (Spec_Before_Body_Edge,
+ -- Successor denotes a body, Predecessor denotes a spec
Elaborate_Edge,
-- Successor withs Predecessor, and has pragma Elaborate for it
@@ -716,6 +249,9 @@ package Bindo.Graphs is
Elaborate_All_Edge,
-- Successor withs Predecessor, and has pragma Elaborate_All for it
+ With_Edge,
+ -- Successor withs Predecessor
+
Forced_Edge,
-- Successor is forced to with Predecessor by virtue of an existing
-- elaboration order provided in a file.
@@ -724,11 +260,10 @@ package Bindo.Graphs is
-- An invocation construct in unit Successor invokes a target in unit
-- Predecessor.
- Spec_Before_Body_Edge,
- -- Successor denotes a body, Predecessor denotes a spec
-
- With_Edge,
- -- Successor withs Predecessor
+ Body_Before_Spec_Edge,
+ -- Successor denotes spec, Predecessor denotes a body. This is a
+ -- special edge kind used only during the discovery of components.
+ -- Note that a body can never be elaborated before its spec.
No_Edge);
@@ -1724,4 +1259,486 @@ package Bindo.Graphs is
type Edges_To_Successors_Iterator is new DG.Outgoing_Edge_Iterator;
end Library_Graphs;
+ -----------------------
+ -- Invocation_Graphs --
+ -----------------------
+
+ package Invocation_Graphs is
+
+ -----------
+ -- Graph --
+ -----------
+
+ -- The following type denotes an invocation graph handle. Each instance
+ -- must be created using routine Create.
+
+ type Invocation_Graph is private;
+ Nil : constant Invocation_Graph;
+
+ ----------------------
+ -- Graph operations --
+ ----------------------
+
+ procedure Add_Edge
+ (G : Invocation_Graph;
+ Source : Invocation_Graph_Vertex_Id;
+ Target : Invocation_Graph_Vertex_Id;
+ IR_Id : Invocation_Relation_Id);
+ pragma Inline (Add_Edge);
+ -- Create a new edge in invocation graph G with source vertex Source and
+ -- destination vertex Target. IR_Id is the invocation relation the edge
+ -- describes.
+
+ procedure Add_Vertex
+ (G : Invocation_Graph;
+ IC_Id : Invocation_Construct_Id;
+ Body_Vertex : Library_Graph_Vertex_Id;
+ Spec_Vertex : Library_Graph_Vertex_Id);
+ pragma Inline (Add_Vertex);
+ -- Create a new vertex in invocation graph G. IC_Id is the invocation
+ -- construct the vertex describes. Body_Vertex denotes the library graph
+ -- vertex where the invocation construct's body is declared. Spec_Vertex
+ -- is the library graph vertex where the invocation construct's spec is
+ -- declared.
+
+ function Create
+ (Initial_Vertices : Positive;
+ Initial_Edges : Positive;
+ Lib_Graph : Library_Graphs.Library_Graph)
+ return Invocation_Graph;
+ pragma Inline (Create);
+ -- Create a new empty graph with vertex capacity Initial_Vertices
+ -- and edge capacity Initial_Edges. Lib_Graph is the library graph
+ -- corresponding to this invocation graph.
+
+ function Get_Lib_Graph
+ (G : Invocation_Graph) return Library_Graphs.Library_Graph;
+ pragma Inline (Get_Lib_Graph);
+ -- Return the library graph corresponding to this invocation graph
+
+ procedure Destroy (G : in out Invocation_Graph);
+ pragma Inline (Destroy);
+ -- Destroy the contents of invocation graph G, rendering it unusable
+
+ function Present (G : Invocation_Graph) return Boolean;
+ pragma Inline (Present);
+ -- Determine whether invocation graph G exists
+
+ -----------------------
+ -- Vertex attributes --
+ -----------------------
+
+ function Body_Vertex
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id;
+ pragma Inline (Body_Vertex);
+ -- Obtain the library graph vertex where the body of the invocation
+ -- construct represented by vertex Vertex of invocation graph G is
+ -- declared.
+
+ function Column
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Nat;
+ pragma Inline (Column);
+ -- Obtain the column number where the invocation construct vertex Vertex
+ -- of invocation graph G describes.
+
+ function Construct
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Invocation_Construct_Id;
+ pragma Inline (Construct);
+ -- Obtain the invocation construct vertex Vertex of invocation graph G
+ -- describes.
+
+ function Corresponding_Vertex
+ (G : Invocation_Graph;
+ IS_Id : Invocation_Signature_Id) return Invocation_Graph_Vertex_Id;
+ pragma Inline (Corresponding_Vertex);
+ -- Obtain the vertex of invocation graph G that corresponds to signature
+ -- IS_Id.
+
+ function Line
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Nat;
+ pragma Inline (Line);
+ -- Obtain the line number where the invocation construct vertex Vertex
+ -- of invocation graph G describes.
+
+ function Name
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Name_Id;
+ pragma Inline (Name);
+ -- Obtain the name of the construct vertex Vertex of invocation graph G
+ -- describes.
+
+ function Spec_Vertex
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id;
+ pragma Inline (Spec_Vertex);
+ -- Obtain the library graph vertex where the spec of the invocation
+ -- construct represented by vertex Vertex of invocation graph G is
+ -- declared.
+
+ ---------------------
+ -- Edge attributes --
+ ---------------------
+
+ function Extra
+ (G : Invocation_Graph;
+ Edge : Invocation_Graph_Edge_Id) return Name_Id;
+ pragma Inline (Extra);
+ -- Obtain the extra name used in error diagnostics of edge Edge of
+ -- invocation graph G.
+
+ function Kind
+ (G : Invocation_Graph;
+ Edge : Invocation_Graph_Edge_Id) return Invocation_Kind;
+ pragma Inline (Kind);
+ -- Obtain the nature of edge Edge of invocation graph G
+
+ function Relation
+ (G : Invocation_Graph;
+ Edge : Invocation_Graph_Edge_Id) return Invocation_Relation_Id;
+ pragma Inline (Relation);
+ -- Obtain the relation edge Edge of invocation graph G describes
+
+ function Target
+ (G : Invocation_Graph;
+ Edge : Invocation_Graph_Edge_Id) return Invocation_Graph_Vertex_Id;
+ pragma Inline (Target);
+ -- Obtain the target vertex edge Edge of invocation graph G designates
+
+ ----------------
+ -- Statistics --
+ ----------------
+
+ function Invocation_Graph_Edge_Count
+ (G : Invocation_Graph;
+ Kind : Invocation_Kind) return Natural;
+ pragma Inline (Invocation_Graph_Edge_Count);
+ -- Obtain the total number of edges of kind Kind in invocation graph G
+
+ function Number_Of_Edges (G : Invocation_Graph) return Natural;
+ pragma Inline (Number_Of_Edges);
+ -- Obtain the total number of edges in invocation graph G
+
+ function Number_Of_Edges_To_Targets
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Natural;
+ pragma Inline (Number_Of_Edges_To_Targets);
+ -- Obtain the total number of edges to targets vertex Vertex of
+ -- invocation graph G has.
+
+ function Number_Of_Elaboration_Roots
+ (G : Invocation_Graph) return Natural;
+ pragma Inline (Number_Of_Elaboration_Roots);
+ -- Obtain the total number of elaboration roots in invocation graph G
+
+ function Number_Of_Vertices (G : Invocation_Graph) return Natural;
+ pragma Inline (Number_Of_Vertices);
+ -- Obtain the total number of vertices in invocation graph G
+
+ ---------------
+ -- Iterators --
+ ---------------
+
+ -- The following type represents an iterator over all edges of an
+ -- invocation graph.
+
+ type All_Edge_Iterator is private;
+
+ function Has_Next (Iter : All_Edge_Iterator) return Boolean;
+ pragma Inline (Has_Next);
+ -- Determine whether iterator Iter has more edges to examine
+
+ function Iterate_All_Edges
+ (G : Invocation_Graph) return All_Edge_Iterator;
+ pragma Inline (Iterate_All_Edges);
+ -- Obtain an iterator over all edges of invocation graph G
+
+ procedure Next
+ (Iter : in out All_Edge_Iterator;
+ Edge : out Invocation_Graph_Edge_Id);
+ pragma Inline (Next);
+ -- Return the current edge referenced by iterator Iter and advance to
+ -- the next available edge.
+
+ -- The following type represents an iterator over all vertices of an
+ -- invocation graph.
+
+ type All_Vertex_Iterator is private;
+
+ function Has_Next (Iter : All_Vertex_Iterator) return Boolean;
+ pragma Inline (Has_Next);
+ -- Determine whether iterator Iter has more vertices to examine
+
+ function Iterate_All_Vertices
+ (G : Invocation_Graph) return All_Vertex_Iterator;
+ pragma Inline (Iterate_All_Vertices);
+ -- Obtain an iterator over all vertices of invocation graph G
+
+ procedure Next
+ (Iter : in out All_Vertex_Iterator;
+ Vertex : out Invocation_Graph_Vertex_Id);
+ pragma Inline (Next);
+ -- Return the current vertex referenced by iterator Iter and advance
+ -- to the next available vertex.
+
+ -- The following type represents an iterator over all edges that reach
+ -- targets starting from a particular source vertex.
+
+ type Edges_To_Targets_Iterator is private;
+
+ function Has_Next (Iter : Edges_To_Targets_Iterator) return Boolean;
+ pragma Inline (Has_Next);
+ -- Determine whether iterator Iter has more edges to examine
+
+ function Iterate_Edges_To_Targets
+ (G : Invocation_Graph;
+ Vertex : Invocation_Graph_Vertex_Id) return Edges_To_Targets_Iterator;
+ pragma Inline (Iterate_Edges_To_Targets);
+ -- Obtain an iterator over all edges to targets with source vertex
+ -- Vertex of invocation graph G.
+
+ procedure Next
+ (Iter : in out Edges_To_Targets_Iterator;
+ Edge : out Invocation_Graph_Edge_Id);
+ pragma Inline (Next);
+ -- Return the current edge referenced by iterator Iter and advance to
+ -- the next available edge.
+
+ -- The following type represents an iterator over all vertices of an
+ -- invocation graph that denote the elaboration procedure or a spec or
+ -- a body, referred to as elaboration root.
+
+ type Elaboration_Root_Iterator is private;
+
+ function Has_Next (Iter : Elaboration_Root_Iterator) return Boolean;
+ pragma Inline (Has_Next);
+ -- Determine whether iterator Iter has more elaboration roots to examine
+
+ function Iterate_Elaboration_Roots
+ (G : Invocation_Graph) return Elaboration_Root_Iterator;
+ pragma Inline (Iterate_Elaboration_Roots);
+ -- Obtain an iterator over all elaboration roots of invocation graph G
+
+ procedure Next
+ (Iter : in out Elaboration_Root_Iterator;
+ Root : out Invocation_Graph_Vertex_Id);
+ pragma Inline (Next);
+ -- Return the current elaboration root referenced by iterator Iter and
+ -- advance to the next available elaboration root.
+
+ private
+
+ --------------
+ -- Vertices --
+ --------------
+
+ procedure Destroy_Invocation_Graph_Vertex
+ (Vertex : in out Invocation_Graph_Vertex_Id);
+ pragma Inline (Destroy_Invocation_Graph_Vertex);
+ -- Destroy invocation graph vertex Vertex
+
+ -- The following type represents the attributes of an invocation graph
+ -- vertex.
+
+ type Invocation_Graph_Vertex_Attributes is record
+ Body_Vertex : Library_Graph_Vertex_Id := No_Library_Graph_Vertex;
+ -- Reference to the library graph vertex where the body of this
+ -- vertex resides.
+
+ Construct : Invocation_Construct_Id := No_Invocation_Construct;
+ -- Reference to the invocation construct this vertex represents
+
+ Spec_Vertex : Library_Graph_Vertex_Id := No_Library_Graph_Vertex;
+ -- Reference to the library graph vertex where the spec of this
+ -- vertex resides.
+ end record;
+
+ No_Invocation_Graph_Vertex_Attributes :
+ constant Invocation_Graph_Vertex_Attributes :=
+ (Body_Vertex => No_Library_Graph_Vertex,
+ Construct => No_Invocation_Construct,
+ Spec_Vertex => No_Library_Graph_Vertex);
+
+ procedure Destroy_Invocation_Graph_Vertex_Attributes
+ (Attrs : in out Invocation_Graph_Vertex_Attributes);
+ pragma Inline (Destroy_Invocation_Graph_Vertex_Attributes);
+ -- Destroy the contents of attributes Attrs
+
+ package IGV_Tables is new Dynamic_Hash_Tables
+ (Key_Type => Invocation_Graph_Vertex_Id,
+ Value_Type => Invocation_Graph_Vertex_Attributes,
+ No_Value => No_Invocation_Graph_Vertex_Attributes,
+ Expansion_Threshold => 1.5,
+ Expansion_Factor => 2,
+ Compression_Threshold => 0.3,
+ Compression_Factor => 2,
+ "=" => "=",
+ Destroy_Value => Destroy_Invocation_Graph_Vertex_Attributes,
+ Hash => Hash_Invocation_Graph_Vertex);
+
+ -----------
+ -- Edges --
+ -----------
+
+ procedure Destroy_Invocation_Graph_Edge
+ (Edge : in out Invocation_Graph_Edge_Id);
+ pragma Inline (Destroy_Invocation_Graph_Edge);
+ -- Destroy invocation graph edge Edge
+
+ -- The following type represents the attributes of an invocation graph
+ -- edge.
+
+ type Invocation_Graph_Edge_Attributes is record
+ Relation : Invocation_Relation_Id := No_Invocation_Relation;
+ -- Reference to the invocation relation this edge represents
+ end record;
+
+ No_Invocation_Graph_Edge_Attributes :
+ constant Invocation_Graph_Edge_Attributes :=
+ (Relation => No_Invocation_Relation);
+
+ procedure Destroy_Invocation_Graph_Edge_Attributes
+ (Attrs : in out Invocation_Graph_Edge_Attributes);
+ pragma Inline (Destroy_Invocation_Graph_Edge_Attributes);
+ -- Destroy the contents of attributes Attrs
+
+ package IGE_Tables is new Dynamic_Hash_Tables
+ (Key_Type => Invocation_Graph_Edge_Id,
+ Value_Type => Invocation_Graph_Edge_Attributes,
+ No_Value => No_Invocation_Graph_Edge_Attributes,
+ Expansion_Threshold => 1.5,
+ Expansion_Factor => 2,
+ Compression_Threshold => 0.3,
+ Compression_Factor => 2,
+ "=" => "=",
+ Destroy_Value => Destroy_Invocation_Graph_Edge_Attributes,
+ Hash => Hash_Invocation_Graph_Edge);
+
+ ---------------
+ -- Relations --
+ ---------------
+
+ -- The following type represents a relation between a source and target
+ -- vertices.
+
+ type Source_Target_Relation is record
+ Source : Invocation_Graph_Vertex_Id := No_Invocation_Graph_Vertex;
+ -- The source vertex
+
+ Target : Invocation_Graph_Vertex_Id := No_Invocation_Graph_Vertex;
+ -- The destination vertex
+ end record;
+
+ No_Source_Target_Relation :
+ constant Source_Target_Relation :=
+ (Source => No_Invocation_Graph_Vertex,
+ Target => No_Invocation_Graph_Vertex);
+
+ function Hash_Source_Target_Relation
+ (Rel : Source_Target_Relation) return Bucket_Range_Type;
+ pragma Inline (Hash_Source_Target_Relation);
+ -- Obtain the hash value of key Rel
+
+ package Relation_Sets is new Membership_Sets
+ (Element_Type => Source_Target_Relation,
+ "=" => "=",
+ Hash => Hash_Source_Target_Relation);
+
+ ----------------
+ -- Statistics --
+ ----------------
+
+ type Invocation_Graph_Edge_Counts is array (Invocation_Kind) of Natural;
+
+ ----------------
+ -- Signatures --
+ ----------------
+
+ function Hash_Invocation_Signature
+ (IS_Id : Invocation_Signature_Id) return Bucket_Range_Type;
+ pragma Inline (Hash_Invocation_Signature);
+ -- Obtain the hash value of key IS_Id
+
+ package Signature_Tables is new Dynamic_Hash_Tables
+ (Key_Type => Invocation_Signature_Id,
+ Value_Type => Invocation_Graph_Vertex_Id,
+ No_Value => No_Invocation_Graph_Vertex,
+ Expansion_Threshold => 1.5,
+ Expansion_Factor => 2,
+ Compression_Threshold => 0.3,
+ Compression_Factor => 2,
+ "=" => "=",
+ Destroy_Value => Destroy_Invocation_Graph_Vertex,
+ Hash => Hash_Invocation_Signature);
+
+ -----------------------
+ -- Elaboration roots --
+ -----------------------
+
+ package IGV_Sets is new Membership_Sets
+ (Element_Type => Invocation_Graph_Vertex_Id,
+ "=" => "=",
+ Hash => Hash_Invocation_Graph_Vertex);
+
+ -----------
+ -- Graph --
+ -----------
+
+ package DG is new Directed_Graphs
+ (Vertex_Id => Invocation_Graph_Vertex_Id,
+ No_Vertex => No_Invocation_Graph_Vertex,
+ Hash_Vertex => Hash_Invocation_Graph_Vertex,
+ Same_Vertex => "=",
+ Edge_id => Invocation_Graph_Edge_Id,
+ No_Edge => No_Invocation_Graph_Edge,
+ Hash_Edge => Hash_Invocation_Graph_Edge,
+ Same_Edge => "=");
+
+ -- The following type represents the attributes of an invocation graph
+
+ type Invocation_Graph_Attributes is record
+ Counts : Invocation_Graph_Edge_Counts := (others => 0);
+ -- Edge statistics
+
+ Edge_Attributes : IGE_Tables.Dynamic_Hash_Table := IGE_Tables.Nil;
+ -- The map of edge -> edge attributes for all edges in the graph
+
+ Graph : DG.Directed_Graph := DG.Nil;
+ -- The underlying graph describing the relations between edges and
+ -- vertices.
+
+ Relations : Relation_Sets.Membership_Set := Relation_Sets.Nil;
+ -- The set of relations between source and targets, used to prevent
+ -- duplicate edges in the graph.
+
+ Roots : IGV_Sets.Membership_Set := IGV_Sets.Nil;
+ -- The set of elaboration root vertices
+
+ Signature_To_Vertex : Signature_Tables.Dynamic_Hash_Table :=
+ Signature_Tables.Nil;
+ -- The map of signature -> vertex
+
+ Vertex_Attributes : IGV_Tables.Dynamic_Hash_Table := IGV_Tables.Nil;
+ -- The map of vertex -> vertex attributes for all vertices in the
+ -- graph.
+
+ Lib_Graph : Library_Graphs.Library_Graph;
+ end record;
+
+ type Invocation_Graph is access Invocation_Graph_Attributes;
+ Nil : constant Invocation_Graph := null;
+
+ ---------------
+ -- Iterators --
+ ---------------
+
+ type All_Edge_Iterator is new DG.All_Edge_Iterator;
+ type All_Vertex_Iterator is new DG.All_Vertex_Iterator;
+ type Edges_To_Targets_Iterator is new DG.Outgoing_Edge_Iterator;
+ type Elaboration_Root_Iterator is new IGV_Sets.Iterator;
+ end Invocation_Graphs;
+
end Bindo.Graphs;
diff --git a/gcc/ada/bindo-units.adb b/gcc/ada/bindo-units.adb
index 284aa62..80eef3d 100644
--- a/gcc/ada/bindo-units.adb
+++ b/gcc/ada/bindo-units.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/bindo-units.ads b/gcc/ada/bindo-units.ads
index 5f045c8..ce29606 100644
--- a/gcc/ada/bindo-units.ads
+++ b/gcc/ada/bindo-units.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/bindo-validators.adb b/gcc/ada/bindo-validators.adb
index 584d33f..c4b2a0f 100644
--- a/gcc/ada/bindo-validators.adb
+++ b/gcc/ada/bindo-validators.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/bindo-validators.ads b/gcc/ada/bindo-validators.ads
index d70447b..1325f43 100644
--- a/gcc/ada/bindo-validators.ads
+++ b/gcc/ada/bindo-validators.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/bindo-writers.adb b/gcc/ada/bindo-writers.adb
index 1fcfb11..88c8b25 100644
--- a/gcc/ada/bindo-writers.adb
+++ b/gcc/ada/bindo-writers.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -927,6 +927,10 @@ package body Bindo.Writers is
(G : Invocation_Graph;
Vertex : Invocation_Graph_Vertex_Id)
is
+ Lib_Graph : constant Library_Graph := Get_Lib_Graph (G);
+
+ B : constant Library_Graph_Vertex_Id := Body_Vertex (G, Vertex);
+ S : constant Library_Graph_Vertex_Id := Spec_Vertex (G, Vertex);
begin
pragma Assert (Present (G));
pragma Assert (Present (Vertex));
@@ -938,8 +942,9 @@ package body Bindo.Writers is
Write_Eol;
Write_Str (" Body_Vertex (LGV_Id_");
- Write_Int (Int (Body_Vertex (G, Vertex)));
- Write_Str (")");
+ Write_Int (Int (B));
+ Write_Str (") name = ");
+ Write_Name (Name (Lib_Graph, B));
Write_Eol;
Write_Str (" Construct (IC_Id_");
@@ -948,8 +953,9 @@ package body Bindo.Writers is
Write_Eol;
Write_Str (" Spec_Vertex (LGV_Id_");
- Write_Int (Int (Spec_Vertex (G, Vertex)));
- Write_Str (")");
+ Write_Int (Int (S));
+ Write_Str (") name = ");
+ Write_Name (Name (Lib_Graph, S));
Write_Eol;
Write_Invocation_Graph_Edges (G, Vertex);
@@ -1031,7 +1037,7 @@ package body Bindo.Writers is
-- output.
procedure Write_Components (G : Library_Graph);
- pragma Inline (Write_Component);
+ pragma Inline (Write_Components);
-- Write all components of library graph G to standard output
procedure Write_Edges_To_Successors
diff --git a/gcc/ada/bindo-writers.ads b/gcc/ada/bindo-writers.ads
index 66483d0..cf47ffd 100644
--- a/gcc/ada/bindo-writers.ads
+++ b/gcc/ada/bindo-writers.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/bindo.adb b/gcc/ada/bindo.adb
index 249ce972..0098b2d 100644
--- a/gcc/ada/bindo.adb
+++ b/gcc/ada/bindo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/bindo.ads b/gcc/ada/bindo.ads
index ae35c95..adecc83 100644
--- a/gcc/ada/bindo.ads
+++ b/gcc/ada/bindo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb
index 8331745..6fd55ee 100644
--- a/gcc/ada/bindusg.adb
+++ b/gcc/ada/bindusg.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -315,6 +315,11 @@ package body Bindusg is
Write_Line
(" -x Exclude source files (check object consistency only)");
+ -- Line for -xdr switch
+
+ Write_Line
+ (" -xdr Use the XDR protocol for streaming");
+
-- Line for -X switch
Write_Line
diff --git a/gcc/ada/bindusg.ads b/gcc/ada/bindusg.ads
index eadadb5..edc6888 100644
--- a/gcc/ada/bindusg.ads
+++ b/gcc/ada/bindusg.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/butil.adb b/gcc/ada/butil.adb
index 9427ddd..8cb5a07 100644
--- a/gcc/ada/butil.adb
+++ b/gcc/ada/butil.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/butil.ads b/gcc/ada/butil.ads
index 3ce2f1e..2df4671 100644
--- a/gcc/ada/butil.ads
+++ b/gcc/ada/butil.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/cal.c b/gcc/ada/cal.c
index c61f502..01cabe7 100644
--- a/gcc/ada/cal.c
+++ b/gcc/ada/cal.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/casing.adb b/gcc/ada/casing.adb
index ec87f77..b5020d5 100644
--- a/gcc/ada/casing.adb
+++ b/gcc/ada/casing.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/casing.ads b/gcc/ada/casing.ads
index da779a1..b40faaa 100644
--- a/gcc/ada/casing.ads
+++ b/gcc/ada/casing.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/ceinfo.adb b/gcc/ada/ceinfo.adb
index 289f5d0..8ce6b69 100644
--- a/gcc/ada/ceinfo.adb
+++ b/gcc/ada/ceinfo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 51ef6c0..9de21d6 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -223,7 +223,7 @@ package body Checks is
-- can be referenced and trusted only if ROK is set True.
procedure Apply_Float_Conversion_Check
- (Ck_Node : Node_Id;
+ (Expr : Node_Id;
Target_Typ : Entity_Id);
-- The checks on a conversion from a floating-point type to an integer
-- type are delicate. They have to be performed before conversion, they
@@ -231,7 +231,7 @@ package body Checks is
-- be taken into account to determine the safe bounds of the operand.
procedure Apply_Selected_Length_Checks
- (Ck_Node : Node_Id;
+ (Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Do_Static : Boolean);
@@ -240,15 +240,20 @@ package body Checks is
-- described for the above routines. The Do_Static flag indicates that
-- only a static check is to be done.
- procedure Apply_Selected_Range_Checks
- (Ck_Node : Node_Id;
- Target_Typ : Entity_Id;
- Source_Typ : Entity_Id;
- Do_Static : Boolean);
- -- This is the subprogram that does all the work for Apply_Range_Check.
- -- Expr, Target_Typ and Source_Typ are as described for the above
- -- routine. The Do_Static flag indicates that only a static check is
- -- to be done.
+ procedure Compute_Range_For_Arithmetic_Op
+ (Op : Node_Kind;
+ Lo_Left : Uint;
+ Hi_Left : Uint;
+ Lo_Right : Uint;
+ Hi_Right : Uint;
+ OK : out Boolean;
+ Lo : out Uint;
+ Hi : out Uint);
+ -- Given an integer arithmetical operation Op and the range of values of
+ -- its operand(s), try to compute a conservative estimate of the possible
+ -- range of values for the result of the operation. Thus if OK is True on
+ -- return, the result is known to lie in the range Lo .. Hi (inclusive).
+ -- If OK is false, both Lo and Hi are set to No_Uint.
type Check_Type is new Check_Id range Access_Check .. Division_Check;
function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean;
@@ -307,9 +312,9 @@ package body Checks is
-- To be cleaned up???
function Guard_Access
- (Cond : Node_Id;
- Loc : Source_Ptr;
- Ck_Node : Node_Id) return Node_Id;
+ (Cond : Node_Id;
+ Loc : Source_Ptr;
+ Expr : Node_Id) return Node_Id;
-- In the access type case, guard the test with a test to ensure
-- that the access value is non-null, since the checks do not
-- not apply to null access values.
@@ -332,7 +337,7 @@ package body Checks is
-- of an entity, if these checks are suppressed for the entity.
function Selected_Length_Checks
- (Ck_Node : Node_Id;
+ (Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Warn_Node : Node_Id) return Check_Result;
@@ -345,12 +350,12 @@ package body Checks is
-- Selected_Range_Checks.
function Selected_Range_Checks
- (Ck_Node : Node_Id;
+ (Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Warn_Node : Node_Id) return Check_Result;
- -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
- -- just returns a list of nodes as described in the spec of this package
+ -- Like Apply_Range_Check, except it does not modify anything, just
+ -- returns a list of nodes as described in the spec of this package
-- for the Range_Check function.
------------------------------
@@ -428,7 +433,7 @@ package body Checks is
-- Nothing to do for Rem/Mod/Plus (overflow not possible, the check
-- for zero-divide is a divide check, not an overflow check).
- if Nkind_In (N, N_Op_Rem, N_Op_Mod, N_Op_Plus) then
+ if Nkind (N) in N_Op_Rem | N_Op_Mod | N_Op_Plus then
return;
end if;
end if;
@@ -488,17 +493,13 @@ package body Checks is
(Checks : Check_Result;
Stmts : List_Id;
Suppress_Typ : Entity_Id;
- Static_Sloc : Source_Ptr;
- Flag_Node : Node_Id)
+ Static_Sloc : Source_Ptr)
is
Checks_On : constant Boolean :=
not Index_Checks_Suppressed (Suppress_Typ)
or else
not Range_Checks_Suppressed (Suppress_Typ);
- Internal_Flag_Node : constant Node_Id := Flag_Node;
- Internal_Static_Sloc : constant Source_Ptr := Static_Sloc;
-
begin
-- For now we just return if Checks_On is false, however this should be
-- enhanced to check for an always True value in the condition and to
@@ -514,15 +515,11 @@ package body Checks is
if Nkind (Checks (J)) = N_Raise_Constraint_Error
and then Present (Condition (Checks (J)))
then
- if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
- Append_To (Stmts, Checks (J));
- Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
- end if;
-
+ Append_To (Stmts, Checks (J));
else
Append_To
(Stmts,
- Make_Raise_Constraint_Error (Internal_Static_Sloc,
+ Make_Raise_Constraint_Error (Static_Sloc,
Reason => CE_Range_Check_Failed));
end if;
end loop;
@@ -588,7 +585,7 @@ package body Checks is
if Ada_Version >= Ada_2012
and then not Present (Param_Ent)
and then Is_Entity_Name (N)
- and then Ekind_In (Entity (N), E_Constant, E_Variable)
+ and then Ekind (Entity (N)) in E_Constant | E_Variable
and then Present (Effective_Extra_Accessibility (Entity (N)))
then
Param_Ent := Entity (N);
@@ -624,9 +621,8 @@ package body Checks is
-- deepest type level so as to appropriatly handle the rules for
-- RM 3.10.2 (10.1/3).
- if Ekind_In (Scope (Param_Ent), E_Function,
- E_Operator,
- E_Subprogram_Type)
+ if Ekind (Scope (Param_Ent))
+ in E_Function | E_Operator | E_Subprogram_Type
and then Present (Extra_Accessibility_Of_Result (Scope (Param_Ent)))
then
Type_Level :=
@@ -1207,7 +1203,7 @@ package body Checks is
-- there is no overflow check that starts from that parent node,
-- so apply check now.
- if Nkind_In (P, N_If_Expression, N_Case_Expression)
+ if Nkind (P) in N_If_Expression | N_Case_Expression
and then not Is_Signed_Integer_Arithmetic_Op (Parent (P))
then
null;
@@ -1968,7 +1964,7 @@ package body Checks is
-- (1) The bounds may not be known at compile time
-- (2) The check must take into account rounding or truncation.
-- (3) The range of type I may not be exactly representable in F.
- -- (4) For the rounding case, The end-points I'First - 0.5 and
+ -- (4) For the rounding case, the end-points I'First - 0.5 and
-- I'Last + 0.5 may or may not be in range, depending on the
-- sign of I'First and I'Last.
-- (5) X may be a NaN, which will fail any comparison
@@ -1999,17 +1995,17 @@ package body Checks is
-- Hi_OK be True.
procedure Apply_Float_Conversion_Check
- (Ck_Node : Node_Id;
+ (Expr : Node_Id;
Target_Typ : Entity_Id)
is
LB : constant Node_Id := Type_Low_Bound (Target_Typ);
HB : constant Node_Id := Type_High_Bound (Target_Typ);
- Loc : constant Source_Ptr := Sloc (Ck_Node);
- Expr_Type : constant Entity_Id := Base_Type (Etype (Ck_Node));
+ Loc : constant Source_Ptr := Sloc (Expr);
+ Expr_Type : constant Entity_Id := Base_Type (Etype (Expr));
Target_Base : constant Entity_Id :=
Implementation_Base_Type (Target_Typ);
- Par : constant Node_Id := Parent (Ck_Node);
+ Par : constant Node_Id := Parent (Expr);
pragma Assert (Nkind (Par) = N_Type_Conversion);
-- Parent of check node, must be a type conversion
@@ -2049,7 +2045,7 @@ package body Checks is
-- set the Do_Range check flag, since the range check is taken care of
-- by the code we will generate.
- Set_Do_Range_Check (Ck_Node, False);
+ Set_Do_Range_Check (Expr, False);
if not Compile_Time_Known_Value (LB)
or not Compile_Time_Known_Value (HB)
@@ -2064,7 +2060,7 @@ package body Checks is
Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Par);
begin
- Apply_Float_Conversion_Check (Ck_Node, Target_Base);
+ Apply_Float_Conversion_Check (Expr, Target_Base);
Set_Etype (Temp, Target_Base);
-- Note: Previously the declaration was inserted above the parent
@@ -2105,21 +2101,21 @@ package body Checks is
-- we can do the comparison with the bounds and the conversion to
-- an integer type statically. The range checks are unchanged.
- if Nkind (Ck_Node) = N_Real_Literal
- and then Etype (Ck_Node) = Universal_Real
+ if Nkind (Expr) = N_Real_Literal
+ and then Etype (Expr) = Universal_Real
and then Is_Integer_Type (Target_Typ)
then
declare
- Int_Val : constant Uint := UR_To_Uint (Realval (Ck_Node));
+ Int_Val : constant Uint := UR_To_Uint (Realval (Expr));
begin
if Int_Val <= Ilast and then Int_Val >= Ifirst then
-- Conversion is safe
- Rewrite (Parent (Ck_Node),
+ Rewrite (Parent (Expr),
Make_Integer_Literal (Loc, UI_To_Int (Int_Val)));
- Analyze_And_Resolve (Parent (Ck_Node), Target_Typ);
+ Analyze_And_Resolve (Parent (Expr), Target_Typ);
return;
end if;
end;
@@ -2140,7 +2136,7 @@ package body Checks is
Lo_OK := (Ifirst > 0);
else
- Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node);
+ Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Expr);
Lo_OK := (Lo >= UR_From_Uint (Ifirst));
end if;
@@ -2149,14 +2145,14 @@ package body Checks is
-- Lo_Chk := (X >= Lo)
Lo_Chk := Make_Op_Ge (Loc,
- Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Expr),
Right_Opnd => Make_Real_Literal (Loc, Lo));
else
-- Lo_Chk := (X > Lo)
Lo_Chk := Make_Op_Gt (Loc,
- Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Expr),
Right_Opnd => Make_Real_Literal (Loc, Lo));
end if;
@@ -2174,7 +2170,7 @@ package body Checks is
Hi := UR_From_Uint (Ilast) + Ureal_Half;
Hi_OK := (Ilast < 0);
else
- Hi := Machine (Expr_Type, UR_From_Uint (Ilast), Round_Even, Ck_Node);
+ Hi := Machine (Expr_Type, UR_From_Uint (Ilast), Round_Even, Expr);
Hi_OK := (Hi <= UR_From_Uint (Ilast));
end if;
@@ -2183,14 +2179,14 @@ package body Checks is
-- Hi_Chk := (X <= Hi)
Hi_Chk := Make_Op_Le (Loc,
- Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Expr),
Right_Opnd => Make_Real_Literal (Loc, Hi));
else
-- Hi_Chk := (X < Hi)
Hi_Chk := Make_Op_Lt (Loc,
- Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Expr),
Right_Opnd => Make_Real_Literal (Loc, Hi));
end if;
@@ -2208,7 +2204,7 @@ package body Checks is
-- Raise CE if either conditions does not hold
- Insert_Action (Ck_Node,
+ Insert_Action (Expr,
Make_Raise_Constraint_Error (Loc,
Condition => Make_Op_Not (Loc, Make_And_Then (Loc, Lo_Chk, Hi_Chk)),
Reason => Reason));
@@ -2219,15 +2215,43 @@ package body Checks is
------------------------
procedure Apply_Length_Check
- (Ck_Node : Node_Id;
+ (Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty)
is
begin
Apply_Selected_Length_Checks
- (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
+ (Expr, Target_Typ, Source_Typ, Do_Static => False);
end Apply_Length_Check;
+ --------------------------------------
+ -- Apply_Length_Check_On_Assignment --
+ --------------------------------------
+
+ procedure Apply_Length_Check_On_Assignment
+ (Expr : Node_Id;
+ Target_Typ : Entity_Id;
+ Target : Node_Id;
+ Source_Typ : Entity_Id := Empty)
+ is
+ Assign : constant Node_Id := Parent (Target);
+
+ begin
+ -- No check is needed for the initialization of an object whose
+ -- nominal subtype is unconstrained.
+
+ if Is_Constr_Subt_For_U_Nominal (Target_Typ)
+ and then Nkind (Parent (Assign)) = N_Freeze_Entity
+ and then Is_Entity_Name (Target)
+ and then Entity (Target) = Entity (Parent (Assign))
+ then
+ return;
+ end if;
+
+ Apply_Selected_Length_Checks
+ (Expr, Target_Typ, Source_Typ, Do_Static => False);
+ end Apply_Length_Check_On_Assignment;
+
-------------------------------------
-- Apply_Parameter_Aliasing_Checks --
-------------------------------------
@@ -2644,8 +2668,8 @@ package body Checks is
if not Comes_From_Source (Subp)
- -- Do not process formal subprograms because the corresponding actual
- -- will receive the proper checks when the instance is analyzed.
+ -- Do not process formal subprograms because the corresponding actual
+ -- will receive the proper checks when the instance is analyzed.
or else Is_Formal_Subprogram (Subp)
@@ -2688,14 +2712,12 @@ package body Checks is
-- mode IN OUT - Pre, Post => Formal'Valid[_Scalars]
-- mode OUT - Post => Formal'Valid[_Scalars]
- if Check_Validity_Of_Parameters then
- if Ekind_In (Formal, E_In_Parameter, E_In_Out_Parameter) then
- Add_Validity_Check (Formal, Name_Precondition, False);
- end if;
+ if Ekind (Formal) in E_In_Parameter | E_In_Out_Parameter then
+ Add_Validity_Check (Formal, Name_Precondition, False);
+ end if;
- if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
- Add_Validity_Check (Formal, Name_Postcondition, False);
- end if;
+ if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then
+ Add_Validity_Check (Formal, Name_Postcondition, False);
end if;
Next_Formal (Formal);
@@ -2705,7 +2727,7 @@ package body Checks is
-- Post => Subp'Result'Valid[_Scalars]
- if Check_Validity_Of_Parameters and then Ekind (Subp) = E_Function then
+ if Ekind (Subp) = E_Function then
Add_Validity_Check (Subp, Name_Postcondition, True);
end if;
end Apply_Parameter_Validity_Checks;
@@ -2719,133 +2741,150 @@ package body Checks is
Typ : Entity_Id;
Fun : Entity_Id := Empty)
is
- S : Entity_Id;
+ Par : Node_Id;
+ S : Entity_Id;
begin
- if Predicate_Checks_Suppressed (Empty) then
+ if not Predicate_Enabled (Typ)
+ or else not Predicate_Check_In_Scope (N)
+ then
return;
+ end if;
- elsif Predicates_Ignored (Typ) then
+ S := Current_Scope;
+ while Present (S) and then not Is_Subprogram (S) loop
+ S := Scope (S);
+ end loop;
+
+ -- If the check appears within the predicate function itself, it means
+ -- that the user specified a check whose formal is the predicated
+ -- subtype itself, rather than some covering type. This is likely to be
+ -- a common error, and thus deserves a warning.
+
+ if Present (S) and then S = Predicate_Function (Typ) then
+ Error_Msg_NE
+ ("predicate check includes a call to& that requires a "
+ & "predicate check??", Parent (N), Fun);
+ Error_Msg_N
+ ("\this will result in infinite recursion??", Parent (N));
+
+ if Is_First_Subtype (Typ) then
+ Error_Msg_NE
+ ("\use an explicit subtype of& to carry the predicate",
+ Parent (N), Typ);
+ end if;
+
+ Insert_Action (N,
+ Make_Raise_Storage_Error (Sloc (N),
+ Reason => SE_Infinite_Recursion));
return;
+ end if;
- elsif Present (Predicate_Function (Typ)) then
- S := Current_Scope;
- while Present (S) and then not Is_Subprogram (S) loop
- S := Scope (S);
- end loop;
+ -- Normal case of predicate active
- -- A predicate check does not apply within internally generated
- -- subprograms, such as TSS functions.
+ -- If the expression is an IN parameter, the predicate will have
+ -- been applied at the point of call. An additional check would
+ -- be redundant, or will lead to out-of-scope references if the
+ -- call appears within an aspect specification for a precondition.
- if Within_Internal_Subprogram then
- return;
+ -- However, if the reference is within the body of the subprogram
+ -- that declares the formal, the predicate can safely be applied,
+ -- which may be necessary for a nested call whose formal has a
+ -- different predicate.
+
+ if Is_Entity_Name (N)
+ and then Ekind (Entity (N)) = E_In_Parameter
+ then
+ declare
+ In_Body : Boolean := False;
+ P : Node_Id := Parent (N);
- -- If the check appears within the predicate function itself, it
- -- means that the user specified a check whose formal is the
- -- predicated subtype itself, rather than some covering type. This
- -- is likely to be a common error, and thus deserves a warning.
+ begin
+ while Present (P) loop
+ if Nkind (P) = N_Subprogram_Body
+ and then
+ ((Present (Corresponding_Spec (P))
+ and then
+ Corresponding_Spec (P) = Scope (Entity (N)))
+ or else
+ Defining_Unit_Name (Specification (P)) =
+ Scope (Entity (N)))
+ then
+ In_Body := True;
+ exit;
+ end if;
- elsif Present (S) and then S = Predicate_Function (Typ) then
- Error_Msg_NE
- ("predicate check includes a call to& that requires a "
- & "predicate check??", Parent (N), Fun);
- Error_Msg_N
- ("\this will result in infinite recursion??", Parent (N));
+ P := Parent (P);
+ end loop;
- if Is_First_Subtype (Typ) then
- Error_Msg_NE
- ("\use an explicit subtype of& to carry the predicate",
- Parent (N), Typ);
+ if not In_Body then
+ return;
end if;
+ end;
+ end if;
- Insert_Action (N,
- Make_Raise_Storage_Error (Sloc (N),
- Reason => SE_Infinite_Recursion));
-
- -- Here for normal case of predicate active
+ -- If the type has a static predicate and the expression is known
+ -- at compile time, see if the expression satisfies the predicate.
- else
- -- If the expression is an IN parameter, the predicate will have
- -- been applied at the point of call. An additional check would
- -- be redundant, or will lead to out-of-scope references if the
- -- call appears within an aspect specification for a precondition.
-
- -- However, if the reference is within the body of the subprogram
- -- that declares the formal, the predicate can safely be applied,
- -- which may be necessary for a nested call whose formal has a
- -- different predicate.
-
- if Is_Entity_Name (N)
- and then Ekind (Entity (N)) = E_In_Parameter
- then
- declare
- In_Body : Boolean := False;
- P : Node_Id := Parent (N);
+ Check_Expression_Against_Static_Predicate (N, Typ);
- begin
- while Present (P) loop
- if Nkind (P) = N_Subprogram_Body
- and then Corresponding_Spec (P) = Scope (Entity (N))
- then
- In_Body := True;
- exit;
- end if;
+ if not Expander_Active then
+ return;
+ end if;
- P := Parent (P);
- end loop;
+ Par := Parent (N);
+ if Nkind (Par) = N_Qualified_Expression then
+ Par := Parent (Par);
+ end if;
- if not In_Body then
- return;
- end if;
- end;
- end if;
+ -- For an entity of the type, generate a call to the predicate
+ -- function, unless its type is an actual subtype, which is not
+ -- visible outside of the enclosing subprogram.
- -- If the type has a static predicate and the expression is known
- -- at compile time, see if the expression satisfies the predicate.
+ if Is_Entity_Name (N)
+ and then not Is_Actual_Subtype (Typ)
+ then
+ Insert_Action (N,
+ Make_Predicate_Check
+ (Typ, New_Occurrence_Of (Entity (N), Sloc (N))));
+ return;
- Check_Expression_Against_Static_Predicate (N, Typ);
+ elsif Nkind (N) in N_Aggregate | N_Extension_Aggregate then
- if not Expander_Active then
- return;
- end if;
+ -- If the expression is an aggregate in an assignment, apply the
+ -- check to the LHS after the assignment, rather than create a
+ -- redundant temporary. This is only necessary in rare cases
+ -- of array types (including strings) initialized with an
+ -- aggregate with an "others" clause, either coming from source
+ -- or generated by an Initialize_Scalars pragma.
- -- For an entity of the type, generate a call to the predicate
- -- function, unless its type is an actual subtype, which is not
- -- visible outside of the enclosing subprogram.
+ if Nkind (Par) = N_Assignment_Statement then
+ Insert_Action_After (Par,
+ Make_Predicate_Check
+ (Typ, Duplicate_Subexpr (Name (Par))));
+ return;
- if Is_Entity_Name (N)
- and then not Is_Actual_Subtype (Typ)
- then
- Insert_Action (N,
- Make_Predicate_Check
- (Typ, New_Occurrence_Of (Entity (N), Sloc (N))));
-
- -- If the expression is not an entity it may have side effects,
- -- and the following call will create an object declaration for
- -- it. We disable checks during its analysis, to prevent an
- -- infinite recursion.
-
- -- If the prefix is an aggregate in an assignment, apply the
- -- check to the LHS after assignment, rather than create a
- -- redundant temporary. This is only necessary in rare cases
- -- of array types (including strings) initialized with an
- -- aggregate with an "others" clause, either coming from source
- -- or generated by an Initialize_Scalars pragma.
-
- elsif Nkind (N) = N_Aggregate
- and then Nkind (Parent (N)) = N_Assignment_Statement
- then
- Insert_Action_After (Parent (N),
- Make_Predicate_Check
- (Typ, Duplicate_Subexpr (Name (Parent (N)))));
+ -- Similarly, if the expression is an aggregate in an object
+ -- declaration, apply it to the object after the declaration.
+ -- This is only necessary in rare cases of tagged extensions
+ -- initialized with an aggregate with an "others => <>" clause.
- else
- Insert_Action (N,
- Make_Predicate_Check
- (Typ, Duplicate_Subexpr (N)), Suppress => All_Checks);
- end if;
+ elsif Nkind (Par) = N_Object_Declaration then
+ Insert_Action_After (Par,
+ Make_Predicate_Check (Typ,
+ New_Occurrence_Of (Defining_Identifier (Par), Sloc (N))));
+ return;
end if;
end if;
+
+ -- If the expression is not an entity it may have side effects,
+ -- and the following call will create an object declaration for
+ -- it. We disable checks during its analysis, to prevent an
+ -- infinite recursion.
+
+ Insert_Action (N,
+ Make_Predicate_Check
+ (Typ, Duplicate_Subexpr (N)), Suppress => All_Checks);
end Apply_Predicate_Check;
-----------------------
@@ -2853,13 +2892,107 @@ package body Checks is
-----------------------
procedure Apply_Range_Check
- (Ck_Node : Node_Id;
- Target_Typ : Entity_Id;
- Source_Typ : Entity_Id := Empty)
+ (Expr : Node_Id;
+ Target_Typ : Entity_Id;
+ Source_Typ : Entity_Id := Empty;
+ Insert_Node : Node_Id := Empty)
is
+ Checks_On : constant Boolean :=
+ not Index_Checks_Suppressed (Target_Typ)
+ or else
+ not Range_Checks_Suppressed (Target_Typ);
+
+ Loc : constant Source_Ptr := Sloc (Expr);
+
+ Cond : Node_Id;
+ R_Cno : Node_Id;
+ R_Result : Check_Result;
+
begin
- Apply_Selected_Range_Checks
- (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
+ -- Only apply checks when generating code. In GNATprove mode, we do not
+ -- apply the checks, but we still call Selected_Range_Checks to possibly
+ -- issue errors on SPARK code when a run-time error can be detected at
+ -- compile time.
+
+ if not GNATprove_Mode then
+ if not Expander_Active or not Checks_On then
+ return;
+ end if;
+ end if;
+
+ R_Result :=
+ Selected_Range_Checks (Expr, Target_Typ, Source_Typ, Insert_Node);
+
+ if GNATprove_Mode then
+ return;
+ end if;
+
+ for J in 1 .. 2 loop
+ R_Cno := R_Result (J);
+ exit when No (R_Cno);
+
+ -- The range check requires runtime evaluation. Depending on what its
+ -- triggering condition is, the check may be converted into a compile
+ -- time constraint check.
+
+ if Nkind (R_Cno) = N_Raise_Constraint_Error
+ and then Present (Condition (R_Cno))
+ then
+ Cond := Condition (R_Cno);
+
+ -- Insert the range check before the related context. Note that
+ -- this action analyses the triggering condition.
+
+ if Present (Insert_Node) then
+ Insert_Action (Insert_Node, R_Cno);
+ else
+ Insert_Action (Expr, R_Cno);
+ end if;
+
+ -- The triggering condition evaluates to True, the range check
+ -- can be converted into a compile time constraint check.
+
+ if Is_Entity_Name (Cond)
+ and then Entity (Cond) = Standard_True
+ then
+ -- Since an N_Range is technically not an expression, we have
+ -- to set one of the bounds to C_E and then just flag the
+ -- N_Range. The warning message will point to the lower bound
+ -- and complain about a range, which seems OK.
+
+ if Nkind (Expr) = N_Range then
+ Apply_Compile_Time_Constraint_Error
+ (Low_Bound (Expr),
+ "static range out of bounds of}??",
+ CE_Range_Check_Failed,
+ Ent => Target_Typ,
+ Typ => Target_Typ);
+
+ Set_Raises_Constraint_Error (Expr);
+
+ else
+ Apply_Compile_Time_Constraint_Error
+ (Expr,
+ "static value out of range of}??",
+ CE_Range_Check_Failed,
+ Ent => Target_Typ,
+ Typ => Target_Typ);
+ end if;
+ end if;
+
+ -- The range check raises Constraint_Error explicitly
+
+ elsif Present (Insert_Node) then
+ R_Cno :=
+ Make_Raise_Constraint_Error (Sloc (Insert_Node),
+ Reason => CE_Range_Check_Failed);
+
+ Insert_Action (Insert_Node, R_Cno);
+
+ else
+ Install_Static_Check (R_Cno, Loc);
+ end if;
+ end loop;
end Apply_Range_Check;
------------------------------
@@ -3185,7 +3318,7 @@ package body Checks is
-- provide a wider range.
if not CodePeer_Mode
- or else Target_Typ /= RTE (RE_Priority)
+ or else not Is_RTE (Target_Typ, RE_Priority)
then
Bad_Value;
end if;
@@ -3263,7 +3396,7 @@ package body Checks is
----------------------------------
procedure Apply_Selected_Length_Checks
- (Ck_Node : Node_Id;
+ (Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Do_Static : Boolean)
@@ -3273,7 +3406,7 @@ package body Checks is
or else
not Length_Checks_Suppressed (Target_Typ);
- Loc : constant Source_Ptr := Sloc (Ck_Node);
+ Loc : constant Source_Ptr := Sloc (Expr);
Cond : Node_Id;
R_Cno : Node_Id;
@@ -3290,7 +3423,7 @@ package body Checks is
end if;
R_Result :=
- Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
+ Selected_Length_Checks (Expr, Target_Typ, Source_Typ, Empty);
for J in 1 .. 2 loop
R_Cno := R_Result (J);
@@ -3304,13 +3437,13 @@ package body Checks is
if Ekind (Current_Scope) = E_Package
and then Is_Compilation_Unit (Current_Scope)
then
- Ensure_Defined (Target_Typ, Ck_Node);
+ Ensure_Defined (Target_Typ, Expr);
if Present (Source_Typ) then
- Ensure_Defined (Source_Typ, Ck_Node);
+ Ensure_Defined (Source_Typ, Expr);
- elsif Is_Itype (Etype (Ck_Node)) then
- Ensure_Defined (Etype (Ck_Node), Ck_Node);
+ elsif Is_Itype (Etype (Expr)) then
+ Ensure_Defined (Etype (Expr), Expr);
end if;
end if;
@@ -3324,15 +3457,15 @@ package body Checks is
-- Case where node does not now have a dynamic check
- if not Has_Dynamic_Length_Check (Ck_Node) then
+ if not Has_Dynamic_Length_Check (Expr) then
-- If checks are on, just insert the check
if Checks_On then
- Insert_Action (Ck_Node, R_Cno);
+ Insert_Action (Expr, R_Cno);
if not Do_Static then
- Set_Has_Dynamic_Length_Check (Ck_Node);
+ Set_Has_Dynamic_Length_Check (Expr);
end if;
-- If checks are off, then analyze the length check after
@@ -3341,7 +3474,7 @@ package body Checks is
-- compile time warning in this case.
else
- Set_Parent (R_Cno, Ck_Node);
+ Set_Parent (R_Cno, Expr);
Analyze (R_Cno);
end if;
end if;
@@ -3352,7 +3485,7 @@ package body Checks is
and then Entity (Cond) = Standard_True
then
Apply_Compile_Time_Constraint_Error
- (Ck_Node, "wrong length for array of}??",
+ (Expr, "wrong length for array of}??",
CE_Length_Check_Failed,
Ent => Target_Typ,
Typ => Target_Typ);
@@ -3372,119 +3505,6 @@ package body Checks is
end loop;
end Apply_Selected_Length_Checks;
- ---------------------------------
- -- Apply_Selected_Range_Checks --
- ---------------------------------
-
- procedure Apply_Selected_Range_Checks
- (Ck_Node : Node_Id;
- Target_Typ : Entity_Id;
- Source_Typ : Entity_Id;
- Do_Static : Boolean)
- is
- Checks_On : constant Boolean :=
- not Index_Checks_Suppressed (Target_Typ)
- or else
- not Range_Checks_Suppressed (Target_Typ);
-
- Loc : constant Source_Ptr := Sloc (Ck_Node);
-
- Cond : Node_Id;
- R_Cno : Node_Id;
- R_Result : Check_Result;
-
- begin
- -- Only apply checks when generating code. In GNATprove mode, we do not
- -- apply the checks, but we still call Selected_Range_Checks to possibly
- -- issue errors on SPARK code when a run-time error can be detected at
- -- compile time.
-
- if not GNATprove_Mode then
- if not Expander_Active or not Checks_On then
- return;
- end if;
- end if;
-
- R_Result :=
- Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
-
- if GNATprove_Mode then
- return;
- end if;
-
- for J in 1 .. 2 loop
- R_Cno := R_Result (J);
- exit when No (R_Cno);
-
- -- The range check requires runtime evaluation. Depending on what its
- -- triggering condition is, the check may be converted into a compile
- -- time constraint check.
-
- if Nkind (R_Cno) = N_Raise_Constraint_Error
- and then Present (Condition (R_Cno))
- then
- Cond := Condition (R_Cno);
-
- -- Insert the range check before the related context. Note that
- -- this action analyses the triggering condition.
-
- Insert_Action (Ck_Node, R_Cno);
-
- -- This old code doesn't make sense, why is the context flagged as
- -- requiring dynamic range checks now in the middle of generating
- -- them ???
-
- if not Do_Static then
- Set_Has_Dynamic_Range_Check (Ck_Node);
- end if;
-
- -- The triggering condition evaluates to True, the range check
- -- can be converted into a compile time constraint check.
-
- if Is_Entity_Name (Cond)
- and then Entity (Cond) = Standard_True
- then
- -- Since an N_Range is technically not an expression, we have
- -- to set one of the bounds to C_E and then just flag the
- -- N_Range. The warning message will point to the lower bound
- -- and complain about a range, which seems OK.
-
- if Nkind (Ck_Node) = N_Range then
- Apply_Compile_Time_Constraint_Error
- (Low_Bound (Ck_Node),
- "static range out of bounds of}??",
- CE_Range_Check_Failed,
- Ent => Target_Typ,
- Typ => Target_Typ);
-
- Set_Raises_Constraint_Error (Ck_Node);
-
- else
- Apply_Compile_Time_Constraint_Error
- (Ck_Node,
- "static value out of range of}??",
- CE_Range_Check_Failed,
- Ent => Target_Typ,
- Typ => Target_Typ);
- end if;
-
- -- If we were only doing a static check, or if checks are not
- -- on, then we want to delete the check, since it is not needed.
- -- We do this by replacing the if statement by a null statement
-
- elsif Do_Static then
- Remove_Warning_Messages (R_Cno);
- Rewrite (R_Cno, Make_Null_Statement (Loc));
- end if;
-
- -- The range check raises Constraint_Error explicitly
-
- else
- Install_Static_Check (R_Cno, Loc);
- end if;
- end loop;
- end Apply_Selected_Range_Checks;
-
-------------------------------
-- Apply_Static_Length_Check --
-------------------------------
@@ -3523,7 +3543,7 @@ package body Checks is
-- Move to next subscript
- Sub := Next (Sub);
+ Next (Sub);
end loop;
end Apply_Subscript_Validity_Checks;
@@ -3787,6 +3807,11 @@ package body Checks is
if Inside_A_Generic then
return;
+ -- Nothing to do if the result type is universal integer
+
+ elsif Typ = Universal_Integer then
+ return;
+
-- Nothing to do if checks are suppressed
elsif Range_Checks_Suppressed (Typ)
@@ -3956,6 +3981,15 @@ package body Checks is
Duplicate_Subexpr_No_Checks
(Aggregate_Discriminant_Val (Disc_Ent));
+ elsif Is_Access_Type (Etype (N)) then
+ Dref :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Explicit_Dereference (Loc,
+ Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
+ Selector_Name => Make_Identifier (Loc, Chars (Disc_Ent)));
+
+ Set_Is_In_Discriminant_Check (Dref);
else
Dref :=
Make_Selected_Component (Loc,
@@ -4002,9 +4036,9 @@ package body Checks is
function Left_Expression (Op : Node_Id) return Node_Id is
LE : Node_Id := Left_Opnd (Op);
begin
- while Nkind_In (LE, N_Qualified_Expression,
- N_Type_Conversion,
- N_Expression_With_Actions)
+ while Nkind (LE) in N_Qualified_Expression
+ | N_Type_Conversion
+ | N_Expression_With_Actions
loop
LE := Expression (LE);
end loop;
@@ -4214,11 +4248,11 @@ package body Checks is
begin
pragma Assert
- (Nkind_In (Kind, N_Component_Declaration,
- N_Discriminant_Specification,
- N_Function_Specification,
- N_Object_Declaration,
- N_Parameter_Specification));
+ (Kind in N_Component_Declaration
+ | N_Discriminant_Specification
+ | N_Function_Specification
+ | N_Object_Declaration
+ | N_Parameter_Specification);
if Kind = N_Function_Specification then
Typ := Etype (Defining_Entity (N));
@@ -4367,6 +4401,307 @@ package body Checks is
end if;
end Null_Exclusion_Static_Checks;
+ -------------------------------------
+ -- Compute_Range_For_Arithmetic_Op --
+ -------------------------------------
+
+ procedure Compute_Range_For_Arithmetic_Op
+ (Op : Node_Kind;
+ Lo_Left : Uint;
+ Hi_Left : Uint;
+ Lo_Right : Uint;
+ Hi_Right : Uint;
+ OK : out Boolean;
+ Lo : out Uint;
+ Hi : out Uint)
+ is
+ -- Use local variables for possible adjustments
+
+ Llo : Uint renames Lo_Left;
+ Lhi : Uint renames Hi_Left;
+ Rlo : Uint := Lo_Right;
+ Rhi : Uint := Hi_Right;
+
+ begin
+ -- We will compute a range for the result in almost all cases
+
+ OK := True;
+
+ case Op is
+
+ -- Absolute value
+
+ when N_Op_Abs =>
+ Lo := Uint_0;
+ Hi := UI_Max (abs Rlo, abs Rhi);
+
+ -- Addition
+
+ when N_Op_Add =>
+ Lo := Llo + Rlo;
+ Hi := Lhi + Rhi;
+
+ -- Division
+
+ when N_Op_Divide =>
+
+ -- If the right operand can only be zero, set 0..0
+
+ if Rlo = 0 and then Rhi = 0 then
+ Lo := Uint_0;
+ Hi := Uint_0;
+
+ -- Possible bounds of division must come from dividing end
+ -- values of the input ranges (four possibilities), provided
+ -- zero is not included in the possible values of the right
+ -- operand.
+
+ -- Otherwise, we just consider two intervals of values for
+ -- the right operand: the interval of negative values (up to
+ -- -1) and the interval of positive values (starting at 1).
+ -- Since division by 1 is the identity, and division by -1
+ -- is negation, we get all possible bounds of division in that
+ -- case by considering:
+ -- - all values from the division of end values of input
+ -- ranges;
+ -- - the end values of the left operand;
+ -- - the negation of the end values of the left operand.
+
+ else
+ declare
+ Mrk : constant Uintp.Save_Mark := Mark;
+ -- Mark so we can release the RR and Ev values
+
+ Ev1 : Uint;
+ Ev2 : Uint;
+ Ev3 : Uint;
+ Ev4 : Uint;
+
+ begin
+ -- Discard extreme values of zero for the divisor, since
+ -- they will simply result in an exception in any case.
+
+ if Rlo = 0 then
+ Rlo := Uint_1;
+ elsif Rhi = 0 then
+ Rhi := -Uint_1;
+ end if;
+
+ -- Compute possible bounds coming from dividing end
+ -- values of the input ranges.
+
+ Ev1 := Llo / Rlo;
+ Ev2 := Llo / Rhi;
+ Ev3 := Lhi / Rlo;
+ Ev4 := Lhi / Rhi;
+
+ Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4));
+ Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4));
+
+ -- If the right operand can be both negative or positive,
+ -- include the end values of the left operand in the
+ -- extreme values, as well as their negation.
+
+ if Rlo < 0 and then Rhi > 0 then
+ Ev1 := Llo;
+ Ev2 := -Llo;
+ Ev3 := Lhi;
+ Ev4 := -Lhi;
+
+ Lo := UI_Min (Lo,
+ UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4)));
+ Hi := UI_Max (Hi,
+ UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4)));
+ end if;
+
+ -- Release the RR and Ev values
+
+ Release_And_Save (Mrk, Lo, Hi);
+ end;
+ end if;
+
+ -- Exponentiation
+
+ when N_Op_Expon =>
+
+ -- Discard negative values for the exponent, since they will
+ -- simply result in an exception in any case.
+
+ if Rhi < 0 then
+ Rhi := Uint_0;
+ elsif Rlo < 0 then
+ Rlo := Uint_0;
+ end if;
+
+ -- Estimate number of bits in result before we go computing
+ -- giant useless bounds. Basically the number of bits in the
+ -- result is the number of bits in the base multiplied by the
+ -- value of the exponent. If this is big enough that the result
+ -- definitely won't fit in Long_Long_Integer, return immediately
+ -- and avoid computing giant bounds.
+
+ -- The comparison here is approximate, but conservative, it
+ -- only clicks on cases that are sure to exceed the bounds.
+
+ if Num_Bits (UI_Max (abs Llo, abs Lhi)) * Rhi + 1 > 100 then
+ Lo := No_Uint;
+ Hi := No_Uint;
+ OK := False;
+ return;
+
+ -- If right operand is zero then result is 1
+
+ elsif Rhi = 0 then
+ Lo := Uint_1;
+ Hi := Uint_1;
+
+ else
+ -- High bound comes either from exponentiation of largest
+ -- positive value to largest exponent value, or from
+ -- the exponentiation of most negative value to an
+ -- even exponent.
+
+ declare
+ Hi1, Hi2 : Uint;
+
+ begin
+ if Lhi > 0 then
+ Hi1 := Lhi ** Rhi;
+ else
+ Hi1 := Uint_0;
+ end if;
+
+ if Llo < 0 then
+ if Rhi mod 2 = 0 then
+ Hi2 := Llo ** Rhi;
+ else
+ Hi2 := Llo ** (Rhi - 1);
+ end if;
+ else
+ Hi2 := Uint_0;
+ end if;
+
+ Hi := UI_Max (Hi1, Hi2);
+ end;
+
+ -- Result can only be negative if base can be negative
+
+ if Llo < 0 then
+ if Rhi mod 2 = 0 then
+ Lo := Llo ** (Rhi - 1);
+ else
+ Lo := Llo ** Rhi;
+ end if;
+
+ -- Otherwise low bound is minimum ** minimum
+
+ else
+ Lo := Llo ** Rlo;
+ end if;
+ end if;
+
+ -- Negation
+
+ when N_Op_Minus =>
+ Lo := -Rhi;
+ Hi := -Rlo;
+
+ -- Mod
+
+ when N_Op_Mod =>
+ declare
+ Maxabs : constant Uint := UI_Max (abs Rlo, abs Rhi) - 1;
+ -- This is the maximum absolute value of the result
+
+ begin
+ Lo := Uint_0;
+ Hi := Uint_0;
+
+ -- The result depends only on the sign and magnitude of
+ -- the right operand, it does not depend on the sign or
+ -- magnitude of the left operand.
+
+ if Rlo < 0 then
+ Lo := -Maxabs;
+ end if;
+
+ if Rhi > 0 then
+ Hi := Maxabs;
+ end if;
+ end;
+
+ -- Multiplication
+
+ when N_Op_Multiply =>
+
+ -- Possible bounds of multiplication must come from multiplying
+ -- end values of the input ranges (four possibilities).
+
+ declare
+ Mrk : constant Uintp.Save_Mark := Mark;
+ -- Mark so we can release the Ev values
+
+ Ev1 : constant Uint := Llo * Rlo;
+ Ev2 : constant Uint := Llo * Rhi;
+ Ev3 : constant Uint := Lhi * Rlo;
+ Ev4 : constant Uint := Lhi * Rhi;
+
+ begin
+ Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4));
+ Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4));
+
+ -- Release the Ev values
+
+ Release_And_Save (Mrk, Lo, Hi);
+ end;
+
+ -- Plus operator (affirmation)
+
+ when N_Op_Plus =>
+ Lo := Rlo;
+ Hi := Rhi;
+
+ -- Remainder
+
+ when N_Op_Rem =>
+ declare
+ Maxabs : constant Uint := UI_Max (abs Rlo, abs Rhi) - 1;
+ -- This is the maximum absolute value of the result. Note
+ -- that the result range does not depend on the sign of the
+ -- right operand.
+
+ begin
+ Lo := Uint_0;
+ Hi := Uint_0;
+
+ -- Case of left operand negative, which results in a range
+ -- of -Maxabs .. 0 for those negative values. If there are
+ -- no negative values then Lo value of result is always 0.
+
+ if Llo < 0 then
+ Lo := -Maxabs;
+ end if;
+
+ -- Case of left operand positive
+
+ if Lhi > 0 then
+ Hi := Maxabs;
+ end if;
+ end;
+
+ -- Subtract
+
+ when N_Op_Subtract =>
+ Lo := Llo - Rhi;
+ Hi := Lhi - Rlo;
+
+ -- Nothing else should be possible
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end Compute_Range_For_Arithmetic_Op;
+
----------------------------------
-- Conditional_Statements_Begin --
----------------------------------
@@ -4480,6 +4815,7 @@ package body Checks is
-- Determine size of below cache (power of 2 is more efficient)
Determine_Range_Cache_N : array (Cache_Index) of Node_Id;
+ Determine_Range_Cache_O : array (Cache_Index) of Node_Id;
Determine_Range_Cache_V : array (Cache_Index) of Boolean;
Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
Determine_Range_Cache_Hi : array (Cache_Index) of Uint;
@@ -4491,7 +4827,9 @@ package body Checks is
-- checking calls the routine on the way up the tree, a quadratic behavior
-- can otherwise be encountered in large expressions. The cache entry for
-- node N is stored in the (N mod Cache_Size) entry, and can be validated
- -- by checking the actual node value stored there. The Range_Cache_V array
+ -- by checking the actual node value stored there. The Range_Cache_O array
+ -- records the setting of Original_Node (N) so that the cache entry does
+ -- not become stale when the node N is rewritten. The Range_Cache_V array
-- records the setting of Assume_Valid for the cache entry.
procedure Determine_Range
@@ -4501,11 +4839,30 @@ package body Checks is
Hi : out Uint;
Assume_Valid : Boolean := False)
is
+ Kind : constant Node_Kind := Nkind (N);
+ -- Kind of node
+
+ function Half_Address_Space return Uint;
+ -- The size of half the total addressable memory space in storage units
+ -- (minus one, so that the size fits in a signed integer whose size is
+ -- System_Address_Size, which helps in various cases).
+
+ ------------------------
+ -- Half_Address_Space --
+ ------------------------
+
+ function Half_Address_Space return Uint is
+ begin
+ return Uint_2 ** (System_Address_Size - 1) - 1;
+ end Half_Address_Space;
+
+ -- Local variables
+
Typ : Entity_Id := Etype (N);
-- Type to use, may get reset to base type for possibly invalid entity
- Lo_Left : Uint;
- Hi_Left : Uint;
+ Lo_Left : Uint := No_Uint;
+ Hi_Left : Uint := No_Uint;
-- Lo and Hi bounds of left operand
Lo_Right : Uint := No_Uint;
@@ -4531,29 +4888,6 @@ package body Checks is
Btyp : Entity_Id;
-- Base type
- function OK_Operands return Boolean;
- -- Used for binary operators. Determines the ranges of the left and
- -- right operands, and if they are both OK, returns True, and puts
- -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
-
- -----------------
- -- OK_Operands --
- -----------------
-
- function OK_Operands return Boolean is
- begin
- Determine_Range
- (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid);
-
- if not OK1 then
- return False;
- end if;
-
- Determine_Range
- (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
- return OK1;
- end OK_Operands;
-
-- Start of processing for Determine_Range
begin
@@ -4631,6 +4965,8 @@ package body Checks is
if Determine_Range_Cache_N (Cindex) = N
and then
+ Determine_Range_Cache_O (Cindex) = Original_Node (N)
+ and then
Determine_Range_Cache_V (Cindex) = Assume_Valid
then
Lo := Determine_Range_Cache_Lo (Cindex);
@@ -4686,7 +5022,7 @@ package body Checks is
-- corresponding base type bound if possible. If we can't get a bound
-- then we figure we can't determine the range (a peculiar case, that
-- perhaps cannot happen, but there is no point in bombing in this
- -- optimization circuit.
+ -- optimization circuit).
-- First the low bound
@@ -4731,198 +5067,142 @@ package body Checks is
-- refinement is possible, then Lor and Hir are set to possibly tighter
-- bounds, and OK1 is set to True.
- case Nkind (N) is
-
- -- For unary plus, result is limited by range of operand
-
- when N_Op_Plus =>
- Determine_Range
- (Right_Opnd (N), OK1, Lor, Hir, Assume_Valid);
+ case Kind is
- -- For unary minus, determine range of operand, and negate it
+ -- Unary operation case
- when N_Op_Minus =>
+ when N_Op_Abs
+ | N_Op_Minus
+ | N_Op_Plus
+ =>
Determine_Range
(Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
if OK1 then
- Lor := -Hi_Right;
- Hir := -Lo_Right;
- end if;
-
- -- For binary addition, get range of each operand and do the
- -- addition to get the result range.
-
- when N_Op_Add =>
- if OK_Operands then
- Lor := Lo_Left + Lo_Right;
- Hir := Hi_Left + Hi_Right;
+ Compute_Range_For_Arithmetic_Op
+ (Kind, Lo_Left, Hi_Left, Lo_Right, Hi_Right, OK1, Lor, Hir);
end if;
- -- Division is tricky. The only case we consider is where the right
- -- operand is a positive constant, and in this case we simply divide
- -- the bounds of the left operand
+ -- Binary operation case
- when N_Op_Divide =>
- if OK_Operands then
- if Lo_Right = Hi_Right
- and then Lo_Right > 0
- then
- Lor := Lo_Left / Lo_Right;
- Hir := Hi_Left / Lo_Right;
- else
- OK1 := False;
- end if;
- end if;
-
- -- For binary subtraction, get range of each operand and do the worst
- -- case subtraction to get the result range.
+ when N_Op_Add
+ | N_Op_Divide
+ | N_Op_Expon
+ | N_Op_Mod
+ | N_Op_Multiply
+ | N_Op_Rem
+ | N_Op_Subtract
+ =>
+ Determine_Range
+ (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid);
- when N_Op_Subtract =>
- if OK_Operands then
- Lor := Lo_Left - Hi_Right;
- Hir := Hi_Left - Lo_Right;
+ if OK1 then
+ Determine_Range
+ (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
end if;
- -- For MOD, if right operand is a positive constant, then result must
- -- be in the allowable range of mod results.
-
- when N_Op_Mod =>
- if OK_Operands then
- if Lo_Right = Hi_Right
- and then Lo_Right /= 0
- then
- if Lo_Right > 0 then
- Lor := Uint_0;
- Hir := Lo_Right - 1;
-
- else -- Lo_Right < 0
- Lor := Lo_Right + 1;
- Hir := Uint_0;
- end if;
-
- else
- OK1 := False;
- end if;
+ if OK1 then
+ Compute_Range_For_Arithmetic_Op
+ (Kind, Lo_Left, Hi_Left, Lo_Right, Hi_Right, OK1, Lor, Hir);
end if;
- -- For REM, if right operand is a positive constant, then result must
- -- be in the allowable range of mod results.
-
- when N_Op_Rem =>
- if OK_Operands then
- if Lo_Right = Hi_Right and then Lo_Right /= 0 then
- declare
- Dval : constant Uint := (abs Lo_Right) - 1;
-
- begin
- -- The sign of the result depends on the sign of the
- -- dividend (but not on the sign of the divisor, hence
- -- the abs operation above).
+ -- Attribute reference cases
- if Lo_Left < 0 then
- Lor := -Dval;
- else
- Lor := Uint_0;
- end if;
+ when N_Attribute_Reference =>
+ case Get_Attribute_Id (Attribute_Name (N)) is
- if Hi_Left < 0 then
- Hir := Uint_0;
- else
- Hir := Dval;
- end if;
- end;
+ -- For Min/Max attributes, we can refine the range using the
+ -- possible range of values of the attribute expressions.
- else
- OK1 := False;
- end if;
- end if;
+ when Attribute_Min
+ | Attribute_Max
+ =>
+ Determine_Range
+ (First (Expressions (N)),
+ OK1, Lo_Left, Hi_Left, Assume_Valid);
- -- Attribute reference cases
+ if OK1 then
+ Determine_Range
+ (Next (First (Expressions (N))),
+ OK1, Lo_Right, Hi_Right, Assume_Valid);
+ end if;
- when N_Attribute_Reference =>
- case Attribute_Name (N) is
+ if OK1 then
+ Lor := UI_Min (Lo_Left, Lo_Right);
+ Hir := UI_Max (Hi_Left, Hi_Right);
+ end if;
-- For Pos/Val attributes, we can refine the range using the
-- possible range of values of the attribute expression.
- when Name_Pos
- | Name_Val
+ when Attribute_Pos
+ | Attribute_Val
=>
Determine_Range
(First (Expressions (N)), OK1, Lor, Hir, Assume_Valid);
- -- For Length attribute, use the bounds of the corresponding
- -- index type to refine the range.
+ -- For Length and Range_Length attributes, use the bounds of
+ -- the (corresponding index) type to refine the range.
- when Name_Length =>
+ when Attribute_Length
+ | Attribute_Range_Length
+ =>
declare
- Atyp : Entity_Id := Etype (Prefix (N));
- Inum : Nat;
- Indx : Node_Id;
+ Ptyp : Entity_Id;
+ Ityp : Entity_Id;
LL, LU : Uint;
UL, UU : Uint;
begin
- if Is_Access_Type (Atyp) then
- Atyp := Designated_Type (Atyp);
+ Ptyp := Etype (Prefix (N));
+ if Is_Access_Type (Ptyp) then
+ Ptyp := Designated_Type (Ptyp);
end if;
-- For string literal, we know exact value
- if Ekind (Atyp) = E_String_Literal_Subtype then
+ if Ekind (Ptyp) = E_String_Literal_Subtype then
OK := True;
- Lo := String_Literal_Length (Atyp);
- Hi := String_Literal_Length (Atyp);
+ Lo := String_Literal_Length (Ptyp);
+ Hi := String_Literal_Length (Ptyp);
return;
end if;
- -- Otherwise check for expression given
-
- if No (Expressions (N)) then
- Inum := 1;
+ if Is_Array_Type (Ptyp) then
+ Ityp := Get_Index_Subtype (N);
else
- Inum :=
- UI_To_Int (Expr_Value (First (Expressions (N))));
+ Ityp := Ptyp;
end if;
- Indx := First_Index (Atyp);
- for J in 2 .. Inum loop
- Indx := Next_Index (Indx);
- end loop;
-
- -- If the index type is a formal type or derived from
+ -- If the (index) type is a formal type or derived from
-- one, the bounds are not static.
- if Is_Generic_Type (Root_Type (Etype (Indx))) then
+ if Is_Generic_Type (Root_Type (Ityp)) then
OK := False;
return;
end if;
Determine_Range
- (Type_Low_Bound (Etype (Indx)), OK1, LL, LU,
- Assume_Valid);
+ (Type_Low_Bound (Ityp), OK1, LL, LU, Assume_Valid);
if OK1 then
Determine_Range
- (Type_High_Bound (Etype (Indx)), OK1, UL, UU,
- Assume_Valid);
+ (Type_High_Bound (Ityp), OK1, UL, UU, Assume_Valid);
if OK1 then
-
-- The maximum value for Length is the biggest
-- possible gap between the values of the bounds.
-- But of course, this value cannot be negative.
Hir := UI_Max (Uint_0, UU - LL + 1);
- -- For constrained arrays, the minimum value for
+ -- For a constrained array, the minimum value for
-- Length is taken from the actual value of the
-- bounds, since the index will be exactly of this
-- subtype.
- if Is_Constrained (Atyp) then
+ if Is_Constrained (Ptyp) then
Lor := UI_Max (Uint_0, UL - LU + 1);
-- For an unconstrained array, the minimum value
@@ -4933,6 +5213,95 @@ package body Checks is
end if;
end if;
end if;
+
+ -- Small optimization: the maximum size in storage units
+ -- an object can have with GNAT is half of the address
+ -- space, so we can bound the length of an array declared
+ -- in Interfaces (or its children) because its component
+ -- size is at least the storage unit and it is meant to
+ -- be used to interface actual array objects.
+
+ if Is_Array_Type (Ptyp) then
+ declare
+ S : constant Entity_Id := Scope (Base_Type (Ptyp));
+ begin
+ if Is_RTU (S, Interfaces)
+ or else (S /= Standard_Standard
+ and then Is_RTU (Scope (S), Interfaces))
+ then
+ Hir := UI_Min (Hir, Half_Address_Space);
+ end if;
+ end;
+ end if;
+ end;
+
+ -- The maximum default alignment is quite low, but GNAT accepts
+ -- alignment clauses that are fairly large, but not as large as
+ -- the maximum size of objects, see below.
+
+ when Attribute_Alignment =>
+ Lor := Uint_0;
+ Hir := Half_Address_Space;
+ OK1 := True;
+
+ -- The attribute should have been folded if a component clause
+ -- was specified, so we assume there is none.
+
+ when Attribute_Bit
+ | Attribute_First_Bit
+ =>
+ Lor := Uint_0;
+ Hir := UI_From_Int (System_Storage_Unit - 1);
+ OK1 := True;
+
+ -- Likewise about the component clause. Note that Last_Bit
+ -- yields -1 for a field of size 0 if First_Bit is 0.
+
+ when Attribute_Last_Bit =>
+ Lor := Uint_Minus_1;
+ Hir := Hi;
+ OK1 := True;
+
+ -- Likewise about the component clause for Position. The
+ -- maximum size in storage units that an object can have
+ -- with GNAT is half of the address space.
+
+ when Attribute_Max_Size_In_Storage_Elements
+ | Attribute_Position
+ =>
+ Lor := Uint_0;
+ Hir := Half_Address_Space;
+ OK1 := True;
+
+ -- These attributes yield a nonnegative value (we do not set
+ -- the maximum value because it is too large to be useful).
+
+ when Attribute_Bit_Position
+ | Attribute_Component_Size
+ | Attribute_Object_Size
+ | Attribute_Size
+ | Attribute_Value_Size
+ =>
+ Lor := Uint_0;
+ Hir := Hi;
+ OK1 := True;
+
+ -- The maximum size is the sum of twice the size of the largest
+ -- integer for every dimension, rounded up to the next multiple
+ -- of the maximum alignment, but we add instead of rounding.
+
+ when Attribute_Descriptor_Size =>
+ declare
+ Max_Align : constant Pos :=
+ Maximum_Alignment * System_Storage_Unit;
+ Max_Size : constant Uint :=
+ 2 * Esize (Universal_Integer);
+ Ndims : constant Pos :=
+ Number_Dimensions (Etype (Prefix (N)));
+ begin
+ Lor := Uint_0;
+ Hir := Max_Size * Ndims + Max_Align;
+ OK1 := True;
end;
-- No special handling for other attributes
@@ -5018,6 +5387,7 @@ package body Checks is
-- Set cache entry for future call and we are all done
Determine_Range_Cache_N (Cindex) := N;
+ Determine_Range_Cache_O (Cindex) := Original_Node (N);
Determine_Range_Cache_V (Cindex) := Assume_Valid;
Determine_Range_Cache_Lo (Cindex) := Lo;
Determine_Range_Cache_Hi (Cindex) := Hi;
@@ -5194,6 +5564,8 @@ package body Checks is
if Determine_Range_Cache_N (Cindex) = N
and then
+ Determine_Range_Cache_O (Cindex) = Original_Node (N)
+ and then
Determine_Range_Cache_V (Cindex) = Assume_Valid
then
Lo := Determine_Range_Cache_Lo_R (Cindex);
@@ -5465,6 +5837,7 @@ package body Checks is
-- Set cache entry for future call and we are all done
Determine_Range_Cache_N (Cindex) := N;
+ Determine_Range_Cache_O (Cindex) := Original_Node (N);
Determine_Range_Cache_V (Cindex) := Assume_Valid;
Determine_Range_Cache_Lo_R (Cindex) := Lo;
Determine_Range_Cache_Hi_R (Cindex) := Hi;
@@ -5678,9 +6051,9 @@ package body Checks is
Do_Ovflow_Check := False;
-- Despite the comments above, it is worth dealing specially with
- -- division specially. The only case where integer division can
- -- overflow is (largest negative number) / (-1). So we will do
- -- an extra range analysis to see if this is possible.
+ -- division. The only case where integer division can overflow is
+ -- (largest negative number) / (-1). So we will do an extra range
+ -- analysis to see if this is possible.
elsif Nkind (N) = N_Op_Divide then
Determine_Range
@@ -5700,6 +6073,17 @@ package body Checks is
Do_Ovflow_Check := False;
end if;
end if;
+
+ -- Likewise for Abs/Minus, the only case where the operation can
+ -- overflow is when the operand is the largest negative number.
+
+ elsif Nkind (N) in N_Op_Abs | N_Op_Minus then
+ Determine_Range
+ (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
+
+ if OK and then Lo > Expr_Value (Type_Low_Bound (Typ)) then
+ Do_Ovflow_Check := False;
+ end if;
end if;
-- If no overflow check required, we are done
@@ -5835,7 +6219,7 @@ package body Checks is
-- Do not set range check flag if parent is assignment statement or
-- object declaration with Suppress_Assignment_Checks flag set
- if Nkind_In (Parent (N), N_Assignment_Statement, N_Object_Declaration)
+ if Nkind (Parent (N)) in N_Assignment_Statement | N_Object_Declaration
and then Suppress_Assignment_Checks (Parent (N))
then
return;
@@ -6196,9 +6580,9 @@ package body Checks is
-- If this is an indirect or dispatching call, get signature
-- from the subprogram type.
- if Nkind_In (P, N_Entry_Call_Statement,
- N_Function_Call,
- N_Procedure_Call_Statement)
+ if Nkind (P) in N_Entry_Call_Statement
+ | N_Function_Call
+ | N_Procedure_Call_Statement
then
E := Get_Called_Entity (P);
L := Parameter_Associations (P);
@@ -6329,13 +6713,13 @@ package body Checks is
-- Integer and character literals always have valid values, where
-- appropriate these will be range checked in any case.
- elsif Nkind_In (Expr, N_Integer_Literal, N_Character_Literal) then
+ elsif Nkind (Expr) in N_Integer_Literal | N_Character_Literal then
return True;
-- If we have a type conversion or a qualification of a known valid
-- value, then the result will always be valid.
- elsif Nkind_In (Expr, N_Type_Conversion, N_Qualified_Expression) then
+ elsif Nkind (Expr) in N_Type_Conversion | N_Qualified_Expression then
return Expr_Known_Valid (Expression (Expr));
-- Case of expression is a non-floating-point operator. In this case we
@@ -6515,9 +6899,6 @@ package body Checks is
-- Generate_Discriminant_Check --
---------------------------------
- -- Note: the code for this procedure is derived from the
- -- Emit_Discriminant_Check Routine in trans.c.
-
procedure Generate_Discriminant_Check (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Pref : constant Node_Id := Prefix (N);
@@ -6677,9 +7058,7 @@ package body Checks is
begin
P := Prefix (N);
while not Is_Entity_Name (P) loop
- if not Nkind_In (P, N_Selected_Component,
- N_Indexed_Component)
- then
+ if Nkind (P) not in N_Selected_Component | N_Indexed_Component then
return Empty;
end if;
@@ -6767,9 +7146,9 @@ package body Checks is
else
declare
- A_Idx : Node_Id := Empty;
+ A_Idx : Node_Id;
A_Range : Node_Id;
- Ind : Nat;
+ Ind : Pos;
Num : List_Id;
Range_N : Node_Id;
@@ -6792,11 +7171,13 @@ package body Checks is
if Nkind (A_Idx) = N_Range then
A_Range := A_Idx;
- elsif Nkind (A_Idx) = N_Identifier
- or else Nkind (A_Idx) = N_Expanded_Name
- then
+ elsif Nkind (A_Idx) in N_Identifier | N_Expanded_Name then
A_Range := Scalar_Range (Entity (A_Idx));
+ if Nkind (A_Range) = N_Subtype_Indication then
+ A_Range := Range_Expression (Constraint (A_Range));
+ end if;
+
else pragma Assert (Nkind (A_Idx) = N_Subtype_Indication);
A_Range := Range_Expression (Constraint (A_Idx));
end if;
@@ -6847,7 +7228,7 @@ package body Checks is
Reason => CE_Index_Check_Failed));
end if;
- A_Idx := Next_Index (A_Idx);
+ Next_Index (A_Idx);
Ind := Ind + 1;
Next (Sub);
end loop;
@@ -6875,6 +7256,10 @@ package body Checks is
-- given Suppress argument. Then check the converted value against the
-- range of the target subtype.
+ function Is_Single_Attribute_Reference (N : Node_Id) return Boolean;
+ -- Return True if N is an expression that contains a single attribute
+ -- reference, possibly as operand among only integer literal operands.
+
-----------------------------
-- Convert_And_Check_Range --
-----------------------------
@@ -6934,6 +7319,31 @@ package body Checks is
Set_Etype (N, Target_Base_Type);
end Convert_And_Check_Range;
+ -------------------------------------
+ -- Is_Single_Attribute_Reference --
+ -------------------------------------
+
+ function Is_Single_Attribute_Reference (N : Node_Id) return Boolean is
+ begin
+ if Nkind (N) = N_Attribute_Reference then
+ return True;
+
+ elsif Nkind (N) in N_Binary_Op then
+ if Nkind (Right_Opnd (N)) = N_Integer_Literal then
+ return Is_Single_Attribute_Reference (Left_Opnd (N));
+
+ elsif Nkind (Left_Opnd (N)) = N_Integer_Literal then
+ return Is_Single_Attribute_Reference (Right_Opnd (N));
+
+ else
+ return False;
+ end if;
+
+ else
+ return False;
+ end if;
+ end Is_Single_Attribute_Reference;
+
-- Start of processing for Generate_Range_Check
begin
@@ -6949,7 +7359,8 @@ package body Checks is
-- the target.
and then not
- (Nkind_In (N, N_Integer_Literal, N_Real_Literal, N_Character_Literal)
+ (Nkind (N) in
+ N_Integer_Literal | N_Real_Literal | N_Character_Literal
or else
(Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_Enumeration_Literal))
@@ -6958,12 +7369,12 @@ package body Checks is
return;
end if;
- -- Here a check is needed. If the expander is not active, or if we are
- -- in GNATProve mode, then simply set the Do_Range_Check flag and we
- -- are done. In both these cases, we just want to see the range check
- -- flag set, we do not want to generate the explicit range check code.
+ -- Here a check is needed. If the expander is not active (which is also
+ -- the case in GNATprove mode), then simply set the Do_Range_Check flag
+ -- and we are done. We just want to see the range check flag set, we do
+ -- not want to generate the explicit range check code.
- if GNATprove_Mode or else not Expander_Active then
+ if not Expander_Active then
Set_Do_Range_Check (N);
return;
end if;
@@ -6982,9 +7393,10 @@ package body Checks is
-- We skip the evaluation of attribute references because, after these
-- runtime checks are generated, the expander may need to rewrite this
-- node (for example, see Attribute_Max_Size_In_Storage_Elements in
- -- Expand_N_Attribute_Reference).
+ -- Expand_N_Attribute_Reference) and, in many cases, their return type
+ -- is universal integer, which is a very large type for a temporary.
- if Nkind (N) /= N_Attribute_Reference
+ if not Is_Single_Attribute_Reference (N)
and then (not Is_Entity_Name (N)
or else Treat_As_Volatile (Entity (N)))
then
@@ -7331,14 +7743,14 @@ package body Checks is
----------------------
function Get_Range_Checks
- (Ck_Node : Node_Id;
+ (Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty;
Warn_Node : Node_Id := Empty) return Check_Result
is
begin
return
- Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
+ Selected_Range_Checks (Expr, Target_Typ, Source_Typ, Warn_Node);
end Get_Range_Checks;
------------------
@@ -7346,16 +7758,16 @@ package body Checks is
------------------
function Guard_Access
- (Cond : Node_Id;
- Loc : Source_Ptr;
- Ck_Node : Node_Id) return Node_Id
+ (Cond : Node_Id;
+ Loc : Source_Ptr;
+ Expr : Node_Id) return Node_Id
is
begin
if Nkind (Cond) = N_Or_Else then
Set_Paren_Count (Cond, 1);
end if;
- if Nkind (Ck_Node) = N_Allocator then
+ if Nkind (Expr) = N_Allocator then
return Cond;
else
@@ -7363,7 +7775,7 @@ package body Checks is
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ne (Loc,
- Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Expr),
Right_Opnd => Make_Null (Loc)),
Right_Opnd => Cond);
end if;
@@ -7407,8 +7819,7 @@ package body Checks is
(Checks : Check_Result;
Node : Node_Id;
Suppress_Typ : Entity_Id;
- Static_Sloc : Source_Ptr := No_Location;
- Flag_Node : Node_Id := Empty;
+ Static_Sloc : Source_Ptr;
Do_Before : Boolean := False)
is
Checks_On : constant Boolean :=
@@ -7416,9 +7827,7 @@ package body Checks is
or else
not Range_Checks_Suppressed (Suppress_Typ);
- Check_Node : Node_Id;
- Internal_Flag_Node : Node_Id := Flag_Node;
- Internal_Static_Sloc : Source_Ptr := Static_Sloc;
+ Check_Node : Node_Id;
begin
-- For now we just return if Checks_On is false, however this should be
@@ -7429,44 +7838,25 @@ package body Checks is
return;
end if;
- if Static_Sloc = No_Location then
- Internal_Static_Sloc := Sloc (Node);
- end if;
-
- if No (Flag_Node) then
- Internal_Flag_Node := Node;
- end if;
-
for J in 1 .. 2 loop
exit when No (Checks (J));
if Nkind (Checks (J)) = N_Raise_Constraint_Error
and then Present (Condition (Checks (J)))
then
- if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
- Check_Node := Checks (J);
- Mark_Rewrite_Insertion (Check_Node);
-
- if Do_Before then
- Insert_Before_And_Analyze (Node, Check_Node);
- else
- Insert_After_And_Analyze (Node, Check_Node);
- end if;
-
- Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
- end if;
-
+ Check_Node := Checks (J);
else
Check_Node :=
- Make_Raise_Constraint_Error (Internal_Static_Sloc,
+ Make_Raise_Constraint_Error (Static_Sloc,
Reason => CE_Range_Check_Failed);
- Mark_Rewrite_Insertion (Check_Node);
+ end if;
- if Do_Before then
- Insert_Before_And_Analyze (Node, Check_Node);
- else
- Insert_After_And_Analyze (Node, Check_Node);
- end if;
+ Mark_Rewrite_Insertion (Check_Node);
+
+ if Do_Before then
+ Insert_Before_And_Analyze (Node, Check_Node);
+ else
+ Insert_After_And_Analyze (Node, Check_Node);
end if;
end loop;
end Insert_Range_Checks;
@@ -8064,7 +8454,7 @@ package body Checks is
-- Do not generate an elaboration check in compilation modes where
-- expansion is not desirable.
- if ASIS_Mode or GNATprove_Mode then
+ if GNATprove_Mode then
return;
-- Do not generate an elaboration check if all checks have been
@@ -8141,9 +8531,8 @@ package body Checks is
-- need to be called while elaboration is taking place.
elsif Is_Controlled (Tag_Typ)
- and then Nam_In (Chars (Subp_Id), Name_Adjust,
- Name_Finalize,
- Name_Initialize)
+ and then
+ Chars (Subp_Id) in Name_Adjust | Name_Finalize | Name_Initialize
then
return;
end if;
@@ -8740,8 +9129,7 @@ package body Checks is
else
declare
- Rtype : Entity_Id;
- pragma Warnings (Off, Rtype);
+ Rtype : Entity_Id := Empty;
New_Alts : List_Id;
New_Exp : Node_Id;
@@ -8771,6 +9159,7 @@ package body Checks is
Expression => Expression (N),
Alternatives => New_Alts));
+ pragma Assert (Present (Rtype));
Reanalyze (Rtype, Suppress => True);
end;
end if;
@@ -8811,279 +9200,9 @@ package body Checks is
-- Otherwise compute result range
else
+ Compute_Range_For_Arithmetic_Op
+ (Nkind (N), Llo, Lhi, Rlo, Rhi, OK, Lo, Hi);
Bignum_Operands := False;
-
- case Nkind (N) is
-
- -- Absolute value
-
- when N_Op_Abs =>
- Lo := Uint_0;
- Hi := UI_Max (abs Rlo, abs Rhi);
-
- -- Addition
-
- when N_Op_Add =>
- Lo := Llo + Rlo;
- Hi := Lhi + Rhi;
-
- -- Division
-
- when N_Op_Divide =>
-
- -- If the right operand can only be zero, set 0..0
-
- if Rlo = 0 and then Rhi = 0 then
- Lo := Uint_0;
- Hi := Uint_0;
-
- -- Possible bounds of division must come from dividing end
- -- values of the input ranges (four possibilities), provided
- -- zero is not included in the possible values of the right
- -- operand.
-
- -- Otherwise, we just consider two intervals of values for
- -- the right operand: the interval of negative values (up to
- -- -1) and the interval of positive values (starting at 1).
- -- Since division by 1 is the identity, and division by -1
- -- is negation, we get all possible bounds of division in that
- -- case by considering:
- -- - all values from the division of end values of input
- -- ranges;
- -- - the end values of the left operand;
- -- - the negation of the end values of the left operand.
-
- else
- declare
- Mrk : constant Uintp.Save_Mark := Mark;
- -- Mark so we can release the RR and Ev values
-
- Ev1 : Uint;
- Ev2 : Uint;
- Ev3 : Uint;
- Ev4 : Uint;
-
- begin
- -- Discard extreme values of zero for the divisor, since
- -- they will simply result in an exception in any case.
-
- if Rlo = 0 then
- Rlo := Uint_1;
- elsif Rhi = 0 then
- Rhi := -Uint_1;
- end if;
-
- -- Compute possible bounds coming from dividing end
- -- values of the input ranges.
-
- Ev1 := Llo / Rlo;
- Ev2 := Llo / Rhi;
- Ev3 := Lhi / Rlo;
- Ev4 := Lhi / Rhi;
-
- Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4));
- Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4));
-
- -- If the right operand can be both negative or positive,
- -- include the end values of the left operand in the
- -- extreme values, as well as their negation.
-
- if Rlo < 0 and then Rhi > 0 then
- Ev1 := Llo;
- Ev2 := -Llo;
- Ev3 := Lhi;
- Ev4 := -Lhi;
-
- Min (Lo,
- UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4)));
- Max (Hi,
- UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4)));
- end if;
-
- -- Release the RR and Ev values
-
- Release_And_Save (Mrk, Lo, Hi);
- end;
- end if;
-
- -- Exponentiation
-
- when N_Op_Expon =>
-
- -- Discard negative values for the exponent, since they will
- -- simply result in an exception in any case.
-
- if Rhi < 0 then
- Rhi := Uint_0;
- elsif Rlo < 0 then
- Rlo := Uint_0;
- end if;
-
- -- Estimate number of bits in result before we go computing
- -- giant useless bounds. Basically the number of bits in the
- -- result is the number of bits in the base multiplied by the
- -- value of the exponent. If this is big enough that the result
- -- definitely won't fit in Long_Long_Integer, switch to bignum
- -- mode immediately, and avoid computing giant bounds.
-
- -- The comparison here is approximate, but conservative, it
- -- only clicks on cases that are sure to exceed the bounds.
-
- if Num_Bits (UI_Max (abs Llo, abs Lhi)) * Rhi + 1 > 100 then
- Lo := No_Uint;
- Hi := No_Uint;
-
- -- If right operand is zero then result is 1
-
- elsif Rhi = 0 then
- Lo := Uint_1;
- Hi := Uint_1;
-
- else
- -- High bound comes either from exponentiation of largest
- -- positive value to largest exponent value, or from
- -- the exponentiation of most negative value to an
- -- even exponent.
-
- declare
- Hi1, Hi2 : Uint;
-
- begin
- if Lhi > 0 then
- Hi1 := Lhi ** Rhi;
- else
- Hi1 := Uint_0;
- end if;
-
- if Llo < 0 then
- if Rhi mod 2 = 0 then
- Hi2 := Llo ** Rhi;
- else
- Hi2 := Llo ** (Rhi - 1);
- end if;
- else
- Hi2 := Uint_0;
- end if;
-
- Hi := UI_Max (Hi1, Hi2);
- end;
-
- -- Result can only be negative if base can be negative
-
- if Llo < 0 then
- if Rhi mod 2 = 0 then
- Lo := Llo ** (Rhi - 1);
- else
- Lo := Llo ** Rhi;
- end if;
-
- -- Otherwise low bound is minimum ** minimum
-
- else
- Lo := Llo ** Rlo;
- end if;
- end if;
-
- -- Negation
-
- when N_Op_Minus =>
- Lo := -Rhi;
- Hi := -Rlo;
-
- -- Mod
-
- when N_Op_Mod =>
- declare
- Maxabs : constant Uint := UI_Max (abs Rlo, abs Rhi) - 1;
- -- This is the maximum absolute value of the result
-
- begin
- Lo := Uint_0;
- Hi := Uint_0;
-
- -- The result depends only on the sign and magnitude of
- -- the right operand, it does not depend on the sign or
- -- magnitude of the left operand.
-
- if Rlo < 0 then
- Lo := -Maxabs;
- end if;
-
- if Rhi > 0 then
- Hi := Maxabs;
- end if;
- end;
-
- -- Multiplication
-
- when N_Op_Multiply =>
-
- -- Possible bounds of multiplication must come from multiplying
- -- end values of the input ranges (four possibilities).
-
- declare
- Mrk : constant Uintp.Save_Mark := Mark;
- -- Mark so we can release the Ev values
-
- Ev1 : constant Uint := Llo * Rlo;
- Ev2 : constant Uint := Llo * Rhi;
- Ev3 : constant Uint := Lhi * Rlo;
- Ev4 : constant Uint := Lhi * Rhi;
-
- begin
- Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4));
- Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4));
-
- -- Release the Ev values
-
- Release_And_Save (Mrk, Lo, Hi);
- end;
-
- -- Plus operator (affirmation)
-
- when N_Op_Plus =>
- Lo := Rlo;
- Hi := Rhi;
-
- -- Remainder
-
- when N_Op_Rem =>
- declare
- Maxabs : constant Uint := UI_Max (abs Rlo, abs Rhi) - 1;
- -- This is the maximum absolute value of the result. Note
- -- that the result range does not depend on the sign of the
- -- right operand.
-
- begin
- Lo := Uint_0;
- Hi := Uint_0;
-
- -- Case of left operand negative, which results in a range
- -- of -Maxabs .. 0 for those negative values. If there are
- -- no negative values then Lo value of result is always 0.
-
- if Llo < 0 then
- Lo := -Maxabs;
- end if;
-
- -- Case of left operand positive
-
- if Lhi > 0 then
- Hi := Maxabs;
- end if;
- end;
-
- -- Subtract
-
- when N_Op_Subtract =>
- Lo := Llo - Rhi;
- Hi := Lhi - Rlo;
-
- -- Nothing else should be possible
-
- when others =>
- raise Program_Error;
- end case;
end if;
-- Here for the case where we have not rewritten anything (no bignum
@@ -9528,12 +9647,12 @@ package body Checks is
----------------------------
function Selected_Length_Checks
- (Ck_Node : Node_Id;
+ (Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Warn_Node : Node_Id) return Check_Result
is
- Loc : constant Source_Ptr := Sloc (Ck_Node);
+ Loc : constant Source_Ptr := Sloc (Expr);
S_Typ : Entity_Id;
T_Typ : Entity_Id;
Expr_Actual : Node_Id;
@@ -9565,11 +9684,11 @@ package body Checks is
-- Typ'Length /= Exptyp'Length
function Length_N_Cond
- (Expr : Node_Id;
+ (Exp : Node_Id;
Typ : Entity_Id;
Indx : Nat) return Node_Id;
-- Returns expression to compute:
- -- Typ'Length /= Expr'Length
+ -- Typ'Length /= Exp'Length
function Length_Mismatch_Info_Message
(Left_Element_Count : Uint;
@@ -9614,7 +9733,7 @@ package body Checks is
N := Build_Discriminal_Subtype_Of_Component (E);
if Present (N) then
- Insert_Action (Ck_Node, N);
+ Insert_Action (Expr, N);
E1 := Defining_Identifier (N);
end if;
end if;
@@ -9753,7 +9872,7 @@ package body Checks is
-------------------
function Length_N_Cond
- (Expr : Node_Id;
+ (Exp : Node_Id;
Typ : Entity_Id;
Indx : Nat) return Node_Id
is
@@ -9761,7 +9880,7 @@ package body Checks is
return
Make_Op_Ne (Loc,
Left_Opnd => Get_E_Length (Typ, Indx),
- Right_Opnd => Get_N_Length (Expr, Indx));
+ Right_Opnd => Get_N_Length (Exp, Indx));
end Length_N_Cond;
----------------------------------
@@ -9841,19 +9960,19 @@ package body Checks is
if Target_Typ = Any_Type
or else Target_Typ = Any_Composite
- or else Raises_Constraint_Error (Ck_Node)
+ or else Raises_Constraint_Error (Expr)
then
return Ret_Result;
end if;
if No (Wnode) then
- Wnode := Ck_Node;
+ Wnode := Expr;
end if;
T_Typ := Target_Typ;
if No (Source_Typ) then
- S_Typ := Etype (Ck_Node);
+ S_Typ := Etype (Expr);
else
S_Typ := Source_Typ;
end if;
@@ -9869,7 +9988,7 @@ package body Checks is
-- A simple optimization for the null case
- if Known_Null (Ck_Node) then
+ if Known_Null (Expr) then
return Ret_Result;
end if;
end if;
@@ -9882,10 +10001,10 @@ package body Checks is
-- freeze node does not appear within the generated if expression,
-- but ahead of it.
- Freeze_Before (Ck_Node, T_Typ);
+ Freeze_Before (Expr, T_Typ);
- Expr_Actual := Get_Referenced_Object (Ck_Node);
- Exptyp := Get_Actual_Subtype (Ck_Node);
+ Expr_Actual := Get_Referenced_Object (Expr);
+ Exptyp := Get_Actual_Subtype (Expr);
if Is_Access_Type (Exptyp) then
Exptyp := Designated_Type (Exptyp);
@@ -9945,9 +10064,9 @@ package body Checks is
not In_Package_Body (Cunit_Entity (Current_Sem_Unit))
and then In_Open_Scopes (Scope (Exptyp))
then
- Ref_Node := Make_Itype_Reference (Sloc (Ck_Node));
+ Ref_Node := Make_Itype_Reference (Sloc (Expr));
Set_Itype (Ref_Node, Exptyp);
- Insert_Action (Ck_Node, Ref_Node);
+ Insert_Action (Expr, Ref_Node);
end if;
L_Index := First_Index (T_Typ);
@@ -10031,20 +10150,20 @@ package body Checks is
-- the length or range from the expression itself, making sure we
-- do not evaluate it more than once.
- -- Here Ck_Node is the original expression, or more properly the
+ -- Here Expr is the original expression, or more properly the
-- result of applying Duplicate_Expr to the original tree, forcing
-- the result to be a name.
else
declare
- Ndims : constant Nat := Number_Dimensions (T_Typ);
+ Ndims : constant Pos := Number_Dimensions (T_Typ);
begin
-- Build the condition for the explicit dereference case
for Indx in 1 .. Ndims loop
Evolve_Or_Else
- (Cond, Length_N_Cond (Ck_Node, T_Typ, Indx));
+ (Cond, Length_N_Cond (Expr, T_Typ, Indx));
end loop;
end;
end if;
@@ -10055,7 +10174,7 @@ package body Checks is
if Present (Cond) then
if Do_Access then
- Cond := Guard_Access (Cond, Loc, Ck_Node);
+ Cond := Guard_Access (Cond, Loc, Expr);
end if;
Add_Check
@@ -10072,12 +10191,12 @@ package body Checks is
---------------------------
function Selected_Range_Checks
- (Ck_Node : Node_Id;
+ (Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Warn_Node : Node_Id) return Check_Result
is
- Loc : constant Source_Ptr := Sloc (Ck_Node);
+ Loc : constant Source_Ptr := Sloc (Expr);
S_Typ : Entity_Id;
T_Typ : Entity_Id;
Expr_Actual : Node_Id;
@@ -10092,20 +10211,20 @@ package body Checks is
-- Adds the action given to Ret_Result if N is non-Empty
function Discrete_Range_Cond
- (Expr : Node_Id;
- Typ : Entity_Id) return Node_Id;
+ (Exp : Node_Id;
+ Typ : Entity_Id) return Node_Id;
-- Returns expression to compute:
- -- Low_Bound (Expr) < Typ'First
+ -- Low_Bound (Exp) < Typ'First
-- or else
- -- High_Bound (Expr) > Typ'Last
+ -- High_Bound (Exp) > Typ'Last
function Discrete_Expr_Cond
- (Expr : Node_Id;
- Typ : Entity_Id) return Node_Id;
+ (Exp : Node_Id;
+ Typ : Entity_Id) return Node_Id;
-- Returns expression to compute:
- -- Expr < Typ'First
+ -- Exp < Typ'First
-- or else
- -- Expr > Typ'Last
+ -- Exp > Typ'Last
function Get_E_First_Or_Last
(Loc : Source_Ptr;
@@ -10142,11 +10261,11 @@ package body Checks is
-- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
function Range_N_Cond
- (Expr : Node_Id;
+ (Exp : Node_Id;
Typ : Entity_Id;
Indx : Nat) return Node_Id;
-- Return expression to compute:
- -- Expr'First < Typ'First or else Expr'Last > Typ'Last
+ -- Exp'First < Typ'First or else Exp'Last > Typ'Last
---------------
-- Add_Check --
@@ -10173,8 +10292,8 @@ package body Checks is
-------------------------
function Discrete_Expr_Cond
- (Expr : Node_Id;
- Typ : Entity_Id) return Node_Id
+ (Exp : Node_Id;
+ Typ : Entity_Id) return Node_Id
is
begin
return
@@ -10183,7 +10302,7 @@ package body Checks is
Make_Op_Lt (Loc,
Left_Opnd =>
Convert_To (Base_Type (Typ),
- Duplicate_Subexpr_No_Checks (Expr)),
+ Duplicate_Subexpr_No_Checks (Exp)),
Right_Opnd =>
Convert_To (Base_Type (Typ),
Get_E_First_Or_Last (Loc, Typ, 0, Name_First))),
@@ -10192,7 +10311,7 @@ package body Checks is
Make_Op_Gt (Loc,
Left_Opnd =>
Convert_To (Base_Type (Typ),
- Duplicate_Subexpr_No_Checks (Expr)),
+ Duplicate_Subexpr_No_Checks (Exp)),
Right_Opnd =>
Convert_To
(Base_Type (Typ),
@@ -10204,11 +10323,11 @@ package body Checks is
-------------------------
function Discrete_Range_Cond
- (Expr : Node_Id;
- Typ : Entity_Id) return Node_Id
+ (Exp : Node_Id;
+ Typ : Entity_Id) return Node_Id
is
- LB : Node_Id := Low_Bound (Expr);
- HB : Node_Id := High_Bound (Expr);
+ LB : Node_Id := Low_Bound (Exp);
+ HB : Node_Id := High_Bound (Exp);
Left_Opnd : Node_Id;
Right_Opnd : Node_Id;
@@ -10364,7 +10483,7 @@ package body Checks is
------------------
function Range_N_Cond
- (Expr : Node_Id;
+ (Exp : Node_Id;
Typ : Entity_Id;
Indx : Nat) return Node_Id
is
@@ -10374,14 +10493,14 @@ package body Checks is
Left_Opnd =>
Make_Op_Lt (Loc,
Left_Opnd =>
- Get_N_First (Expr, Indx),
+ Get_N_First (Exp, Indx),
Right_Opnd =>
Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
Right_Opnd =>
Make_Op_Gt (Loc,
Left_Opnd =>
- Get_N_Last (Expr, Indx),
+ Get_N_Last (Exp, Indx),
Right_Opnd =>
Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
end Range_N_Cond;
@@ -10400,19 +10519,19 @@ package body Checks is
if Target_Typ = Any_Type
or else Target_Typ = Any_Composite
- or else Raises_Constraint_Error (Ck_Node)
+ or else Raises_Constraint_Error (Expr)
then
return Ret_Result;
end if;
if No (Wnode) then
- Wnode := Ck_Node;
+ Wnode := Expr;
end if;
T_Typ := Target_Typ;
if No (Source_Typ) then
- S_Typ := Etype (Ck_Node);
+ S_Typ := Etype (Expr);
else
S_Typ := Source_Typ;
end if;
@@ -10422,7 +10541,7 @@ package body Checks is
end if;
-- The order of evaluating T_Typ before S_Typ seems to be critical
- -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
+ -- because S_Typ can be derived from Etype (Expr), if it's not passed
-- in, and since Node can be an N_Range node, it might be invalid.
-- Should there be an assert check somewhere for taking the Etype of
-- an N_Range node ???
@@ -10434,7 +10553,7 @@ package body Checks is
-- A simple optimization for the null case
- if Known_Null (Ck_Node) then
+ if Known_Null (Expr) then
return Ret_Result;
end if;
end if;
@@ -10442,11 +10561,11 @@ package body Checks is
-- For an N_Range Node, check for a null range and then if not
-- null generate a range check action.
- if Nkind (Ck_Node) = N_Range then
+ if Nkind (Expr) = N_Range then
-- There's no point in checking a range against itself
- if Ck_Node = Scalar_Range (T_Typ) then
+ if Expr = Scalar_Range (T_Typ) then
return Ret_Result;
end if;
@@ -10456,8 +10575,8 @@ package body Checks is
Known_T_LB : constant Boolean := Compile_Time_Known_Value (T_LB);
Known_T_HB : constant Boolean := Compile_Time_Known_Value (T_HB);
- LB : Node_Id := Low_Bound (Ck_Node);
- HB : Node_Id := High_Bound (Ck_Node);
+ LB : Node_Id := Low_Bound (Expr);
+ HB : Node_Id := High_Bound (Expr);
Known_LB : Boolean := False;
Known_HB : Boolean := False;
@@ -10541,7 +10660,7 @@ package body Checks is
if No (Warn_Node) then
Add_Check
(Compile_Time_Constraint_Error
- (Low_Bound (Ck_Node),
+ (Low_Bound (Expr),
"static value out of range of}??", T_Typ));
else
@@ -10556,7 +10675,7 @@ package body Checks is
if No (Warn_Node) then
Add_Check
(Compile_Time_Constraint_Error
- (High_Bound (Ck_Node),
+ (High_Bound (Expr),
"static value out of range of}??", T_Typ));
else
@@ -10570,8 +10689,8 @@ package body Checks is
else
declare
- LB : Node_Id := Low_Bound (Ck_Node);
- HB : Node_Id := High_Bound (Ck_Node);
+ LB : Node_Id := Low_Bound (Expr);
+ HB : Node_Id := High_Bound (Expr);
begin
-- If either bound is a discriminant and we are within the
@@ -10614,7 +10733,7 @@ package body Checks is
end if;
end if;
- Cond := Discrete_Range_Cond (Ck_Node, T_Typ);
+ Cond := Discrete_Range_Cond (Expr, T_Typ);
Set_Paren_Count (Cond, 1);
Cond :=
@@ -10641,7 +10760,7 @@ package body Checks is
-- arbitrary target type, so we do that here.
if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then
- Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
+ Cond := Discrete_Expr_Cond (Expr, T_Typ);
-- For literals, we can tell if the constraint error will be
-- raised at compile time, so we never need a dynamic check, but
@@ -10649,7 +10768,7 @@ package body Checks is
-- and replace the literal with a raise constraint error
-- expression. As usual, skip this for access types
- elsif Compile_Time_Known_Value (Ck_Node) and then not Do_Access then
+ elsif Compile_Time_Known_Value (Expr) and then not Do_Access then
declare
LB : constant Node_Id := Type_Low_Bound (T_Typ);
UB : constant Node_Id := Type_High_Bound (T_Typ);
@@ -10665,17 +10784,17 @@ package body Checks is
if Static_Bounds then
if Is_Floating_Point_Type (S_Typ) then
Out_Of_Range :=
- (Expr_Value_R (Ck_Node) < Expr_Value_R (LB))
+ (Expr_Value_R (Expr) < Expr_Value_R (LB))
or else
- (Expr_Value_R (Ck_Node) > Expr_Value_R (UB));
+ (Expr_Value_R (Expr) > Expr_Value_R (UB));
-- Fixed or discrete type
else
Out_Of_Range :=
- Expr_Value (Ck_Node) < Expr_Value (LB)
+ Expr_Value (Expr) < Expr_Value (LB)
or else
- Expr_Value (Ck_Node) > Expr_Value (UB);
+ Expr_Value (Expr) > Expr_Value (UB);
end if;
-- Bounds of the type are static and the literal is out of
@@ -10685,7 +10804,7 @@ package body Checks is
if No (Warn_Node) then
Add_Check
(Compile_Time_Constraint_Error
- (Ck_Node,
+ (Expr,
"static value out of range of}??", T_Typ));
else
@@ -10697,7 +10816,7 @@ package body Checks is
end if;
else
- Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
+ Cond := Discrete_Expr_Cond (Expr, T_Typ);
end if;
end;
@@ -10707,7 +10826,7 @@ package body Checks is
else
if not In_Subrange_Of (S_Typ, T_Typ) then
- Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
+ Cond := Discrete_Expr_Cond (Expr, T_Typ);
end if;
end if;
end if;
@@ -10715,7 +10834,7 @@ package body Checks is
if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
if Is_Constrained (T_Typ) then
- Expr_Actual := Get_Referenced_Object (Ck_Node);
+ Expr_Actual := Get_Referenced_Object (Expr);
Exptyp := Get_Actual_Subtype (Expr_Actual);
if Is_Access_Type (Exptyp) then
@@ -10742,7 +10861,7 @@ package body Checks is
elsif Is_Constrained (Exptyp) then
declare
- Ndims : constant Nat := Number_Dimensions (T_Typ);
+ Ndims : constant Pos := Number_Dimensions (T_Typ);
L_Index : Node_Id;
R_Index : Node_Id;
@@ -10790,20 +10909,20 @@ package body Checks is
-- the length or range from the expression itself, making sure we
-- do not evaluate it more than once.
- -- Here Ck_Node is the original expression, or more properly the
+ -- Here Expr is the original expression, or more properly the
-- result of applying Duplicate_Expr to the original tree,
-- forcing the result to be a name.
else
declare
- Ndims : constant Nat := Number_Dimensions (T_Typ);
+ Ndims : constant Pos := Number_Dimensions (T_Typ);
begin
-- Build the condition for the explicit dereference case
for Indx in 1 .. Ndims loop
Evolve_Or_Else
- (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx));
+ (Cond, Range_N_Cond (Expr, T_Typ, Indx));
end loop;
end;
end if;
@@ -10816,7 +10935,7 @@ package body Checks is
-- array type, as 4.6(24.15/2) requires the designated subtypes
-- of the two access types to statically match.
- if Nkind (Parent (Ck_Node)) = N_Type_Conversion
+ if Nkind (Parent (Expr)) = N_Type_Conversion
and then not Do_Access
then
declare
@@ -10825,7 +10944,7 @@ package body Checks is
Opnd_Range : Node_Id;
begin
- Opnd_Index := First_Index (Get_Actual_Subtype (Ck_Node));
+ Opnd_Index := First_Index (Get_Actual_Subtype (Expr));
Targ_Index := First_Index (T_Typ);
while Present (Opnd_Index) loop
@@ -10896,7 +11015,7 @@ package body Checks is
if Present (Cond) then
if Do_Access then
- Cond := Guard_Access (Cond, Loc, Ck_Node);
+ Cond := Guard_Access (Cond, Loc, Expr);
end if;
Add_Check
diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads
index a1538a3..aca1b7e 100644
--- a/gcc/ada/checks.ads
+++ b/gcc/ada/checks.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -23,10 +23,10 @@
-- --
------------------------------------------------------------------------------
--- Package containing routines used to deal with runtime checks. These
+-- Package containing routines used to deal with run-time checks. These
-- routines are used both by the semantics and by the expander. In some
--- cases, checks are enabled simply by setting flags for gigi, and in
--- other cases the code for the check is expanded.
+-- cases, checks are enabled simply by setting a flag for the back end,
+-- and in other cases the code for the check is expanded.
-- The approach used for range and length checks, in regards to suppressed
-- checks, is to attempt to detect at compilation time that a constraint
@@ -48,23 +48,23 @@ package Checks is
-- Called for each new main source program, to initialize internal
-- variables used in the package body of the Checks unit.
- function Access_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Allocation_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Atomic_Synchronization_Disabled (E : Entity_Id) return Boolean;
- function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Division_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Duplicated_Tag_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Index_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Length_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Predicate_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Range_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Storage_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Tag_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Validity_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Access_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Allocation_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Atomic_Synchronization_Disabled (E : Entity_Id) return Boolean;
+ function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Division_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Duplicated_Tag_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Index_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Length_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Predicate_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Range_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Storage_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Tag_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Validity_Checks_Suppressed (E : Entity_Id) return Boolean;
-- These functions check to see if the named check is suppressed, either
-- by an active scope suppress setting, or because the check has been
-- specifically suppressed for the given entity. If no entity is relevant
@@ -179,7 +179,7 @@ package Checks is
-- operate anyway since they may generate useful compile time warnings.
procedure Apply_Access_Check (N : Node_Id);
- -- Determines whether an expression node requires a runtime access
+ -- Determines whether an expression node requires a run-time access
-- check and if so inserts the appropriate run-time check.
procedure Apply_Accessibility_Check
@@ -200,7 +200,7 @@ package Checks is
-- generated) is prepended to the Actions list of N_Freeze_Entity node N.
-- Note that the check references E'Alignment, so it cannot be emitted
-- before N (its freeze node), otherwise this would cause an illegal
- -- access before elaboration error in GIGI. For the case of a clear overlay
+ -- access before elaboration error in gigi. For the case of a clear overlay
-- situation, we also check that the size of the overlaying object is not
-- larger than the overlaid object.
@@ -339,7 +339,7 @@ package Checks is
-- value should be taken into account, which is not the case currently.
procedure Install_Null_Excluding_Check (N : Node_Id);
- -- Determines whether an access node requires a runtime access check and
+ -- Determines whether an access node requires a run-time access check and
-- if so inserts the appropriate run-time check.
procedure Install_Primitive_Elaboration_Check (Subp_Body : Node_Id);
@@ -445,13 +445,10 @@ package Checks is
-------------------------------------------------------
-- Range checks are controlled by the Do_Range_Check flag. The front end
- -- is responsible for setting this flag in relevant nodes. Originally
- -- the back end generated all corresponding range checks. But later on
- -- we decided to generate many range checks in the front end. We are now
- -- in the transitional phase where some of these checks are still done
- -- by the back end, but many are done by the front end. It is possible
- -- that in the future we might move all the checks to the front end. The
- -- main remaining back end checks are for subscript checking.
+ -- is responsible for setting this flag in relevant nodes. Originally the
+ -- back end generated all the corresponding range checks, but later on we
+ -- decided to generate all the range checks in the front end and this is
+ -- the current situation.
-- Overflow checks are similarly controlled by the Do_Overflow_Check flag.
-- The difference here is that if back end overflow checks are inactive
@@ -529,12 +526,6 @@ package Checks is
-- this node is further examined depends on the setting of
-- the parameter Source_Typ, as described below.
- -- ??? Apply_Length_Check and Apply_Range_Check do not have an Expr
- -- formal
-
- -- ??? Apply_Length_Check and Apply_Range_Check have a Ck_Node formal
- -- which is undocumented, is it the same as Expr?
-
-- Target_Typ The target type on which the check is to be based. For
-- example, if we have a scalar range check, then the check
-- is that we are in range of this type.
@@ -561,7 +552,7 @@ package Checks is
-- handled by the caller.
procedure Apply_Length_Check
- (Ck_Node : Node_Id;
+ (Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty);
-- This procedure builds a sequence of declarations to do a length check
@@ -578,10 +569,29 @@ package Checks is
-- processes it as described above for consistency with the other routines
-- in this section.
- procedure Apply_Range_Check
- (Ck_Node : Node_Id;
+ procedure Apply_Length_Check_On_Assignment
+ (Expr : Node_Id;
Target_Typ : Entity_Id;
+ Target : Node_Id;
Source_Typ : Entity_Id := Empty);
+ -- Similar to Apply_Length_Check, but takes the target of an assignment for
+ -- which the check is to be done. Used to filter out specific cases where
+ -- the check is superfluous.
+
+ procedure Apply_Static_Length_Check
+ (Expr : Node_Id;
+ Target_Typ : Entity_Id;
+ Source_Typ : Entity_Id := Empty);
+ -- Tries to determine statically whether the two array types source type
+ -- and Target_Typ have the same length. If it can be determined at compile
+ -- time that they do not, then an N_Raise_Constraint_Error node replaces
+ -- Expr, and a warning message is issued.
+
+ procedure Apply_Range_Check
+ (Expr : Node_Id;
+ Target_Typ : Entity_Id;
+ Source_Typ : Entity_Id := Empty;
+ Insert_Node : Node_Id := Empty);
-- For a Node of kind N_Range, constructs a range check action that tests
-- first that the range is not null and then that the range is contained in
-- the Target_Typ range.
@@ -606,14 +616,8 @@ package Checks is
-- The source type is used by type conversions to unconstrained array
-- types to retrieve the corresponding bounds.
- procedure Apply_Static_Length_Check
- (Expr : Node_Id;
- Target_Typ : Entity_Id;
- Source_Typ : Entity_Id := Empty);
- -- Tries to determine statically whether the two array types source type
- -- and Target_Typ have the same length. If it can be determined at compile
- -- time that they do not, then an N_Raise_Constraint_Error node replaces
- -- Expr, and a warning message is issued.
+ -- Insert_Node indicates the node where the check should be inserted.
+ -- If it is empty, then the check is inserted directly at Expr instead.
procedure Apply_Scalar_Range_Check
(Expr : Node_Id;
@@ -621,7 +625,7 @@ package Checks is
Source_Typ : Entity_Id := Empty;
Fixed_Int : Boolean := False);
-- For scalar types, determines whether an expression node should be
- -- flagged as needing a runtime range check. If the node requires such a
+ -- flagged as needing a run-time range check. If the node requires such a
-- check, the Do_Range_Check flag is turned on. The Fixed_Int flag if set
-- causes any fixed-point values to be treated as though they were discrete
-- values (i.e. the underlying integer value is used).
@@ -631,7 +635,7 @@ package Checks is
-- call to Insert_Range_Checks procedure.
function Get_Range_Checks
- (Ck_Node : Node_Id;
+ (Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty;
Warn_Node : Node_Id := Empty) return Check_Result;
@@ -646,49 +650,37 @@ package Checks is
(Checks : Check_Result;
Stmts : List_Id;
Suppress_Typ : Entity_Id;
- Static_Sloc : Source_Ptr;
- Flag_Node : Node_Id);
+ Static_Sloc : Source_Ptr);
-- Called to append range checks as returned by a call to Get_Range_Checks.
-- Stmts is a list to which either the dynamic check is appended or the
-- raise Constraint_Error statement is appended (for static checks).
- -- Static_Sloc is the Sloc at which the raise CE node points, Flag_Node is
- -- used as the node at which to set the Has_Dynamic_Check flag. Checks_On
- -- is a boolean value that says if range and index checking is on or not.
+ -- Suppress_Typ is the type to check to determine if checks are suppressed.
+ -- Static_Sloc is the Sloc at which the raise CE node points.
procedure Insert_Range_Checks
(Checks : Check_Result;
Node : Node_Id;
Suppress_Typ : Entity_Id;
- Static_Sloc : Source_Ptr := No_Location;
- Flag_Node : Node_Id := Empty;
- Do_Before : Boolean := False);
+ Static_Sloc : Source_Ptr;
+ Do_Before : Boolean := False);
-- Called to insert range checks as returned by a call to Get_Range_Checks.
-- Node is the node after which either the dynamic check is inserted or
-- the raise Constraint_Error statement is inserted (for static checks).
-- Suppress_Typ is the type to check to determine if checks are suppressed.
- -- Static_Sloc, if passed, is the Sloc at which the raise CE node points,
- -- otherwise Sloc (Node) is used. The Has_Dynamic_Check flag is normally
- -- set at Node. If Flag_Node is present, then this is used instead as the
- -- node at which to set the Has_Dynamic_Check flag. Normally the check is
- -- inserted after, if Do_Before is True, the check is inserted before
- -- Node.
+ -- Static_Sloc is the Sloc at which the raise CE node points. Normally the
+ -- checks are inserted after Node; if Do_Before is True, they are before.
-----------------------
-- Expander Routines --
-----------------------
- -- Some of the earlier processing for checks results in temporarily setting
- -- the Do_Range_Check flag rather than actually generating checks. Now we
- -- are moving the generation of such checks into the front end for reasons
- -- of efficiency and simplicity (there were difficulties in handling this
- -- in the back end when side effects were present in the expressions being
- -- checked).
-
- -- Probably we could eliminate the Do_Range_Check flag entirely and
- -- generate the checks earlier, but this is a delicate area and it
- -- seemed safer to implement the following routines, which are called
- -- late on in the expansion process. They check the Do_Range_Check flag
- -- and if it is set, generate the actual checks and reset the flag.
+ -- In most cases, the processing for range checks done by semantic analysis
+ -- only results in setting the Do_Range_Check flag, rather than actually
+ -- generating checks. The following routines must be called later on in the
+ -- expansion process upon seeing the Do_Range_Check flag; they generate the
+ -- actual checks and reset the flag. The remaining cases where range checks
+ -- are still directly generated during semantic analysis occur as part of
+ -- the processing of constraints in (sub)type and object declarations.
procedure Generate_Range_Check
(N : Node_Id;
@@ -702,11 +694,11 @@ package Checks is
-- if raised.
--
-- Note: if the expander is not active, or if we are in GNATprove mode,
- -- then we do not generate explicit range code. Instead we just turn the
+ -- then we do not generate explicit range checks. Instead we just turn the
-- Do_Range_Check flag on, since in these cases that's what we want to see
-- in the tree (GNATprove in particular depends on this flag being set). If
- -- we generate the actual range check, then we make sure the flag is off,
- -- since the code we generate takes complete care of the check.
+ -- we generate the actual range checks, then we make sure the flag is off
+ -- afterward, since the code we generate takes complete care of the checks.
--
-- Historical note: We used to just pass on the Do_Range_Check flag to the
-- back end to generate the check, but now in code-generation mode we never
diff --git a/gcc/ada/cio.c b/gcc/ada/cio.c
index 7fca412..2a9fe1a 100644
--- a/gcc/ada/cio.c
+++ b/gcc/ada/cio.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb
index 565d22e..f5778a0 100644
--- a/gcc/ada/clean.adb
+++ b/gcc/ada/clean.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/clean.ads b/gcc/ada/clean.ads
index 2d21c68..4e8f6fe 100644
--- a/gcc/ada/clean.ads
+++ b/gcc/ada/clean.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb
index f8f3d77..06fb0a4 100644
--- a/gcc/ada/comperr.adb
+++ b/gcc/ada/comperr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -310,8 +310,8 @@ package body Comperr is
End_Line;
Write_Str
- ("| http://www.adacore.com/ " &
- "section 'send a report'.");
+ ("| https://www.adacore.com/login?mode=gap " &
+ "section 'Create New Ticket'.");
End_Line;
Write_Str
@@ -325,17 +325,17 @@ package body Comperr is
End_Line;
Write_Str
- ("| http://www.adacore.com/gnattracker/ " &
- "section 'send a report'.");
+ ("| https://www.adacore.com/login " &
+ "section 'Create New Ticket'.");
End_Line;
Write_Str
- ("| alternatively submit a bug report by email " &
- "to report@adacore.com,");
+ ("| Or submit a bug report by email " &
+ "to report@adacore.com");
End_Line;
Write_Str
- ("| including your customer number #nnn " &
+ ("| and include your customer number #nnn " &
"in the subject line.");
End_Line;
end if;
diff --git a/gcc/ada/comperr.ads b/gcc/ada/comperr.ads
index 2992e7d..3bba501 100644
--- a/gcc/ada/comperr.ads
+++ b/gcc/ada/comperr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 981bb91..9d3e9e9 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2015-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -61,6 +61,11 @@ package body Contracts is
--
-- Part_Of
+ procedure Check_Type_Or_Object_External_Properties
+ (Type_Or_Obj_Id : Entity_Id);
+ -- Perform checking of external properties pragmas that is common to both
+ -- type declarations and object declarations.
+
procedure Expand_Subprogram_Contract (Body_Id : Entity_Id);
-- Expand the contracts of a subprogram body and its correspoding spec (if
-- any). This routine processes all [refined] pre- and postconditions as
@@ -149,7 +154,7 @@ package body Contracts is
-- Refined_Post
elsif Is_Entry_Body (Id) then
- if Nam_In (Prag_Nam, Name_Refined_Depends, Name_Refined_Global) then
+ if Prag_Nam in Name_Refined_Depends | Name_Refined_Global then
Add_Classification;
elsif Prag_Nam = Name_Refined_Post then
@@ -174,31 +179,31 @@ package body Contracts is
-- Volatile_Function
elsif Is_Entry_Declaration (Id)
- or else Ekind_In (Id, E_Function,
- E_Generic_Function,
- E_Generic_Procedure,
- E_Procedure)
+ or else Ekind (Id) in E_Function
+ | E_Generic_Function
+ | E_Generic_Procedure
+ | E_Procedure
then
- if Nam_In (Prag_Nam, Name_Attach_Handler, Name_Interrupt_Handler)
- and then Ekind_In (Id, E_Generic_Procedure, E_Procedure)
+ if Prag_Nam in Name_Attach_Handler | Name_Interrupt_Handler
+ and then Ekind (Id) in E_Generic_Procedure | E_Procedure
then
Add_Classification;
- elsif Nam_In (Prag_Nam, Name_Depends,
- Name_Extensions_Visible,
- Name_Global)
+ elsif Prag_Nam in Name_Depends
+ | Name_Extensions_Visible
+ | Name_Global
then
Add_Classification;
elsif Prag_Nam = Name_Volatile_Function
- and then Ekind_In (Id, E_Function, E_Generic_Function)
+ and then Ekind (Id) in E_Function | E_Generic_Function
then
Add_Classification;
- elsif Nam_In (Prag_Nam, Name_Contract_Cases, Name_Test_Case) then
+ elsif Prag_Nam in Name_Contract_Cases | Name_Test_Case then
Add_Contract_Test_Case;
- elsif Nam_In (Prag_Nam, Name_Postcondition, Name_Precondition) then
+ elsif Prag_Nam in Name_Postcondition | Name_Precondition then
Add_Pre_Post_Condition;
-- The pragma is not a proper contract item
@@ -213,10 +218,10 @@ package body Contracts is
-- Initializes
-- Part_Of (instantiation only)
- elsif Ekind_In (Id, E_Generic_Package, E_Package) then
- if Nam_In (Prag_Nam, Name_Abstract_State,
- Name_Initial_Condition,
- Name_Initializes)
+ elsif Is_Package_Or_Generic_Package (Id) then
+ if Prag_Nam in Name_Abstract_State
+ | Name_Initial_Condition
+ | Name_Initializes
then
Add_Classification;
@@ -244,18 +249,33 @@ package body Contracts is
raise Program_Error;
end if;
- -- Protected units, the applicable pragmas are:
- -- Part_Of
-
- elsif Ekind (Id) = E_Protected_Type then
- if Prag_Nam = Name_Part_Of then
- Add_Classification;
+ -- The four volatility refinement pragmas are ok for all types.
+ -- Part_Of is ok for task types and protected types.
+ -- Depends and Global are ok for task types.
+
+ elsif Is_Type (Id) then
+ declare
+ Is_OK : constant Boolean :=
+ Prag_Nam in Name_Async_Readers
+ | Name_Async_Writers
+ | Name_Effective_Reads
+ | Name_Effective_Writes
+ or else (Ekind (Id) = E_Task_Type
+ and Prag_Nam in Name_Part_Of
+ | Name_Depends
+ | Name_Global)
+ or else (Ekind (Id) = E_Protected_Type
+ and Prag_Nam = Name_Part_Of);
+ begin
+ if Is_OK then
+ Add_Classification;
+ else
- -- The pragma is not a proper contract item
+ -- The pragma is not a proper contract item
- else
- raise Program_Error;
- end if;
+ raise Program_Error;
+ end if;
+ end;
-- Subprogram bodies, the applicable pragmas are:
-- Postcondition
@@ -265,12 +285,12 @@ package body Contracts is
-- Refined_Post
elsif Ekind (Id) = E_Subprogram_Body then
- if Nam_In (Prag_Nam, Name_Refined_Depends, Name_Refined_Global) then
+ if Prag_Nam in Name_Refined_Depends | Name_Refined_Global then
Add_Classification;
- elsif Nam_In (Prag_Nam, Name_Postcondition,
- Name_Precondition,
- Name_Refined_Post)
+ elsif Prag_Nam in Name_Postcondition
+ | Name_Precondition
+ | Name_Refined_Post
then
Add_Pre_Post_Condition;
@@ -285,7 +305,7 @@ package body Contracts is
-- Refined_Global
elsif Ekind (Id) = E_Task_Body then
- if Nam_In (Prag_Nam, Name_Refined_Depends, Name_Refined_Global) then
+ if Prag_Nam in Name_Refined_Depends | Name_Refined_Global then
Add_Classification;
-- The pragma is not a proper contract item
@@ -299,16 +319,6 @@ package body Contracts is
-- Global
-- Part_Of
- elsif Ekind (Id) = E_Task_Type then
- if Nam_In (Prag_Nam, Name_Depends, Name_Global, Name_Part_Of) then
- Add_Classification;
-
- -- The pragma is not a proper contract item
-
- else
- raise Program_Error;
- end if;
-
-- Variables, the applicable pragmas are:
-- Async_Readers
-- Async_Writers
@@ -321,15 +331,15 @@ package body Contracts is
-- Part_Of
elsif Ekind (Id) = E_Variable then
- if Nam_In (Prag_Nam, Name_Async_Readers,
- Name_Async_Writers,
- Name_Constant_After_Elaboration,
- Name_Depends,
- Name_Effective_Reads,
- Name_Effective_Writes,
- Name_Global,
- Name_No_Caching,
- Name_Part_Of)
+ if Prag_Nam in Name_Async_Readers
+ | Name_Async_Writers
+ | Name_Constant_After_Elaboration
+ | Name_Depends
+ | Name_Effective_Reads
+ | Name_Effective_Writes
+ | Name_Global
+ | Name_No_Caching
+ | Name_Part_Of
then
Add_Classification;
@@ -338,6 +348,9 @@ package body Contracts is
else
raise Program_Error;
end if;
+
+ else
+ raise Program_Error;
end if;
end Add_Contract_Item;
@@ -354,10 +367,10 @@ package body Contracts is
-- Entry or subprogram declarations
- if Nkind_In (Decl, N_Abstract_Subprogram_Declaration,
- N_Entry_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Subprogram_Declaration)
+ if Nkind (Decl) in N_Abstract_Subprogram_Declaration
+ | N_Entry_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Subprogram_Declaration
then
declare
Subp_Id : constant Entity_Id := Defining_Entity (Decl);
@@ -379,7 +392,7 @@ package body Contracts is
-- Entry or subprogram bodies
- elsif Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
+ elsif Nkind (Decl) in N_Entry_Body | N_Subprogram_Body then
Analyze_Entry_Or_Subprogram_Body_Contract (Defining_Entity (Decl));
-- Objects
@@ -394,8 +407,8 @@ package body Contracts is
-- Protected units
- elsif Nkind_In (Decl, N_Protected_Type_Declaration,
- N_Single_Protected_Declaration)
+ elsif Nkind (Decl) in N_Protected_Type_Declaration
+ | N_Single_Protected_Declaration
then
Analyze_Protected_Contract (Defining_Entity (Decl));
@@ -406,13 +419,13 @@ package body Contracts is
-- Task units
- elsif Nkind_In (Decl, N_Single_Task_Declaration,
- N_Task_Type_Declaration)
+ elsif Nkind (Decl) in N_Single_Task_Declaration
+ | N_Task_Type_Declaration
then
Analyze_Task_Contract (Defining_Entity (Decl));
-- For type declarations, we need to do the preanalysis of Iterable
- -- aspect specifications.
+ -- and the 3 Xxx_Literal aspect specifications.
-- Other type aspects need to be resolved here???
@@ -420,16 +433,41 @@ package body Contracts is
and then Present (Aspect_Specifications (Decl))
then
declare
- E : constant Entity_Id := Defining_Identifier (Decl);
- It : constant Node_Id := Find_Aspect (E, Aspect_Iterable);
+ E : constant Entity_Id := Defining_Identifier (Decl);
+ It : constant Node_Id := Find_Aspect (E, Aspect_Iterable);
+ I_Lit : constant Node_Id :=
+ Find_Aspect (E, Aspect_Integer_Literal);
+ R_Lit : constant Node_Id :=
+ Find_Aspect (E, Aspect_Real_Literal);
+ S_Lit : constant Node_Id :=
+ Find_Aspect (E, Aspect_String_Literal);
begin
if Present (It) then
Validate_Iterable_Aspect (E, It);
end if;
+
+ if Present (I_Lit) then
+ Validate_Literal_Aspect (E, I_Lit);
+ end if;
+ if Present (R_Lit) then
+ Validate_Literal_Aspect (E, R_Lit);
+ end if;
+ if Present (S_Lit) then
+ Validate_Literal_Aspect (E, S_Lit);
+ end if;
end;
end if;
+ if Nkind (Decl) in N_Full_Type_Declaration
+ | N_Private_Type_Declaration
+ | N_Task_Type_Declaration
+ | N_Protected_Type_Declaration
+ | N_Formal_Type_Declaration
+ then
+ Analyze_Type_Contract (Defining_Identifier (Decl));
+ end if;
+
Next (Decl);
end loop;
end Analyze_Contracts;
@@ -490,7 +528,7 @@ package body Contracts is
-- subprograms.
if SPARK_Mode = On
- and then Ekind_In (Body_Id, E_Function, E_Generic_Function)
+ and then Ekind (Body_Id) in E_Function | E_Generic_Function
and then Comes_From_Source (Spec_Id)
and then not Is_Volatile_Function (Body_Id)
then
@@ -540,9 +578,7 @@ package body Contracts is
-- Save the SPARK_Mode-related data to restore on exit
Skip_Assert_Exprs : constant Boolean :=
- Ekind_In (Subp_Id, E_Entry, E_Entry_Family)
- and then not ASIS_Mode
- and then not GNATprove_Mode;
+ Is_Entry (Subp_Id) and then not GNATprove_Mode;
Depends : Node_Id := Empty;
Global : Node_Id := Empty;
@@ -576,7 +612,7 @@ package body Contracts is
elsif Present (Items) then
-- Do not analyze the pre/postconditions of an entry declaration
- -- unless annotating the original tree for ASIS or GNATprove. The
+ -- unless annotating the original tree for GNATprove. The
-- real analysis occurs when the pre/postconditons are relocated to
-- the contract wrapper procedure (see Build_Contract_Wrapper).
@@ -617,7 +653,9 @@ package body Contracts is
Freeze_Expr_Types
(Def_Id => Subp_Id,
Typ => Standard_Boolean,
- Expr => Expression (Corresponding_Aspect (Prag)),
+ Expr =>
+ Expression
+ (First (Pragma_Argument_Associations (Prag))),
N => Bod);
end if;
@@ -636,7 +674,7 @@ package body Contracts is
if Prag_Nam = Name_Contract_Cases then
-- Do not analyze the contract cases of an entry declaration
- -- unless annotating the original tree for ASIS or GNATprove.
+ -- unless annotating the original tree for GNATprove.
-- The real analysis occurs when the contract cases are moved
-- to the contract wrapper procedure (Build_Contract_Wrapper).
@@ -699,7 +737,7 @@ package body Contracts is
-- processed after the analysis of the related subprogram declaration.
if SPARK_Mode = On
- and then Ekind_In (Subp_Id, E_Function, E_Generic_Function)
+ and then Ekind (Subp_Id) in E_Function | E_Generic_Function
and then Comes_From_Source (Subp_Id)
and then not Is_Volatile_Function (Subp_Id)
then
@@ -721,6 +759,233 @@ package body Contracts is
end if;
end Analyze_Entry_Or_Subprogram_Contract;
+ ----------------------------------------------
+ -- Check_Type_Or_Object_External_Properties --
+ ----------------------------------------------
+
+ procedure Check_Type_Or_Object_External_Properties
+ (Type_Or_Obj_Id : Entity_Id)
+ is
+ function Decl_Kind (Is_Type : Boolean;
+ Object_Kind : String) return String;
+ -- Returns "type" or Object_Kind, depending on Is_Type
+
+ ---------------
+ -- Decl_Kind --
+ ---------------
+
+ function Decl_Kind (Is_Type : Boolean;
+ Object_Kind : String) return String is
+ begin
+ if Is_Type then
+ return "type";
+ else
+ return Object_Kind;
+ end if;
+ end Decl_Kind;
+
+ Is_Type_Id : constant Boolean := Is_Type (Type_Or_Obj_Id);
+
+ -- Local variables
+
+ AR_Val : Boolean := False;
+ AW_Val : Boolean := False;
+ ER_Val : Boolean := False;
+ EW_Val : Boolean := False;
+ Seen : Boolean := False;
+ Prag : Node_Id;
+ Obj_Typ : Entity_Id;
+
+ -- Start of processing for Check_Type_Or_Object_External_Properties
+
+ begin
+ -- Analyze all external properties
+
+ if Is_Type_Id then
+ Obj_Typ := Type_Or_Obj_Id;
+
+ -- If the parent type of a derived type is volatile
+ -- then the derived type inherits volatility-related flags.
+
+ if Is_Derived_Type (Type_Or_Obj_Id) then
+ declare
+ Parent_Type : constant Entity_Id :=
+ Etype (Base_Type (Type_Or_Obj_Id));
+ begin
+ if Is_Effectively_Volatile (Parent_Type) then
+ AR_Val := Async_Readers_Enabled (Parent_Type);
+ AW_Val := Async_Writers_Enabled (Parent_Type);
+ ER_Val := Effective_Reads_Enabled (Parent_Type);
+ EW_Val := Effective_Writes_Enabled (Parent_Type);
+ end if;
+ end;
+ end if;
+ else
+ Obj_Typ := Etype (Type_Or_Obj_Id);
+ end if;
+
+ Prag := Get_Pragma (Type_Or_Obj_Id, Pragma_Async_Readers);
+
+ if Present (Prag) then
+ declare
+ Saved_AR_Val : constant Boolean := AR_Val;
+ begin
+ Analyze_External_Property_In_Decl_Part (Prag, AR_Val);
+ Seen := True;
+ if Saved_AR_Val and not AR_Val then
+ Error_Msg_N
+ ("illegal non-confirming Async_Readers specification",
+ Prag);
+ end if;
+ end;
+ end if;
+
+ Prag := Get_Pragma (Type_Or_Obj_Id, Pragma_Async_Writers);
+
+ if Present (Prag) then
+ declare
+ Saved_AW_Val : constant Boolean := AW_Val;
+ begin
+ Analyze_External_Property_In_Decl_Part (Prag, AW_Val);
+ Seen := True;
+ if Saved_AW_Val and not AW_Val then
+ Error_Msg_N
+ ("illegal non-confirming Async_Writers specification",
+ Prag);
+ end if;
+ end;
+ end if;
+
+ Prag := Get_Pragma (Type_Or_Obj_Id, Pragma_Effective_Reads);
+
+ if Present (Prag) then
+ declare
+ Saved_ER_Val : constant Boolean := ER_Val;
+ begin
+ Analyze_External_Property_In_Decl_Part (Prag, ER_Val);
+ Seen := True;
+ if Saved_ER_Val and not ER_Val then
+ Error_Msg_N
+ ("illegal non-confirming Effective_Reads specification",
+ Prag);
+ end if;
+ end;
+ end if;
+
+ Prag := Get_Pragma (Type_Or_Obj_Id, Pragma_Effective_Writes);
+
+ if Present (Prag) then
+ declare
+ Saved_EW_Val : constant Boolean := EW_Val;
+ begin
+ Analyze_External_Property_In_Decl_Part (Prag, EW_Val);
+ Seen := True;
+ if Saved_EW_Val and not EW_Val then
+ Error_Msg_N
+ ("illegal non-confirming Effective_Writes specification",
+ Prag);
+ end if;
+ end;
+ end if;
+
+ -- Verify the mutual interaction of the various external properties
+
+ if Seen then
+ Check_External_Properties
+ (Type_Or_Obj_Id, AR_Val, AW_Val, ER_Val, EW_Val);
+ end if;
+
+ -- The following checks are relevant only when SPARK_Mode is on, as
+ -- they are not standard Ada legality rules. Internally generated
+ -- temporaries are ignored.
+
+ if SPARK_Mode = On and then Comes_From_Source (Type_Or_Obj_Id) then
+ if Is_Effectively_Volatile (Type_Or_Obj_Id) then
+
+ -- The declaration of an effectively volatile object or type must
+ -- appear at the library level (SPARK RM 7.1.3(3), C.6(6)).
+
+ if not Is_Library_Level_Entity (Type_Or_Obj_Id) then
+ Error_Msg_N
+ ("effectively volatile "
+ & Decl_Kind (Is_Type => Is_Type_Id,
+ Object_Kind => "variable")
+ & " & must be declared at library level "
+ & "(SPARK RM 7.1.3(3))", Type_Or_Obj_Id);
+
+ -- An object of a discriminated type cannot be effectively
+ -- volatile except for protected objects (SPARK RM 7.1.3(5)).
+
+ elsif Has_Discriminants (Obj_Typ)
+ and then not Is_Protected_Type (Obj_Typ)
+ then
+ Error_Msg_N
+ ("discriminated "
+ & Decl_Kind (Is_Type => Is_Type_Id,
+ Object_Kind => "object")
+ & " & cannot be volatile",
+ Type_Or_Obj_Id);
+ end if;
+
+ -- An object decl shall be compatible with respect to volatility
+ -- with its type (SPARK RM 7.1.3(2)).
+
+ if not Is_Type_Id then
+ if Is_Effectively_Volatile (Obj_Typ) then
+ Check_Volatility_Compatibility
+ (Type_Or_Obj_Id, Obj_Typ,
+ "volatile object", "its type",
+ Srcpos_Bearer => Type_Or_Obj_Id);
+ end if;
+
+ -- A component of a composite type (in this case, the composite
+ -- type is an array type) shall be compatible with respect to
+ -- volatility with the composite type (SPARK RM 7.1.3(6)).
+
+ elsif Is_Array_Type (Obj_Typ) then
+ Check_Volatility_Compatibility
+ (Component_Type (Obj_Typ), Obj_Typ,
+ "component type", "its enclosing array type",
+ Srcpos_Bearer => Obj_Typ);
+
+ -- A component of a composite type (in this case, the composite
+ -- type is a record type) shall be compatible with respect to
+ -- volatility with the composite type (SPARK RM 7.1.3(6)).
+
+ elsif Is_Record_Type (Obj_Typ) then
+ declare
+ Comp : Entity_Id := First_Component (Obj_Typ);
+ begin
+ while Present (Comp) loop
+ Check_Volatility_Compatibility
+ (Etype (Comp), Obj_Typ,
+ "record component " & Get_Name_String (Chars (Comp)),
+ "its enclosing record type",
+ Srcpos_Bearer => Comp);
+ Next_Component (Comp);
+ end loop;
+ end;
+ end if;
+
+ -- The type or object is not effectively volatile
+
+ else
+ -- A non-effectively volatile type cannot have effectively
+ -- volatile components (SPARK RM 7.1.3(6)).
+
+ if Is_Type_Id
+ and then not Is_Effectively_Volatile (Type_Or_Obj_Id)
+ and then Has_Volatile_Component (Type_Or_Obj_Id)
+ then
+ Error_Msg_N
+ ("non-volatile type & cannot have volatile"
+ & " components",
+ Type_Or_Obj_Id);
+ end if;
+ end if;
+ end if;
+ end Check_Type_Or_Object_External_Properties;
+
-----------------------------
-- Analyze_Object_Contract --
-----------------------------
@@ -739,15 +1004,10 @@ package body Contracts is
Saved_SMP : constant Node_Id := SPARK_Mode_Pragma;
-- Save the SPARK_Mode-related data to restore on exit
- AR_Val : Boolean := False;
- AW_Val : Boolean := False;
- ER_Val : Boolean := False;
- EW_Val : Boolean := False;
NC_Val : Boolean := False;
Items : Node_Id;
Prag : Node_Id;
Ref_Elmt : Elmt_Id;
- Seen : Boolean := False;
begin
-- The loop parameter in an element iterator over a formal container
@@ -814,41 +1074,8 @@ package body Contracts is
else pragma Assert (Ekind (Obj_Id) = E_Variable);
- -- Analyze all external properties
-
- Prag := Get_Pragma (Obj_Id, Pragma_Async_Readers);
-
- if Present (Prag) then
- Analyze_External_Property_In_Decl_Part (Prag, AR_Val);
- Seen := True;
- end if;
-
- Prag := Get_Pragma (Obj_Id, Pragma_Async_Writers);
-
- if Present (Prag) then
- Analyze_External_Property_In_Decl_Part (Prag, AW_Val);
- Seen := True;
- end if;
-
- Prag := Get_Pragma (Obj_Id, Pragma_Effective_Reads);
-
- if Present (Prag) then
- Analyze_External_Property_In_Decl_Part (Prag, ER_Val);
- Seen := True;
- end if;
-
- Prag := Get_Pragma (Obj_Id, Pragma_Effective_Writes);
-
- if Present (Prag) then
- Analyze_External_Property_In_Decl_Part (Prag, EW_Val);
- Seen := True;
- end if;
-
- -- Verify the mutual interaction of the various external properties
-
- if Seen then
- Check_External_Properties (Obj_Id, AR_Val, AW_Val, ER_Val, EW_Val);
- end if;
+ Check_Type_Or_Object_External_Properties
+ (Type_Or_Obj_Id => Obj_Id);
-- Analyze the non-external volatility property No_Caching
@@ -858,10 +1085,10 @@ package body Contracts is
Analyze_External_Property_In_Decl_Part (Prag, NC_Val);
end if;
- -- The anonymous object created for a single concurrent type carries
- -- pragmas Depends and Globat of the type.
+ -- The anonymous object created for a single task type carries
+ -- pragmas Depends and Global of the type.
- if Is_Single_Concurrent_Object (Obj_Id) then
+ if Is_Single_Task_Object (Obj_Id) then
-- Analyze Global first, as Depends may mention items classified
-- in the global categorization.
@@ -912,47 +1139,6 @@ package body Contracts is
else
Check_Missing_Part_Of (Obj_Id);
end if;
-
- -- The following checks are relevant only when SPARK_Mode is on, as
- -- they are not standard Ada legality rules. Internally generated
- -- temporaries are ignored.
-
- if SPARK_Mode = On and then Comes_From_Source (Obj_Id) then
- if Is_Effectively_Volatile (Obj_Id) then
-
- -- The declaration of an effectively volatile object must
- -- appear at the library level (SPARK RM 7.1.3(3), C.6(6)).
-
- if not Is_Library_Level_Entity (Obj_Id) then
- Error_Msg_N
- ("volatile variable & must be declared at library level "
- & "(SPARK RM 7.1.3(3))", Obj_Id);
-
- -- An object of a discriminated type cannot be effectively
- -- volatile except for protected objects (SPARK RM 7.1.3(5)).
-
- elsif Has_Discriminants (Obj_Typ)
- and then not Is_Protected_Type (Obj_Typ)
- then
- Error_Msg_N
- ("discriminated object & cannot be volatile", Obj_Id);
- end if;
-
- -- The object is not effectively volatile
-
- else
- -- A non-effectively volatile object cannot have effectively
- -- volatile components (SPARK RM 7.1.3(6)).
-
- if not Is_Effectively_Volatile (Obj_Id)
- and then Has_Volatile_Component (Obj_Typ)
- then
- Error_Msg_N
- ("non-volatile object & cannot have volatile components",
- Obj_Id);
- end if;
- end if;
- end if;
end if;
-- Common checks
@@ -1305,6 +1491,16 @@ package body Contracts is
Restore_SPARK_Mode (Saved_SM, Saved_SMP);
end Analyze_Task_Contract;
+ ---------------------------
+ -- Analyze_Type_Contract --
+ ---------------------------
+
+ procedure Analyze_Type_Contract (Type_Id : Entity_Id) is
+ begin
+ Check_Type_Or_Object_External_Properties
+ (Type_Or_Obj_Id => Type_Id);
+ end Analyze_Type_Contract;
+
-----------------------------
-- Create_Generic_Contract --
-----------------------------
@@ -1670,13 +1866,15 @@ package body Contracts is
Add_Invariant_Access_Checks (Result);
end if;
- -- Add invariant and predicates for all formals that qualify
+ -- Add invariant checks for all formals that qualify (see AI05-0289
+ -- and AI12-0044).
Formal := First_Formal (Subp_Id);
while Present (Formal) loop
Typ := Etype (Formal);
if Ekind (Formal) /= E_In_Parameter
+ or else Ekind (Subp_Id) = E_Procedure
or else Is_Access_Type (Typ)
then
if Invariant_Checks_OK (Typ) then
@@ -2407,7 +2605,9 @@ package body Contracts is
Freeze_Expr_Types
(Def_Id => Subp_Id,
Typ => Standard_Boolean,
- Expr => Expression (Corresponding_Aspect (Prag)),
+ Expr =>
+ Expression
+ (First (Pragma_Argument_Associations (Prag))),
N => Body_Decl);
end if;
@@ -2543,11 +2743,6 @@ package body Contracts is
if not Expander_Active then
return;
- -- ASIS requires an unaltered tree
-
- elsif ASIS_Mode then
- return;
-
-- GNATprove does not need the executable semantics of a contract
elsif GNATprove_Mode then
@@ -2687,12 +2882,9 @@ package body Contracts is
function Causes_Contract_Freezing (N : Node_Id) return Boolean is
begin
- return Nkind_In (N, N_Entry_Body,
- N_Package_Body,
- N_Protected_Body,
- N_Subprogram_Body,
- N_Subprogram_Body_Stub,
- N_Task_Body);
+ return Nkind (N) in
+ N_Entry_Body | N_Package_Body | N_Protected_Body |
+ N_Subprogram_Body | N_Subprogram_Body_Stub | N_Task_Body;
end Causes_Contract_Freezing;
----------------------
@@ -2727,10 +2919,10 @@ package body Contracts is
-- Entry or subprogram declarations
- elsif Nkind_In (Decl, N_Abstract_Subprogram_Declaration,
- N_Entry_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Subprogram_Declaration)
+ elsif Nkind (Decl) in N_Abstract_Subprogram_Declaration
+ | N_Entry_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Subprogram_Declaration
then
Analyze_Entry_Or_Subprogram_Contract
(Subp_Id => Defining_Entity (Decl),
@@ -2745,8 +2937,8 @@ package body Contracts is
-- Protected units
- elsif Nkind_In (Decl, N_Protected_Type_Declaration,
- N_Single_Protected_Declaration)
+ elsif Nkind (Decl) in N_Protected_Type_Declaration
+ | N_Single_Protected_Declaration
then
Analyze_Protected_Contract (Defining_Entity (Decl));
@@ -2757,12 +2949,21 @@ package body Contracts is
-- Task units
- elsif Nkind_In (Decl, N_Single_Task_Declaration,
- N_Task_Type_Declaration)
+ elsif Nkind (Decl) in N_Single_Task_Declaration
+ | N_Task_Type_Declaration
then
Analyze_Task_Contract (Defining_Entity (Decl));
end if;
+ if Nkind (Decl) in N_Full_Type_Declaration
+ | N_Private_Type_Declaration
+ | N_Task_Type_Declaration
+ | N_Protected_Type_Declaration
+ | N_Formal_Type_Declaration
+ then
+ Analyze_Type_Contract (Defining_Identifier (Decl));
+ end if;
+
Prev (Decl);
end loop;
end Freeze_Contracts;
diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads
index ca99c34..9e7b955 100644
--- a/gcc/ada/contracts.ads
+++ b/gcc/ada/contracts.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2015-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,8 +33,8 @@ package Contracts is
procedure Add_Contract_Item (Prag : Node_Id; Id : Entity_Id);
-- Add pragma Prag to the contract of a constant, entry, entry family,
-- [generic] package, package body, protected unit, [generic] subprogram,
- -- subprogram body, variable or task unit denoted by Id. The following are
- -- valid pragmas:
+ -- subprogram body, variable, task unit, or type denoted by Id.
+ -- The following are valid pragmas:
--
-- Abstract_State
-- Async_Readers
@@ -114,6 +114,19 @@ package Contracts is
-- Freeze_Id is the entity of a [generic] package body or a [generic]
-- subprogram body which "freezes" the contract of Obj_Id.
+ procedure Analyze_Type_Contract (Type_Id : Entity_Id);
+ -- Analyze all delayed pragmas chained on the contract of object Obj_Id as
+ -- if they appeared at the end of the declarative region. The pragmas to be
+ -- considered are:
+ --
+ -- Async_Readers
+ -- Async_Writers
+ -- Effective_Reads
+ -- Effective_Writes
+ --
+ -- In the case of a protected or task type, there will also be
+ -- a call to Analyze_Protected_Contract or Analyze_Task_Contract.
+
procedure Analyze_Package_Body_Contract
(Body_Id : Entity_Id;
Freeze_Id : Entity_Id := Empty);
diff --git a/gcc/ada/csets.adb b/gcc/ada/csets.adb
index b945115..ed3166b 100644
--- a/gcc/ada/csets.adb
+++ b/gcc/ada/csets.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/csets.ads b/gcc/ada/csets.ads
index fb07346..1fdff40 100644
--- a/gcc/ada/csets.ads
+++ b/gcc/ada/csets.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/csinfo.adb b/gcc/ada/csinfo.adb
index 8aac17d..635a2a5 100644
--- a/gcc/ada/csinfo.adb
+++ b/gcc/ada/csinfo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -89,10 +89,10 @@ procedure CSinfo is
Flags : TV.Table (20);
-- Maps flag numbers to letters
- N_Fields : constant Pattern := BreakX ("JL");
- E_Fields : constant Pattern := BreakX ("5EFGHIJLOP");
- U_Fields : constant Pattern := BreakX ("1345EFGHIJKLOPQ");
- B_Fields : constant Pattern := BreakX ("12345EFGHIJKLOPQ");
+ N_Fields : constant Pattern := BreakX ("J");
+ E_Fields : constant Pattern := BreakX ("5EFGHIJOP");
+ U_Fields : constant Pattern := BreakX ("1345EFGHIJKOPQ");
+ B_Fields : constant Pattern := BreakX ("12345EFGHIJKOPQ");
Line : VString;
Bad : Boolean;
@@ -215,7 +215,6 @@ begin
Set (Special, "First_Itype", True);
Set (Special, "Has_Aspect_Specifications", True);
Set (Special, "Has_Dynamic_Itype", True);
- Set (Special, "Has_Dynamic_Range_Check", True);
Set (Special, "Has_Dynamic_Length_Check", True);
Set (Special, "Has_Private_View", True);
Set (Special, "Is_Controlling_Actual", True);
diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb
index 5f3d69f..71d40e9 100644
--- a/gcc/ada/cstand.adb
+++ b/gcc/ada/cstand.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -48,8 +48,8 @@ with Urealp; use Urealp;
package body CStand is
- Stloc : constant Source_Ptr := Standard_Location;
- Staloc : constant Source_Ptr := Standard_ASCII_Location;
+ Stloc : Source_Ptr renames Standard_Location;
+ Staloc : Source_Ptr renames Standard_ASCII_Location;
-- Standard abbreviations used throughout this package
Back_End_Float_Types : Elist_Id := No_Elist;
@@ -85,14 +85,11 @@ package body CStand is
-- is the size in bits. The corresponding base type is not built by
-- this routine but instead must be built by the caller where needed.
- procedure Build_Unsigned_Integer_Type
- (Uns : Entity_Id;
- Siz : Nat;
- Nam : String);
+ procedure Build_Unsigned_Integer_Type (Uns : Entity_Id; Siz : Nat);
-- Procedure to build standard predefined unsigned integer subtype. These
-- subtypes are not user visible, but they are used internally. The first
-- parameter is the entity for the subtype. The second parameter is the
- -- size in bits. The third parameter is an identifying name.
+ -- size in bits.
procedure Copy_Float_Type (To : Entity_Id; From : Entity_Id);
-- Build a floating point type, copying representation details from From.
@@ -129,8 +126,8 @@ package body CStand is
-- These are not generally valid identifier names.
function Identifier_For (S : Standard_Entity_Type) return Node_Id;
- -- Returns an identifier node with the same name as the defining
- -- identifier corresponding to the given Standard_Entity_Type value
+ -- Returns an identifier node with the same name as the defining identifier
+ -- corresponding to the given Standard_Entity_Type value.
procedure Make_Component
(Rec : Entity_Id;
@@ -139,17 +136,12 @@ package body CStand is
-- Build a record component with the given type and name, and append to
-- the list of components of Rec.
- function Make_Formal
- (Typ : Entity_Id;
- Formal_Name : String) return Entity_Id;
+ function Make_Formal (Typ : Entity_Id; Nam : String) return Entity_Id;
-- Construct entity for subprogram formal with given name and type
function Make_Integer (V : Uint) return Node_Id;
-- Builds integer literal with given value
- procedure Make_Name (Id : Entity_Id; Nam : String);
- -- Make an entry in the names table for Nam, and set as Chars field of Id
-
function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id;
-- Build entity for standard operator with given name and type
@@ -157,9 +149,9 @@ package body CStand is
(New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id;
-- Builds a new entity for Standard
- function New_Standard_Entity (S : String) return Entity_Id;
+ function New_Standard_Entity (Nam : String) return Entity_Id;
-- Builds a new entity for Standard with Nkind = N_Defining_Identifier,
- -- and Chars of this defining identifier set to the given string S.
+ -- and Chars of this defining identifier set to the given string Nam.
procedure Print_Standard;
-- Print representation of package Standard if switch set
@@ -268,16 +260,13 @@ package body CStand is
procedure Build_Unsigned_Integer_Type
(Uns : Entity_Id;
- Siz : Nat;
- Nam : String)
+ Siz : Nat)
is
- Decl : Node_Id;
- R_Node : Node_Id;
+ Decl : constant Node_Id := New_Node (N_Full_Type_Declaration, Stloc);
+ R_Node : constant Node_Id := New_Node (N_Range, Stloc);
begin
- Decl := New_Node (N_Full_Type_Declaration, Stloc);
Set_Defining_Identifier (Decl, Uns);
- Make_Name (Uns, Nam);
Set_Ekind (Uns, E_Modular_Integer_Type);
Set_Scope (Uns, Standard_Standard);
@@ -289,7 +278,6 @@ package body CStand is
Set_Size_Known_At_Compile_Time (Uns);
Set_Is_Known_Valid (Uns, True);
- R_Node := New_Node (N_Range, Stloc);
Set_Low_Bound (R_Node, Make_Integer (Uint_0));
Set_High_Bound (R_Node, Make_Integer (Modulus (Uns) - 1));
Set_Etype (Low_Bound (R_Node), Uns);
@@ -553,20 +541,18 @@ package body CStand is
----------------------
procedure Make_Dummy_Index (E : Entity_Id) is
- Index : Node_Id;
- Dummy : List_Id;
-
- begin
- Index :=
+ Index : constant Node_Id :=
Make_Range (Sloc (E),
Low_Bound => Make_Integer (Uint_0),
High_Bound => Make_Integer (Uint_2 ** Standard_Integer_Size));
- Set_Etype (Index, Standard_Integer);
- Set_First_Index (E, Index);
-- Make sure Index is a list as required, so Next_Index is Empty
- Dummy := New_List (Index);
+ Dummy : constant List_Id := New_List (Index);
+
+ begin
+ Set_Etype (Index, Standard_Integer);
+ Set_First_Index (E, Index);
end Make_Dummy_Index;
----------------------
@@ -581,6 +567,7 @@ package body CStand is
New_List (
Make_Pragma_Argument_Association (Stloc,
Expression => New_Occurrence_Of (String_Type, Stloc))));
+
begin
Append (Prag, Decl_S);
Record_Rep_Item (String_Type, Prag);
@@ -601,8 +588,7 @@ package body CStand is
-- Defining identifier node
begin
- Ident_Node := New_Standard_Entity;
- Make_Name (Ident_Node, S_Name (3 .. S_Name'Length));
+ Ident_Node := New_Standard_Entity (S_Name (3 .. S_Name'Length));
Standard_Entity (S) := Ident_Node;
end;
end loop;
@@ -1110,11 +1096,10 @@ package body CStand is
-- Create semantic phase entities
- Standard_Void_Type := New_Standard_Entity;
+ Standard_Void_Type := New_Standard_Entity ("_void_type");
Set_Ekind (Standard_Void_Type, E_Void);
Set_Etype (Standard_Void_Type, Standard_Void_Type);
Set_Scope (Standard_Void_Type, Standard_Standard);
- Make_Name (Standard_Void_Type, "_void_type");
-- The type field of packages is set to void
@@ -1124,7 +1109,7 @@ package body CStand is
-- Standard_A_String is actually used in generated code, so it has a
-- type name that is reasonable, but does not overlap any Ada name.
- Standard_A_String := New_Standard_Entity;
+ Standard_A_String := New_Standard_Entity ("access_string");
Set_Ekind (Standard_A_String, E_Access_Type);
Set_Scope (Standard_A_String, Standard_Standard);
Set_Etype (Standard_A_String, Standard_A_String);
@@ -1139,9 +1124,8 @@ package body CStand is
Set_Directly_Designated_Type
(Standard_A_String, Standard_String);
- Make_Name (Standard_A_String, "access_string");
- Standard_A_Char := New_Standard_Entity;
+ Standard_A_Char := New_Standard_Entity ("access_character");
Set_Ekind (Standard_A_Char, E_Access_Type);
Set_Scope (Standard_A_Char, Standard_Standard);
Set_Etype (Standard_A_Char, Standard_A_String);
@@ -1149,14 +1133,13 @@ package body CStand is
Set_Elem_Alignment (Standard_A_Char);
Set_Directly_Designated_Type (Standard_A_Char, Standard_Character);
- Make_Name (Standard_A_Char, "access_character");
-- Standard_Debug_Renaming_Type is used for the special objects created
-- to encode the names occurring in renaming declarations for use by the
-- debugger (see exp_dbug.adb). The type is a zero-sized subtype of
-- Standard.Integer.
- Standard_Debug_Renaming_Type := New_Standard_Entity;
+ Standard_Debug_Renaming_Type := New_Standard_Entity ("_renaming_type");
Set_Ekind (Standard_Debug_Renaming_Type, E_Signed_Integer_Subtype);
Set_Scope (Standard_Debug_Renaming_Type, Standard_Standard);
@@ -1171,8 +1154,6 @@ package body CStand is
Set_Is_Constrained (Standard_Debug_Renaming_Type);
Set_Has_Size_Clause (Standard_Debug_Renaming_Type);
- Make_Name (Standard_Debug_Renaming_Type, "_renaming_type");
-
-- Note on type names. The type names for the following special types
-- are constructed so that they will look reasonable should they ever
-- appear in error messages etc, although in practice the use of the
@@ -1341,41 +1322,39 @@ package body CStand is
-- used internally. They are unsigned types with the same length as
-- the correspondingly named signed integer types.
- Standard_Short_Short_Unsigned := New_Standard_Entity;
+ Standard_Short_Short_Unsigned
+ := New_Standard_Entity ("short_short_unsigned");
Build_Unsigned_Integer_Type
- (Standard_Short_Short_Unsigned,
- Standard_Short_Short_Integer_Size,
- "short_short_unsigned");
+ (Standard_Short_Short_Unsigned, Standard_Short_Short_Integer_Size);
- Standard_Short_Unsigned := New_Standard_Entity;
+ Standard_Short_Unsigned := New_Standard_Entity ("short_unsigned");
Build_Unsigned_Integer_Type
- (Standard_Short_Unsigned,
- Standard_Short_Integer_Size,
- "short_unsigned");
+ (Standard_Short_Unsigned, Standard_Short_Integer_Size);
- Standard_Unsigned := New_Standard_Entity;
+ Standard_Unsigned := New_Standard_Entity ("unsigned");
Build_Unsigned_Integer_Type
- (Standard_Unsigned,
- Standard_Integer_Size,
- "unsigned");
+ (Standard_Unsigned, Standard_Integer_Size);
- Standard_Long_Unsigned := New_Standard_Entity;
+ Standard_Long_Unsigned := New_Standard_Entity ("long_unsigned");
Build_Unsigned_Integer_Type
- (Standard_Long_Unsigned,
- Standard_Long_Integer_Size,
- "long_unsigned");
+ (Standard_Long_Unsigned, Standard_Long_Integer_Size);
- Standard_Long_Long_Unsigned := New_Standard_Entity;
+ Standard_Long_Long_Unsigned
+ := New_Standard_Entity ("long_long_unsigned");
Build_Unsigned_Integer_Type
- (Standard_Long_Long_Unsigned,
- Standard_Long_Long_Integer_Size,
- "long_long_unsigned");
+ (Standard_Long_Long_Unsigned, Standard_Long_Long_Integer_Size);
-- Standard_Unsigned_64 is not user visible, but is used internally. It
- -- is an unsigned type mod 2**64, 64-bits unsigned, size is 64.
+ -- is an unsigned type mod 2**64 with 64 bits size.
+
+ Standard_Unsigned_64 := New_Standard_Entity ("unsigned_64");
+ Build_Unsigned_Integer_Type (Standard_Unsigned_64, 64);
- Standard_Unsigned_64 := New_Standard_Entity;
- Build_Unsigned_Integer_Type (Standard_Unsigned_64, 64, "unsigned_64");
+ -- Standard_Address is not user visible, but is used internally. It is
+ -- an unsigned type mod 2**System_Address_Size with System.Address size.
+
+ Standard_Address := New_Standard_Entity ("standard_address");
+ Build_Unsigned_Integer_Type (Standard_Address, System_Address_Size);
-- Note: universal integer and universal real are constructed as fully
-- formed signed numeric types, with parameters corresponding to the
@@ -1383,28 +1362,25 @@ package body CStand is
-- allows Gigi to properly process references to universal types that
-- are not folded at compile time.
- Universal_Integer := New_Standard_Entity;
+ Universal_Integer := New_Standard_Entity ("universal_integer");
Decl := New_Node (N_Full_Type_Declaration, Stloc);
Set_Defining_Identifier (Decl, Universal_Integer);
- Make_Name (Universal_Integer, "universal_integer");
Set_Scope (Universal_Integer, Standard_Standard);
Build_Signed_Integer_Type
(Universal_Integer, Standard_Long_Long_Integer_Size);
- Universal_Real := New_Standard_Entity;
+ Universal_Real := New_Standard_Entity ("universal_real");
Decl := New_Node (N_Full_Type_Declaration, Stloc);
Set_Defining_Identifier (Decl, Universal_Real);
- Make_Name (Universal_Real, "universal_real");
Set_Scope (Universal_Real, Standard_Standard);
Copy_Float_Type (Universal_Real, Standard_Long_Long_Float);
-- Note: universal fixed, unlike universal integer and universal real,
-- is never used at runtime, so it does not need to have bounds set.
- Universal_Fixed := New_Standard_Entity;
+ Universal_Fixed := New_Standard_Entity ("universal_fixed");
Decl := New_Node (N_Full_Type_Declaration, Stloc);
Set_Defining_Identifier (Decl, Universal_Fixed);
- Make_Name (Universal_Fixed, "universal_fixed");
Set_Ekind (Universal_Fixed, E_Ordinary_Fixed_Point_Type);
Set_Etype (Universal_Fixed, Universal_Fixed);
Set_Scope (Universal_Fixed, Standard_Standard);
@@ -1495,7 +1471,7 @@ package body CStand is
-- known by the run-time. Components of the record are documented in
-- the declaration in System.Standard_Library.
- Standard_Exception_Type := New_Standard_Entity;
+ Standard_Exception_Type := New_Standard_Entity ("exception");
Set_Ekind (Standard_Exception_Type, E_Record_Type);
Set_Etype (Standard_Exception_Type, Standard_Exception_Type);
Set_Scope (Standard_Exception_Type, Standard_Standard);
@@ -1504,7 +1480,6 @@ package body CStand is
Init_Size_Align (Standard_Exception_Type);
Set_Size_Known_At_Compile_Time
(Standard_Exception_Type, True);
- Make_Name (Standard_Exception_Type, "exception");
Make_Component
(Standard_Exception_Type, Standard_Boolean, "Not_Handled_By_Others");
@@ -1566,7 +1541,9 @@ package body CStand is
Build_Exception (S_Tasking_Error);
-- Numeric_Error is a normal exception in Ada 83, but in Ada 95
- -- it is a renaming of Constraint_Error. Is this test too early???
+ -- it is a renaming of Constraint_Error. This test is too early since
+ -- it doesn't handle pragma Ada_83. But it's not worth the trouble of
+ -- fixing this.
if Ada_Version = Ada_83 then
Build_Exception (S_Numeric_Error);
@@ -1694,7 +1671,6 @@ package body CStand is
Set_Etype (Low_Bound (Scalar_Range (E)), New_Ent);
Set_Etype (High_Bound (Scalar_Range (E)), New_Ent);
end if;
-
end Create_Unconstrained_Base_Type;
--------------------
@@ -1702,11 +1678,12 @@ package body CStand is
--------------------
function Identifier_For (S : Standard_Entity_Type) return Node_Id is
- Ident_Node : Node_Id;
+ Ident_Node : constant Node_Id := New_Node (N_Identifier, Stloc);
+
begin
- Ident_Node := New_Node (N_Identifier, Stloc);
Set_Chars (Ident_Node, Chars (Standard_Entity (S)));
Set_Entity (Ident_Node, Standard_Entity (S));
+
return Ident_Node;
end Identifier_For;
@@ -1719,16 +1696,14 @@ package body CStand is
Typ : Entity_Id;
Nam : String)
is
- Id : constant Entity_Id := New_Standard_Entity;
+ Id : constant Entity_Id := New_Standard_Entity (Nam);
begin
- Set_Ekind (Id, E_Component);
- Set_Etype (Id, Typ);
- Set_Scope (Id, Rec);
- Init_Component_Location (Id);
-
+ Set_Ekind (Id, E_Component);
+ Set_Etype (Id, Typ);
+ Set_Scope (Id, Rec);
+ Init_Component_Location (Id);
Set_Original_Record_Component (Id, Id);
- Make_Name (Id, Nam);
Append_Entity (Id, Rec);
end Make_Component;
@@ -1736,20 +1711,14 @@ package body CStand is
-- Make_Formal --
-----------------
- function Make_Formal
- (Typ : Entity_Id;
- Formal_Name : String) return Entity_Id
- is
- Formal : Entity_Id;
+ function Make_Formal (Typ : Entity_Id; Nam : String) return Entity_Id is
+ Formal : constant Entity_Id := New_Standard_Entity (Nam);
begin
- Formal := New_Standard_Entity;
-
Set_Ekind (Formal, E_In_Parameter);
Set_Mechanism (Formal, Default_Mechanism);
Set_Scope (Formal, Standard_Standard);
Set_Etype (Formal, Typ);
- Make_Name (Formal, Formal_Name);
return Formal;
end Make_Formal;
@@ -1760,35 +1729,21 @@ package body CStand is
function Make_Integer (V : Uint) return Node_Id is
N : constant Node_Id := Make_Integer_Literal (Stloc, V);
+
begin
Set_Is_Static_Expression (N);
+
return N;
end Make_Integer;
- ---------------
- -- Make_Name --
- ---------------
-
- procedure Make_Name (Id : Entity_Id; Nam : String) is
- begin
- for J in 1 .. Nam'Length loop
- Name_Buffer (J) := Fold_Lower (Nam (Nam'First + (J - 1)));
- end loop;
-
- Name_Len := Nam'Length;
- Set_Chars (Id, Name_Find);
- end Make_Name;
-
------------------
-- New_Operator --
------------------
function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id is
- Ident_Node : Entity_Id;
+ Ident_Node : constant Entity_Id := Make_Defining_Identifier (Stloc, Op);
begin
- Ident_Node := Make_Defining_Identifier (Stloc, Op);
-
Set_Is_Pure (Ident_Node, True);
Set_Ekind (Ident_Node, E_Operator);
Set_Etype (Ident_Node, Typ);
@@ -1796,11 +1751,12 @@ package body CStand is
Set_Homonym (Ident_Node, Get_Name_Entity_Id (Op));
Set_Convention (Ident_Node, Convention_Intrinsic);
- Set_Is_Immediately_Visible (Ident_Node, True);
- Set_Is_Intrinsic_Subprogram (Ident_Node, True);
+ Set_Is_Immediately_Visible (Ident_Node, True);
+ Set_Is_Intrinsic_Subprogram (Ident_Node, True);
Set_Name_Entity_Id (Op, Ident_Node);
Append_Entity (Ident_Node, Standard_Standard);
+
return Ident_Node;
end New_Operator;
@@ -1838,10 +1794,17 @@ package body CStand is
return E;
end New_Standard_Entity;
- function New_Standard_Entity (S : String) return Entity_Id is
+ function New_Standard_Entity (Nam : String) return Entity_Id is
Ent : constant Entity_Id := New_Standard_Entity;
+
begin
- Make_Name (Ent, S);
+ for J in 1 .. Nam'Length loop
+ Name_Buffer (J) := Fold_Lower (Nam (Nam'First + (J - 1)));
+ end loop;
+
+ Name_Len := Nam'Length;
+ Set_Chars (Ent, Name_Find);
+
return Ent;
end New_Standard_Entity;
@@ -2076,11 +2039,10 @@ package body CStand is
pragma Unreferenced (Precision);
-- See Build_Float_Type for the rationale
- Ent : constant Entity_Id := New_Standard_Entity;
+ Ent : constant Entity_Id := New_Standard_Entity (Name);
begin
Set_Defining_Identifier (New_Node (N_Full_Type_Declaration, Stloc), Ent);
- Make_Name (Ent, Name);
Set_Scope (Ent, Standard_Standard);
Build_Float_Type
(Ent, Pos (Digs), Float_Rep, Int (Size), Int (Alignment / 8));
diff --git a/gcc/ada/cstand.ads b/gcc/ada/cstand.ads
index f2c3e8b..f2873ef 100644
--- a/gcc/ada/cstand.ads
+++ b/gcc/ada/cstand.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/cstreams.c b/gcc/ada/cstreams.c
index 92392fc..4e00ded 100644
--- a/gcc/ada/cstreams.c
+++ b/gcc/ada/cstreams.c
@@ -6,7 +6,7 @@
* *
* Auxiliary C functions for Interfaces.C.Streams *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/ctrl_c.c b/gcc/ada/ctrl_c.c
index 0e427ea..72d6a5b 100644
--- a/gcc/ada/ctrl_c.c
+++ b/gcc/ada/ctrl_c.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2002-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2002-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index 032d88a..0e4a530 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -69,7 +69,7 @@ package body Debug is
-- dC Output debugging information on check suppression
-- dD Delete elaboration checks in inner level routines
-- dE Apply elaboration checks to predefined units
- -- dF Perform the new SPARK checking rules for pointer aliasing
+ -- dF
-- dG Generate all warnings including those normally suppressed
-- dH Hold (kill) call to gigi
-- dI Inhibit internal name numbering in gnatG listing
@@ -118,17 +118,17 @@ package body Debug is
-- d.y Disable implicit pragma Elaborate_All on task bodies
-- d.z Restore previous support for frontend handling of Inline_Always
- -- d.A Read/write Aspect_Specifications hash table to tree
+ -- d.A
-- d.B Generate a bug box on abort_statement
-- d.C Generate concatenation call, do not generate inline code
-- d.D Disable errors on use of overriding keyword in Ada 95 mode
-- d.E Turn selected errors into warnings
-- d.F Debug mode for GNATprove
-- d.G Ignore calls through generic formal parameters for elaboration
- -- d.H GNSA mode for ASIS
+ -- d.H
-- d.I Do not ignore enum representation clauses in CodePeer mode
-- d.J Relaxed rules for pragma No_Return
- -- d.K
+ -- d.K Do not reject components in extensions overlapping with parent
-- d.L Depend on back end for limited types in if and case expressions
-- d.M Relaxed RM semantics
-- d.N Add node to all entities
@@ -170,10 +170,10 @@ package body Debug is
-- d_w
-- d_x
-- d_y
- -- d_z
+ -- d_z Enable Put_Image on tagged types
-- d_A Stop generation of ALI file
- -- d_B
+ -- d_B Warn on build-in-place function calls
-- d_C
-- d_D
-- d_E
@@ -193,7 +193,7 @@ package body Debug is
-- d_S
-- d_T Output trace information on invocation path recording
-- d_U
- -- d_V
+ -- d_V Enable verifications on the expanded tree
-- d_W
-- d_X
-- d_Y
@@ -602,12 +602,6 @@ package body Debug is
-- dE Apply compile time elaboration checking for with relations between
-- predefined units. Normally no checks are made.
- -- dF Disable the new SPARK checking rules for pointer aliasing. This is
- -- only activated as part of GNATprove mode and on SPARK code. Now
- -- that pointer support is part of the official SPARK language, this
- -- switch allows reverting to the previous version of GNATprove
- -- rejecting pointers.
-
-- dG Generate all warnings. Normally Errout suppresses warnings on
-- units that are not part of the main extended source, and also
-- suppresses warnings on instantiations in the main extended
@@ -847,11 +841,6 @@ package body Debug is
-- handling of Inline_Always by the front end on such targets. For the
-- targets that do not use the GCC back end, this switch is ignored.
- -- d.A There seems to be a problem with ASIS if we activate the circuit
- -- for reading and writing the aspect specification hash table, so
- -- for now, this is controlled by the debug flag d.A. The hash table
- -- is only written and read if this flag is set.
-
-- d.B Generate a bug box when we see an abort_statement, even though
-- there is no bug. Useful for testing Comperr.Compiler_Abort: write
-- some code containing an abort_statement, and compile it with
@@ -892,9 +881,6 @@ package body Debug is
-- now fixed, but we provide this debug flag to revert to the previous
-- situation of ignoring such calls to aid in transition.
- -- d.H Sets ASIS_GNSA_Mode to True. This signals the front end to suppress
- -- the call to gigi in ASIS_Mode.
-
-- d.I Do not ignore enum representation clauses in CodePeer mode.
-- The default of ignoring representation clauses for enumeration
-- types in CodePeer is good for the majority of Ada code, but in some
@@ -906,6 +892,11 @@ package body Debug is
-- for that. If the procedure does in fact return normally, execution
-- is erroneous, and therefore unpredictable.
+ -- d.K Do not reject components in extensions overlapping with the parent
+ -- component. Such components can be specified by means of a component
+ -- clause but they cannot be fully supported by the GCC type system.
+ -- This switch nevertheless allows them for the sake of compatibility.
+
-- d.L Normally the front end generates special expansion for conditional
-- expressions of a limited type. This debug flag removes this special
-- case expansion, leaving it up to the back end to handle conditional
@@ -1001,8 +992,15 @@ package body Debug is
-- a call to routine Ada.Synchronous_Task_Control.Suspend_Until_True
-- or Ada.Synchronous_Barriers.Wait_For_Release.
+ -- d_z Enable the default Put_Image on tagged types that are not
+ -- predefined.
+
-- d_A Do not generate ALI files by setting Opt.Disable_ALI_File.
+ -- d_B Warn on build-in-place function calls. This allows users to
+ -- inspect their code in case it triggers compiler bugs related
+ -- to build-in-place calls. See known-problem entries for details.
+
-- d_F The compiler encodes the full path from an invocation construct to
-- an external target, offering additional information to GNATBIND for
-- purposes of error diagnostics.
@@ -1015,9 +1013,12 @@ package body Debug is
-- it is checked, and the progress of the recursive trace through
-- elaboration calls at compile time.
- -- d_T The compiler outputs trance information to standard output whenever
+ -- d_T The compiler outputs trace information to standard output whenever
-- an invocation path is recorded.
+ -- d_V Enable verification of the expanded code before calling the backend
+ -- and generate error messages on each inconsistency found.
+
-- d1 Error messages have node numbers where possible. Normally error
-- messages have only source locations. This option is useful when
-- debugging errors caused by expanded code, where the source location
diff --git a/gcc/ada/debug.ads b/gcc/ada/debug.ads
index 2bbaae6..ccc9d11 100644
--- a/gcc/ada/debug.ads
+++ b/gcc/ada/debug.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/debug_a.adb b/gcc/ada/debug_a.adb
index 7228fba..d3a1424 100644
--- a/gcc/ada/debug_a.adb
+++ b/gcc/ada/debug_a.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/debug_a.ads b/gcc/ada/debug_a.ads
index 44ced10..d352525 100644
--- a/gcc/ada/debug_a.ads
+++ b/gcc/ada/debug_a.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/doc/gnat_rm/implementation_advice.rst b/gcc/ada/doc/gnat_rm/implementation_advice.rst
index 31376d9..998d0c5 100644
--- a/gcc/ada/doc/gnat_rm/implementation_advice.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_advice.rst
@@ -712,43 +712,20 @@ RM 13.13.2(1.6): Stream Oriented Attributes
to the nearest factor or multiple of the word size that is also a
multiple of the stream element size."
-Followed, except that the number of stream elements is a power of 2.
+Followed, except that the number of stream elements is 1, 2, 3, 4 or 8.
The Stream_Size may be used to override the default choice.
-However, such an implementation is based on direct binary
-representations and is therefore target- and endianness-dependent. To
-address this issue, GNAT also supplies an alternate implementation of
-the stream attributes ``Read`` and ``Write``, which uses the
-target-independent XDR standard representation for scalar types.
+The default implementation is based on direct binary representations and is
+therefore target- and endianness-dependent. To address this issue, GNAT also
+supplies an alternate implementation of the stream attributes ``Read`` and
+``Write``, which uses the target-independent XDR standard representation for
+scalar types. This XDR alternative can be enabled via the binder switch -xdr.
.. index:: XDR representation
-
.. index:: Read attribute
-
.. index:: Write attribute
-
.. index:: Stream oriented attributes
-The XDR implementation is provided as an alternative body of the
-``System.Stream_Attributes`` package, in the file
-:file:`s-stratt-xdr.adb` in the GNAT library.
-There is no :file:`s-stratt-xdr.ads` file.
-In order to install the XDR implementation, do the following:
-
-* Replace the default implementation of the
- ``System.Stream_Attributes`` package with the XDR implementation.
- For example on a Unix platform issue the commands:
-
- .. code-block:: sh
-
- $ mv s-stratt.adb s-stratt-default.adb
- $ mv s-stratt-xdr.adb s-stratt.adb
-
-
-*
- Rebuild the GNAT run-time library as documented in
- the *GNAT and Libraries* section of the :title:`GNAT User's Guide`.
-
RM A.1(52): Names of Predefined Numeric Types
=============================================
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
index 89f6718..736710d 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
@@ -464,6 +464,13 @@ Aspect Refined_State
This aspect is equivalent to :ref:`pragma Refined_State<Pragma-Refined_State>`.
+Aspect Relaxed_Initialization
+=============================
+.. index:: Refined_Initialization
+
+For the syntax and semantics of this aspect, see the SPARK 2014 Reference
+Manual, section 6.10.
+
Aspect Remote_Access_Type
=========================
.. index:: Remote_Access_Type
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
index db75ea7..967e9d9 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
@@ -93,8 +93,8 @@ Attribute Bit
``obj'Bit``, where ``obj`` is any object, yields the bit
offset within the storage unit (byte) that contains the first bit of
storage allocated for the object. The value of this attribute is of the
-type *universal_integer*, and is always a non-negative number not
-exceeding the value of ``System.Storage_Unit``.
+type *universal_integer* and is always a nonnegative number smaller
+than ``System.Storage_Unit``.
For an object that is a variable or a constant allocated in a register,
the value is zero. (The use of this attribute does not force the
@@ -241,14 +241,16 @@ the first element of the array.
.. code-block:: ada
- type Unconstr_Array is array (Positive range <>) of Boolean;
+ type Unconstr_Array is array (Short_Short_Integer range <>) of Positive;
Put_Line ("Descriptor size = " & Unconstr_Array'Descriptor_Size'Img);
-The attribute takes into account any additional padding due to type alignment.
-In the example above, the descriptor contains two values of type
-``Positive`` representing the low and high bound. Since ``Positive`` has
-a size of 31 bits and an alignment of 4, the descriptor size is ``2 * Positive'Size + 2`` or 64 bits.
+The attribute takes into account any padding due to the alignment of the
+component type. In the example above, the descriptor contains two values
+of type ``Short_Short_Integer`` representing the low and high bound. But,
+since ``Positive`` has an alignment of 4, the size of the descriptor is
+``2 * Short_Short_Integer'Size`` rounded up to the next multiple of 32,
+which yields a size of 32 bits, i.e. including 16 bits of padding.
Attribute Elaborated
====================
@@ -336,6 +338,9 @@ Attribute Enum_Rep
.. index:: Enum_Rep
+Note that this attribute is now standard in Ada 202x and is available
+as an implementation defined attribute for earlier Ada versions.
+
For every enumeration subtype ``S``, ``S'Enum_Rep`` denotes a
function with the following spec:
@@ -353,7 +358,7 @@ enumeration literal or object.
The function returns the representation value for the given enumeration
value. This will be equal to value of the ``Pos`` attribute in the
absence of an enumeration representation clause. This is a static
-attribute (i.e.,:the result is static if the argument is static).
+attribute (i.e., the result is static if the argument is static).
``S'Enum_Rep`` can also be used with integer types and objects,
in which case it simply returns the integer value. The reason for this
@@ -371,6 +376,9 @@ Attribute Enum_Val
.. index:: Enum_Val
+Note that this attribute is now standard in Ada 202x and is available
+as an implementation defined attribute for earlier Ada versions.
+
For every enumeration subtype ``S``, ``S'Enum_Val`` denotes a
function with the following spec:
@@ -503,6 +511,13 @@ that returns the appropriate string when called. This means that
``X'Img`` can be renamed as a function-returning-string, or used
in an instantiation as a function parameter.
+Attribute Initialized
+=====================
+.. index:: Initialized
+
+For the syntax and semantics of this attribute, see the SPARK 2014 Reference
+Manual, section 6.10.
+
Attribute Integer_Value
=======================
.. index:: Integer_Value
@@ -1608,4 +1623,3 @@ Attribute Word_Size
``Standard'Word_Size`` (``Standard`` is the only permissible
prefix) provides the value ``System.Word_Size``. The result is
a static constant.
-
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
index c3d6f90..737bc60 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
@@ -89,158 +89,6 @@ Syntax:
For the semantics of this pragma, see the entry for aspect ``Abstract_State`` in
the SPARK 2014 Reference Manual, section 7.1.4.
-Pragma Acc_Parallel
-===================
-Syntax:
-
-.. code-block:: ada
-
- pragma Acc_Parallel [( ACC_PARALLEL_CLAUSE [, ACC_PARALLEL_CLAUSE... ])];
-
- ACC_PARALLEL_CLAUSE ::=
- Acc_If => boolean_EXPRESSION
- | Acc_Private => IDENTIFIERS
- | Async => integer_EXPRESSION
- | Copy => IDENTIFIERS
- | Copy_In => IDENTIFIERS
- | Copy_Out => IDENTIFIERS
- | Create => IDENTIFIERS
- | Default => None
- | Device_Ptr => IDENTIFIERS
- | First_Private => IDENTIFIERS
- | Num_Gangs => integer_EXPRESSION
- | Num_Workers => integer_EXPRESSION
- | Present => IDENTIFIERS
- | Reduction => (REDUCTION_RECORD)
- | Vector_Length => integer_EXPRESSION
- | Wait => INTEGERS
-
- REDUCTION_RECORD ::=
- "+" => IDENTIFIERS
- | "*" => IDENTIFIERS
- | "min" => IDENTIFIERS
- | "max" => IDENTIFIERS
- | "or" => IDENTIFIERS
- | "and" => IDENTIFIERS
-
- IDENTIFIERS ::=
- | IDENTIFIER
- | (IDENTIFIER, IDENTIFIERS)
-
- INTEGERS ::=
- | integer_EXPRESSION
- | (integer_EXPRESSION, INTEGERS)
-
-Requires the :switch:`-fopenacc` flag.
-
-Equivalent to the ``parallel`` directive of the OpenAcc standard. This pragma
-should be placed in loops. It offloads the content of the loop to an
-accelerator device.
-
-For more information about the effect of the clauses, see the OpenAcc
-specification.
-
-Pragma Acc_Loop
-===============
-Syntax:
-
-.. code-block:: ada
-
- pragma Acc_Loop [( ACC_LOOP_CLAUSE [, ACC_LOOP_CLAUSE... ])];
-
- ACC_LOOP_CLAUSE ::=
- Auto
- | Collapse => INTEGER_LITERAL
- | Gang [=> GANG_ARG]
- | Independent
- | Private => IDENTIFIERS
- | Reduction => (REDUCTION_RECORD)
- | Seq
- | Tile => SIZE_EXPRESSION
- | Vector [=> integer_EXPRESSION]
- | Worker [=> integer_EXPRESSION]
-
- GANG_ARG ::=
- integer_EXPRESSION
- | Static => SIZE_EXPRESSION
-
- SIZE_EXPRESSION ::=
- *
- | integer_EXPRESSION
-
-Requires the :switch:`-fopenacc` flag.
-
-Equivalent to the ``loop`` directive of the OpenAcc standard. This pragma
-should be placed in for loops after the "Acc_Parallel" pragma. It tells the
-compiler how to parallelize the loop.
-
-For more information about the effect of the clauses, see the OpenAcc
-specification.
-
-Pragma Acc_Kernels
-==================
-Syntax:
-
-.. code-block:: ada
-
- pragma Acc_Kernels [( ACC_KERNELS_CLAUSE [, ACC_KERNELS_CLAUSE...])];
-
- ACC_KERNELS_CLAUSE ::=
- Acc_If => boolean_EXPRESSION
- | Async => integer_EXPRESSION
- | Copy => IDENTIFIERS
- | Copy_In => IDENTIFIERS
- | Copy_Out => IDENTIFIERS
- | Create => IDENTIFIERS
- | Default => None
- | Device_Ptr => IDENTIFIERS
- | Num_Gangs => integer_EXPRESSION
- | Num_Workers => integer_EXPRESSION
- | Present => IDENTIFIERS
- | Vector_Length => integer_EXPRESSION
- | Wait => INTEGERS
-
- IDENTIFIERS ::=
- | IDENTIFIER
- | (IDENTIFIER, IDENTIFIERS)
-
- INTEGERS ::=
- | integer_EXPRESSION
- | (integer_EXPRESSION, INTEGERS)
-
-Requires the :switch:`-fopenacc` flag.
-
-Equivalent to the kernels directive of the OpenAcc standard. This pragma should
-be placed in loops.
-
-For more information about the effect of the clauses, see the OpenAcc
-specification.
-
-Pragma Acc_Data
-===============
-Syntax:
-
-.. code-block:: ada
-
- pragma Acc_Data ([ ACC_DATA_CLAUSE [, ACC_DATA_CLAUSE...]]);
-
- ACC_DATA_CLAUSE ::=
- Copy => IDENTIFIERS
- | Copy_In => IDENTIFIERS
- | Copy_Out => IDENTIFIERS
- | Create => IDENTIFIERS
- | Device_Ptr => IDENTIFIERS
- | Present => IDENTIFIERS
-
-Requires the :switch:`-fopenacc` flag.
-
-Equivalent to the ``data`` directive of the OpenAcc standard. This pragma
-should be placed in loops.
-
-For more information about the effect of the clauses, see the OpenAcc
-specification.
-
-
Pragma Ada_83
=============
@@ -1078,6 +926,8 @@ support is available, then the code generator will issue a message
indicating that the necessary attribute for implementation of this
pragma is not available.
+.. _Compile_Time_Error:
+
Pragma Compile_Time_Error
=========================
@@ -1094,14 +944,14 @@ This pragma can be used to generate additional compile time
error messages. It
is particularly useful in generics, where errors can be issued for
specific problematic instantiations. The first parameter is a boolean
-expression. The pragma is effective only if the value of this expression
-is known at compile time, and has the value True. The set of expressions
+expression. The pragma ensures that the value of an expression
+is known at compile time, and has the value False. The set of expressions
whose values are known at compile time includes all static boolean
expressions, and also other values which the compiler can determine
at compile time (e.g., the size of a record type set by an explicit
size representation clause, or the value of a variable which was
initialized to a constant and is known not to have been modified).
-If these conditions are met, an error message is generated using
+If these conditions are not met, an error message is generated using
the value given as the second argument. This string value may contain
embedded ASCII.LF characters to break the message into multiple lines.
@@ -1118,7 +968,10 @@ Syntax:
Same as pragma Compile_Time_Error, except a warning is issued instead
-of an error message. Note that if this pragma is used in a package that
+of an error message. If switch *-gnatw_C* is used, a warning is only issued
+if the value of the expression is known to be True at compile time, not when
+the value of the expression is not known at compile time.
+Note that if this pragma is used in a package that
is with'ed by a client, the client will get the warning even though it
is issued by a with'ed package (normally warnings in with'ed units are
suppressed, but this is a special exception to that rule).
@@ -1128,6 +981,11 @@ of formal parameters are tested, and warnings given appropriately. Another use
with a first parameter of True is to warn a client about use of a package,
for example that it is not fully implemented.
+In previous versions of the compiler, combining *-gnatwe* with
+Compile_Time_Warning resulted in a fatal error. Now the compiler always emits
+a warning. You can use :ref:`Compile_Time_Error` to force the generation of
+an error.
+
Pragma Compiler_Unit
====================
@@ -2335,16 +2193,32 @@ extension mode (the use of Off as a parameter cancels the effect
of the *-gnatX* command switch).
In extension mode, the latest version of the Ada language is
-implemented (currently Ada 2012), and in addition a small number
+implemented (currently Ada 202x), and in addition a small number
of GNAT specific extensions are recognized as follows:
+* Constrained attribute for generic objects
-
-*Constrained attribute for generic objects*
The ``Constrained`` attribute is permitted for objects of
generic types. The result indicates if the corresponding actual
is constrained.
+* ``Static`` aspect on intrinsic functions
+
+ The Ada 202x ``Static`` aspect can be specified on Intrinsic imported
+ functions and the compiler will evaluate some of these intrinsic statically,
+ in particular the ``Shift_Left`` and ``Shift_Right`` intrinsics.
+
+* ``'Reduce`` attribute
+
+ This attribute part of the Ada 202x language definition is provided for
+ now under -gnatX to confirm and potentially refine its usage and syntax.
+
+* ``[]`` aggregates
+
+ This new aggregate syntax for arrays and containers is provided under -gnatX
+ to experiment and confirm this new language syntax.
+
+
.. _Pragma-Extensions_Visible:
Pragma Extensions_Visible
@@ -7570,7 +7444,7 @@ Syntax:
DETAILS ::= static_string_EXPRESSION
DETAILS ::= On | Off, static_string_EXPRESSION
- TOOL_NAME ::= GNAT | GNATProve
+ TOOL_NAME ::= GNAT | GNATprove
REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
diff --git a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst
index efcdc80..7bae014 100644
--- a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst
@@ -582,7 +582,7 @@ that in each case the base is ``Short_Short_Integer`` with a size of 8):
Note: the entries marked '*' are not actually specified by the Ada
Reference Manual, which has nothing to say about size in the dynamic
-case. What GNAT does is to allocate sufficient bits to accomodate any
+case. What GNAT does is to allocate sufficient bits to accommodate any
possible dynamic values for the bounds at run-time.
So far, so good, but GNAT has to obey the RM rules, so the question is
diff --git a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst
index 56dd6a7..b0f59cf 100644
--- a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst
+++ b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst
@@ -1000,8 +1000,7 @@ SPARK_05
--------
.. index:: SPARK_05
-[GNAT] This restriction checks at compile time that some constructs forbidden
-in SPARK 2005 are not present. Note that SPARK 2005 has been superseded by
+[GNAT] This restriction no longer has any effect and is superseded by
SPARK 2014, whose restrictions are checked by the tool GNATprove. To check that
a codebase respects SPARK 2014 restrictions, mark the code with pragma or
aspect ``SPARK_Mode``, and run the tool GNATprove at Stone assurance level, as
@@ -1013,145 +1012,3 @@ or equivalently::
gnatprove -P project.gpr --mode=check_all
-With restriction ``SPARK_05``, error messages related to SPARK 2005 restriction
-have the form:
-
-::
-
- violation of restriction "SPARK_05" at <source-location>
- <error message>
-
-.. index:: SPARK
-
-The restriction ``SPARK`` is recognized as a synonym for ``SPARK_05``. This is
-retained for historical compatibility purposes (and an unconditional warning
-will be generated for its use, advising replacement by ``SPARK_05``).
-
-This is not a replacement for the semantic checks performed by the
-SPARK Examiner tool, as the compiler currently only deals with code,
-not SPARK 2005 annotations, and does not guarantee catching all
-cases of constructs forbidden by SPARK 2005.
-
-Thus it may well be the case that code which passes the compiler with
-the SPARK 2005 restriction is rejected by the SPARK Examiner, e.g. due to
-the different visibility rules of the Examiner based on SPARK 2005
-``inherit`` annotations.
-
-This restriction can be useful in providing an initial filter for code
-developed using SPARK 2005, or in examining legacy code to see how far
-it is from meeting SPARK 2005 restrictions.
-
-The list below summarizes the checks that are performed when this
-restriction is in force:
-
-* No block statements
-* No case statements with only an others clause
-* Exit statements in loops must respect the SPARK 2005 language restrictions
-* No goto statements
-* Return can only appear as last statement in function
-* Function must have return statement
-* Loop parameter specification must include subtype mark
-* Prefix of expanded name cannot be a loop statement
-* Abstract subprogram not allowed
-* User-defined operators not allowed
-* Access type parameters not allowed
-* Default expressions for parameters not allowed
-* Default expressions for record fields not allowed
-* No tasking constructs allowed
-* Label needed at end of subprograms and packages
-* No mixing of positional and named parameter association
-* No access types as result type
-* No unconstrained arrays as result types
-* No null procedures
-* Initial and later declarations must be in correct order (declaration can't come after body)
-* No attributes on private types if full declaration not visible
-* No package declaration within package specification
-* No controlled types
-* No discriminant types
-* No overloading
-* Selector name cannot be operator symbol (i.e. operator symbol cannot be prefixed)
-* Access attribute not allowed
-* Allocator not allowed
-* Result of catenation must be String
-* Operands of catenation must be string literal, static char or another catenation
-* No conditional expressions
-* No explicit dereference
-* Quantified expression not allowed
-* Slicing not allowed
-* No exception renaming
-* No generic renaming
-* No object renaming
-* No use clause
-* Aggregates must be qualified
-* Nonstatic choice in array aggregates not allowed
-* The only view conversions which are allowed as in-out parameters are conversions of a tagged type to an ancestor type
-* No mixing of positional and named association in aggregate, no multi choice
-* AND, OR and XOR for arrays only allowed when operands have same static bounds
-* Fixed point operands to * or / must be qualified or converted
-* Comparison operators not allowed for Booleans or arrays (except strings)
-* Equality not allowed for arrays with non-matching static bounds (except strings)
-* Conversion / qualification not allowed for arrays with non-matching static bounds
-* Subprogram declaration only allowed in package spec (unless followed by import)
-* Access types not allowed
-* Incomplete type declaration not allowed
-* Object and subtype declarations must respect SPARK 2005 restrictions
-* Digits or delta constraint not allowed
-* Decimal fixed point type not allowed
-* Aliasing of objects not allowed
-* Modular type modulus must be power of 2
-* Base not allowed on subtype mark
-* Unary operators not allowed on modular types (except not)
-* Untagged record cannot be null
-* No class-wide operations
-* Initialization expressions must respect SPARK 2005 restrictions
-* Nonstatic ranges not allowed except in iteration schemes
-* String subtypes must have lower bound of 1
-* Subtype of Boolean cannot have constraint
-* At most one tagged type or extension per package
-* Interface is not allowed
-* Character literal cannot be prefixed (selector name cannot be character literal)
-* Record aggregate cannot contain 'others'
-* Component association in record aggregate must contain a single choice
-* Ancestor part cannot be a type mark
-* Attributes 'Image, 'Width and 'Value not allowed
-* Functions may not update globals
-* Subprograms may not contain direct calls to themselves (prevents recursion within unit)
-* Call to subprogram not allowed in same unit before body has been seen (prevents recursion within unit)
-
-The following restrictions are enforced, but note that they are actually more
-strict that the latest SPARK 2005 language definition:
-
-* No derived types other than tagged type extensions
-* Subtype of unconstrained array must have constraint
-
-This list summarises the main SPARK 2005 language rules that are not
-currently checked by the SPARK_05 restriction:
-
-* SPARK 2005 annotations are treated as comments so are not checked at all
-* Based real literals not allowed
-* Objects cannot be initialized at declaration by calls to user-defined functions
-* Objects cannot be initialized at declaration by assignments from variables
-* Objects cannot be initialized at declaration by assignments from indexed/selected components
-* Ranges shall not be null
-* A fixed point delta expression must be a simple expression
-* Restrictions on where renaming declarations may be placed
-* Externals of mode 'out' cannot be referenced
-* Externals of mode 'in' cannot be updated
-* Loop with no iteration scheme or exits only allowed as last statement in main program or task
-* Subprogram cannot have parent unit name
-* SPARK 2005 inherited subprogram must be prefixed with overriding
-* External variables (or functions that reference them) may not be passed as actual parameters
-* Globals must be explicitly mentioned in contract
-* Deferred constants cannot be completed by pragma Import
-* Package initialization cannot read/write variables from other packages
-* Prefix not allowed for entities that are directly visible
-* Identifier declaration can't override inherited package name
-* Cannot use Standard or other predefined packages as identifiers
-* After renaming, cannot use the original name
-* Subprograms can only be renamed to remove package prefix
-* Pragma import must be immediately after entity it names
-* No mutual recursion between multiple units (this can be checked with gnatcheck)
-
-Note that if a unit is compiled in Ada 95 mode with the SPARK 2005 restriction,
-violations will be reported for constructs forbidden in SPARK 95,
-instead of SPARK 2005.
diff --git a/gcc/ada/doc/gnat_ugn/about_this_guide.rst b/gcc/ada/doc/gnat_ugn/about_this_guide.rst
index 1ab2f4c..3347626 100644
--- a/gcc/ada/doc/gnat_ugn/about_this_guide.rst
+++ b/gcc/ada/doc/gnat_ugn/about_this_guide.rst
@@ -14,13 +14,13 @@ toolset for the full Ada programming language.
It documents the features of the compiler and tools, and explains
how to use them to build Ada applications.
-GNAT implements Ada 95, Ada 2005 and Ada 2012, and it may also be
+GNAT implements Ada 95, Ada 2005, Ada 2012, and Ada 202x, and it may also be
invoked in Ada 83 compatibility mode.
By default, GNAT assumes Ada 2012, but you can override with a
compiler switch (:ref:`Compiling_Different_Versions_of_Ada`)
to explicitly specify the language version.
Throughout this manual, references to 'Ada' without a year suffix
-apply to all Ada 95/2005/2012 versions of the language.
+apply to all Ada versions of the language, starting with Ada 95.
What This Guide Contains
========================
@@ -71,8 +71,6 @@ What You Should Know before Reading This Guide
This guide assumes a basic familiarity with the Ada 95 language, as
described in the International Standard ANSI/ISO/IEC-8652:1995, January
1995.
-It does not require knowledge of the features introduced by Ada 2005
-or Ada 2012.
Reference manuals for Ada 95, Ada 2005, and Ada 2012 are included in
the GNAT documentation package.
@@ -104,81 +102,6 @@ following documents:
environment Emacs.
-A Note to Readers of Previous Versions of the Manual
-====================================================
-
-In early 2015 the GNAT manuals were transitioned to the
-reStructuredText (rst) / Sphinx documentation generator technology.
-During that process the :title:`GNAT User's Guide` was reorganized
-so that related topics would be described together in the same chapter
-or appendix. Here's a summary of the major changes realized in
-the new document structure.
-
-* :ref:`The_GNAT_Compilation_Model` has been extended so that it now covers
- the following material:
-
- - The ``gnatname``, ``gnatkr``, and ``gnatchop`` tools
- - :ref:`Configuration_Pragmas`
- - :ref:`GNAT_and_Libraries`
- - :ref:`Conditional_Compilation` including :ref:`Preprocessing_with_gnatprep`
- and :ref:`Integrated_Preprocessing`
- - :ref:`Generating_Ada_Bindings_for_C_and_C++_headers`
- - :ref:`Using_GNAT_Files_with_External_Tools`
-
-* :ref:`Building_Executable_Programs_With_GNAT` is a new chapter consolidating
- the following content:
-
- - :ref:`The_GNAT_Make_Program_gnatmake`
- - :ref:`Compiling_with_GCC`
- - :ref:`Binding_with_gnatbind`
- - :ref:`Linking_with_gnatlink`
- - :ref:`Using_the_GNU_make_Utility`
-
-* :ref:`GNAT_Utility_Programs` is a new chapter consolidating the information about several
- GNAT tools:
-
- .. only:: PRO or GPL
-
- - :ref:`The_File_Cleanup_Utility_gnatclean`
- - :ref:`The_GNAT_Library_Browser_gnatls`
- - :ref:`The_Cross-Referencing_Tools_gnatxref_and_gnatfind`
- - :ref:`The_Ada_to_HTML_Converter_gnathtml`
- - :ref:`The_Ada-to-XML_Converter_gnat2xml`
- - :ref:`The_Coding_Standard_Verifier_gnatcheck`
- - :ref:`The_GNAT_Metrics_Tool_gnatmetric`
- - :ref:`The_GNAT_Pretty_Printer_gnatpp`
- - :ref:`The_Body_Stub_Generator_gnatstub`
- - :ref:`The_Unit_Test_Generator_gnattest`
-
- .. only:: FSF
-
- - :ref:`The_File_Cleanup_Utility_gnatclean`
- - :ref:`The_GNAT_Library_Browser_gnatls`
- - :ref:`The_Cross-Referencing_Tools_gnatxref_and_gnatfind`
- - :ref:`The_Ada_to_HTML_Converter_gnathtml`
-
-* :ref:`GNAT_and_Program_Execution` is a new chapter consolidating the following:
-
- - :ref:`Running_and_Debugging_Ada_Programs`
- - :ref:`Profiling`
- - :ref:`Improving_Performance`
- - :ref:`Overflow Check Handling in GNAT <Overflow_Check_Handling_in_GNAT>`
- - :ref:`Performing Dimensionality Analysis in GNAT <Performing_Dimensionality_Analysis_in_GNAT>`
- - :ref:`Stack_Related_Facilities`
- - :ref:`Memory_Management_Issues`
-
-* :ref:`Platform_Specific_Information` is a new appendix consolidating the following:
-
- - :ref:`Run_Time_Libraries`
- - :ref:`Microsoft_Windows_Topics`
- - :ref:`Mac_OS_Topics`
-
-* The *Compatibility and Porting Guide* appendix has been moved to the
- :title:`GNAT Reference Manual`. It now includes a section
- *Writing Portable Fixed-Point Declarations* which was previously
- a separate chapter in the :title:`GNAT User's Guide`.
-
-
Conventions
===========
.. index:: Conventions, typographical
diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
index 7f5dabe..1d44d70 100644
--- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
+++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
@@ -1910,10 +1910,6 @@ Alphabetical List of All Switches
Note that this option should be used only for compiling -- the
code is likely to malfunction at run time.
- Note that when :switch:`-gnatct` is used to generate trees for input
- into ASIS tools, these representation clauses are removed
- from the tree and ignored. This means that the tool will not see them.
-
.. index:: -gnatjnn (gcc)
@@ -2112,12 +2108,6 @@ Alphabetical List of All Switches
Print package Standard.
-.. index:: -gnatt (gcc)
-
-:switch:`-gnatt`
- Generate tree output file.
-
-
.. index:: -gnatT (gcc)
:switch:`-gnatT{nnn}`
@@ -2600,14 +2590,6 @@ format:
implies :switch:`-gnatq`, since the semantic phase must be run to get a
meaningful ALI file.
- In addition, if :switch:`-gnatt` is also specified, then the tree file is
- generated even if there are illegalities. It may be useful in this case
- to also specify :switch:`-gnatq` to ensure that full semantic processing
- occurs. The resulting tree file can be processed by ASIS, for the purpose
- of providing partial information about illegal units, but if the error
- causes the tree to be badly malformed, then ASIS may crash during the
- analysis.
-
When :switch:`-gnatQ` is used and the generated :file:`ALI` file is marked as
being in error, ``gnatmake`` will attempt to recompile the source when it
finds such an :file:`ALI` file, including with switch :switch:`-gnatc`.
@@ -4421,7 +4403,7 @@ to the default checks required by Ada as described above.
All validity checks are turned on.
That is, :switch:`-gnatVa` is
- equivalent to ``gnatVcdfimorst``.
+ equivalent to ``gnatVcdfimoprst``.
.. index:: -gnatVc (gcc)
@@ -5695,21 +5677,6 @@ Subprogram Inlining Control
Auxiliary Output Control
------------------------
-.. index:: -gnatt (gcc)
-.. index:: Writing internal trees
-.. index:: Internal trees, writing to file
-
-:switch:`-gnatt`
- Causes GNAT to write the internal tree for a unit to a file (with the
- extension :file:`.adt`.
- This not normally required, but is used by separate analysis tools.
- Typically
- these tools do the necessary compilations automatically, so you should
- not have to specify this switch in normal operation.
- Note that the combination of switches :switch:`-gnatct`
- generates a tree in the form required by ASIS applications.
-
-
.. index:: -gnatu (gcc)
:switch:`-gnatu`
@@ -6744,6 +6711,14 @@ be presented in subsequent sections.
Exclude source files (check object consistency only).
+ .. index:: -xdr (gnatbind)
+
+:switch:`-xdr`
+ Use the target-independent XDR protocol for stream oriented attributes
+ instead of the default implementation which is based on direct binary
+ representations and is therefore target-and endianness-dependent.
+
+
.. index:: -Xnnn (gnatbind)
:switch:`-X{nnn}`
diff --git a/gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst b/gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst
index 34dc355..9814cb6 100644
--- a/gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst
+++ b/gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst
@@ -9,14 +9,43 @@ Getting Started with GNAT
This chapter describes how to use GNAT's command line interface to build
executable Ada programs.
On most platforms a visually oriented Integrated Development Environment
-is also available, the GNAT Programming Studio (GNAT Studio).
+is also available: GNAT Studio.
GNAT Studio offers a graphical "look and feel", support for development in
other programming languages, comprehensive browsing features, and
many other capabilities.
-For information on GNAT Studio please refer to
-:title:`Using the GNAT Programming Studio`.
+For information on GNAT Studio please refer to the
+:title:`GNAT Studio documentation`.
+.. _System_Requirements:
+
+System Requirements
+===================
+
+Even though any machine can run the GNAT toolset and GNAT Studio IDE, in order
+to get the best experience, we recommend using a machine with as many cores
+as possible since all individual compilations can run in parallel.
+A comfortable setup for a compiler server is a machine with 24 physical cores
+or more, with at least 48 GB of memory (2 GB per core).
+
+For a desktop machine, a minimum of 4 cores is recommended (8 preferred),
+with at least 2GB per core (so 8 to 16GB).
+
+In addition, for running and navigating sources in GNAT Studio smoothly, we
+recommend at least 1.5 GB plus 3 GB of RAM per 1 million source line of code.
+In other words, we recommend at least 3 GB for for 500K lines of code and
+7.5 GB for 2 million lines of code.
+
+Note that using local and fast drives will also make a difference in terms of
+build and link time. Network drives such as NFS, SMB, or worse, configuration
+management filesystems (such as ClearCase dynamic views) should be avoided as
+much as possible and will produce very degraded performance (typically 2 to 3
+times slower than on local fast drives). If such slow drives cannot be avoided
+for accessing the source code, then you should at least configure your project
+file so that the result of the compilation is stored on a drive local to the
+machine performing the run. This can be achieved by setting the ``Object_Dir``
+project file attribute.
+
.. _Running_GNAT:
Running GNAT
@@ -96,24 +125,12 @@ file corresponding to your Ada program. It also generates
an 'Ada Library Information' file :file:`hello.ali`,
which contains additional information used to check
that an Ada program is consistent.
-To build an executable file,
-use ``gnatbind`` to bind the program
-and ``gnatlink`` to link it. The
-argument to both ``gnatbind`` and ``gnatlink`` is the name of the
-:file:`ALI` file, but the default extension of :file:`.ali` can
-be omitted. This means that in the most common case, the argument
-is simply the name of the main program:
-
-.. code-block:: sh
-
- $ gnatbind hello
- $ gnatlink hello
-A simpler method of carrying out these steps is to use ``gnatmake``,
-a master program that invokes all the required
-compilation, binding and linking tools in the correct order. In particular,
-``gnatmake`` automatically recompiles any sources that have been
-modified since they were last compiled, or sources that depend
+To build an executable file, use either ``gnatmake`` or gprbuild with
+the name of the main file: these tools are builders that will take care of
+all the necessary build steps in the correct order.
+In particular, these builders automatically recompile any sources that have
+been modified since they were last compiled, or sources that depend
on such modified sources, so that 'version skew' is avoided.
.. index:: Version skew (avoided by ``gnatmake``)
@@ -190,17 +207,6 @@ following three separate files:
*gmain.adb*
body of main program
-To build an executable version of
-this program, we could use four separate steps to compile, bind, and link
-the program, as follows:
-
-.. code-block:: sh
-
- $ gcc -c gmain.adb
- $ gcc -c greetings.adb
- $ gnatbind gmain
- $ gnatlink gmain
-
Note that there is no required order of compilation when using GNAT.
In particular it is perfectly fine to compile the main program first.
Also, it is not necessary to compile package specs in the case where
@@ -212,66 +218,10 @@ generation, then use the :switch:`-gnatc` switch:
$ gcc -c greetings.ads -gnatc
-Although the compilation can be done in separate steps as in the
-above example, in practice it is almost always more convenient
-to use the ``gnatmake`` tool. All you need to know in this case
-is the name of the main program's source file. The effect of the above four
-commands can be achieved with a single one:
+Although the compilation can be done in separate steps, in practice it is
+almost always more convenient to use the ``gnatmake`` or ``gprbuild`` tools:
.. code-block:: sh
$ gnatmake gmain.adb
-In the next section we discuss the advantages of using ``gnatmake`` in
-more detail.
-
-.. _Using_the_gnatmake_Utility:
-
-Using the ``gnatmake`` Utility
-==============================
-
-If you work on a program by compiling single components at a time using
-``gcc``, you typically keep track of the units you modify. In order to
-build a consistent system, you compile not only these units, but also any
-units that depend on the units you have modified.
-For example, in the preceding case,
-if you edit :file:`gmain.adb`, you only need to recompile that file. But if
-you edit :file:`greetings.ads`, you must recompile both
-:file:`greetings.adb` and :file:`gmain.adb`, because both files contain
-units that depend on :file:`greetings.ads`.
-
-``gnatbind`` will warn you if you forget one of these compilation
-steps, so that it is impossible to generate an inconsistent program as a
-result of forgetting to do a compilation. Nevertheless it is tedious and
-error-prone to keep track of dependencies among units.
-One approach to handle the dependency-bookkeeping is to use a
-makefile. However, makefiles present maintenance problems of their own:
-if the dependencies change as you change the program, you must make
-sure that the makefile is kept up-to-date manually, which is also an
-error-prone process.
-
-The ``gnatmake`` utility takes care of these details automatically.
-Invoke it using either one of the following forms:
-
-.. code-block:: sh
-
- $ gnatmake gmain.adb
- $ gnatmake gmain
-
-The argument is the name of the file containing the main program;
-you may omit the extension. ``gnatmake``
-examines the environment, automatically recompiles any files that need
-recompiling, and binds and links the resulting set of object files,
-generating the executable file, :file:`gmain`.
-In a large program, it
-can be extremely helpful to use ``gnatmake``, because working out by hand
-what needs to be recompiled can be difficult.
-
-Note that ``gnatmake`` takes into account all the Ada rules that
-establish dependencies among units. These include dependencies that result
-from inlining subprogram bodies, and from
-generic instantiation. Unlike some other
-Ada make tools, ``gnatmake`` does not rely on the dependencies that were
-found by the compiler on a previous compilation, which may possibly
-be wrong when sources change. ``gnatmake`` determines the exact set of
-dependencies from scratch each time it is run.
diff --git a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst
index 6e836a7..883f012 100644
--- a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst
+++ b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst
@@ -14,9 +14,6 @@ This chapter describes a number of utility programs:
* :ref:`The_File_Cleanup_Utility_gnatclean`
* :ref:`The_GNAT_Library_Browser_gnatls`
- * :ref:`The_Cross-Referencing_Tools_gnatxref_and_gnatfind`
- * :ref:`The_Ada_to_HTML_Converter_gnathtml`
- * :ref:`The_Ada-to-XML_Converter_gnat2xml`
* :ref:`The_Coding_Standard_Verifier_gnatcheck`
* :ref:`The_GNAT_Metrics_Tool_gnatmetric`
* :ref:`The_GNAT_Pretty_Printer_gnatpp`
@@ -31,8 +28,6 @@ This chapter describes a number of utility programs:
* :ref:`The_File_Cleanup_Utility_gnatclean`
* :ref:`The_GNAT_Library_Browser_gnatls`
- * :ref:`The_Cross-Referencing_Tools_gnatxref_and_gnatfind`
- * :ref:`The_Ada_to_HTML_Converter_gnathtml`
Other GNAT utilities are described elsewhere in this manual:
@@ -472,1299 +467,6 @@ building specialized scripts.
/home/comar/local/adainclude/unchconv.ads
-.. _The_Cross-Referencing_Tools_gnatxref_and_gnatfind:
-
-The Cross-Referencing Tools ``gnatxref`` and ``gnatfind``
-=========================================================
-
-.. index:: ! gnatxref
-.. index:: ! gnatfind
-
-The compiler generates cross-referencing information (unless
-you set the :switch:`-gnatx` switch), which are saved in the :file:`.ali` files.
-This information indicates where in the source each entity is declared and
-referenced. Note that entities in package Standard are not included, but
-entities in all other predefined units are included in the output.
-
-Before using any of these two tools, you need to compile successfully your
-application, so that GNAT gets a chance to generate the cross-referencing
-information.
-
-The two tools ``gnatxref`` and ``gnatfind`` take advantage of this
-information to provide the user with the capability to easily locate the
-declaration and references to an entity. These tools are quite similar,
-the difference being that ``gnatfind`` is intended for locating
-definitions and/or references to a specified entity or entities, whereas
-``gnatxref`` is oriented to generating a full report of all
-cross-references.
-
-To use these tools, you must not compile your application using the
-:switch:`-gnatx` switch on the ``gnatmake`` command line
-(see :ref:`The_GNAT_Make_Program_gnatmake`). Otherwise, cross-referencing
-information will not be generated.
-
-.. _gnatxref_Switches:
-
-``gnatxref`` Switches
----------------------
-
-The command invocation for ``gnatxref`` is:
-
- ::
-
- $ gnatxref [ switches ] sourcefile1 [ sourcefile2 ... ]
-
-where
-
-``sourcefile1`` [, ``sourcefile2`` ...]
- identify the source files for which a report is to be generated. The
- ``with``\ ed units will be processed too. You must provide at least one file.
-
- These file names are considered to be regular expressions, so for instance
- specifying :file:`source\*.adb` is the same as giving every file in the current
- directory whose name starts with :file:`source` and whose extension is
- :file:`adb`.
-
- You shouldn't specify any directory name, just base names. ``gnatxref``
- and ``gnatfind`` will be able to locate these files by themselves using
- the source path. If you specify directories, no result is produced.
-
-The following switches are available for ``gnatxref``:
-
-
-.. index:: --version (gnatxref)
-
-:switch:`--version`
- Display copyright and version, then exit disregarding all other options.
-
-
-.. index:: --help (gnatxref)
-
-:switch:`--help`
- If :switch:`--version` was not used, display usage, then exit disregarding
- all other options.
-
-
-.. index:: -a (gnatxref)
-
-:switch:`-a`
- If this switch is present, ``gnatfind`` and ``gnatxref`` will parse
- the read-only files found in the library search path. Otherwise, these files
- will be ignored. This option can be used to protect Gnat sources or your own
- libraries from being parsed, thus making ``gnatfind`` and ``gnatxref``
- much faster, and their output much smaller. Read-only here refers to access
- or permissions status in the file system for the current user.
-
-
-.. index:: -aIDIR (gnatxref)
-
-:switch:`-aI{DIR}`
- When looking for source files also look in directory DIR. The order in which
- source file search is undertaken is the same as for ``gnatmake``.
-
-
-.. index:: -aODIR (gnatxref)
-
-:switch:`aO{DIR}`
- When -searching for library and object files, look in directory
- DIR. The order in which library files are searched is the same as for
- ``gnatmake``.
-
-
-.. index:: -nostdinc (gnatxref)
-
-:switch:`-nostdinc`
- Do not look for sources in the system default directory.
-
-
-.. index:: -nostdlib (gnatxref)
-
-:switch:`-nostdlib`
- Do not look for library files in the system default directory.
-
-
-.. index:: --ext (gnatxref)
-
-:switch:`--ext={extension}`
- Specify an alternate ali file extension. The default is ``ali`` and other
- extensions (e.g. ``gli`` for C/C++ sources) may be specified via this switch.
- Note that if this switch overrides the default, only the new extension will
- be considered.
-
-
-.. index:: --RTS (gnatxref)
-
-:switch:`--RTS={rts-path}`
- Specifies the default location of the runtime library. Same meaning as the
- equivalent ``gnatmake`` flag (:ref:`Switches_for_gnatmake`).
-
-
-.. index:: -d (gnatxref)
-
-:switch:`-d`
- If this switch is set ``gnatxref`` will output the parent type
- reference for each matching derived types.
-
-
-.. index:: -f (gnatxref)
-
-:switch:`-f`
- If this switch is set, the output file names will be preceded by their
- directory (if the file was found in the search path). If this switch is
- not set, the directory will not be printed.
-
-
-.. index:: -g (gnatxref)
-
-:switch:`-g`
- If this switch is set, information is output only for library-level
- entities, ignoring local entities. The use of this switch may accelerate
- ``gnatfind`` and ``gnatxref``.
-
-
-.. index:: -IDIR (gnatxref)
-
-:switch:`-I{DIR}`
- Equivalent to :switch:`-aODIR -aIDIR`.
-
-
-.. index:: -pFILE (gnatxref)
-
-:switch:`-p{FILE}`
- Specify a configuration file to use to list the source and object directories.
-
- If a file is specified, then the content of the source directory and object
- directory lines are added as if they had been specified respectively
- by :switch:`-aI` and :switch:`-aO`.
-
- See :ref:`Configuration_Files_for_gnatxref_and_gnatfind` for the syntax
- of this configuration file.
-
-:switch:`-u`
- Output only unused symbols. This may be really useful if you give your
- main compilation unit on the command line, as ``gnatxref`` will then
- display every unused entity and 'with'ed package.
-
-:switch:`-v`
- Instead of producing the default output, ``gnatxref`` will generate a
- :file:`tags` file that can be used by vi. For examples how to use this
- feature, see :ref:`Examples_of_gnatxref_Usage`. The tags file is output
- to the standard output, thus you will have to redirect it to a file.
-
-All these switches may be in any order on the command line, and may even
-appear after the file names. They need not be separated by spaces, thus
-you can say ``gnatxref -ag`` instead of ``gnatxref -a -g``.
-
-.. _gnatfind_Switches:
-
-``gnatfind`` Switches
----------------------
-
-The command invocation for ``gnatfind`` is:
-
- ::
-
- $ gnatfind [ switches ] pattern[:sourcefile[:line[:column]]]
- [file1 file2 ...]
-
-with the following iterpretation of the command arguments:
-
-*pattern*
- An entity will be output only if it matches the regular expression found
- in *pattern*, see :ref:`Regular_Expressions_in_gnatfind_and_gnatxref`.
-
- Omitting the pattern is equivalent to specifying ``*``, which
- will match any entity. Note that if you do not provide a pattern, you
- have to provide both a sourcefile and a line.
-
- Entity names are given in Latin-1, with uppercase/lowercase equivalence
- for matching purposes. At the current time there is no support for
- 8-bit codes other than Latin-1, or for wide characters in identifiers.
-
-*sourcefile*
- ``gnatfind`` will look for references, bodies or declarations
- of symbols referenced in :file:`sourcefile`, at line ``line``
- and column ``column``. See :ref:`Examples_of_gnatfind_Usage`
- for syntax examples.
-
-*line*
- A decimal integer identifying the line number containing
- the reference to the entity (or entities) to be located.
-
-
-*column*
- A decimal integer identifying the exact location on the
- line of the first character of the identifier for the
- entity reference. Columns are numbered from 1.
-
-
-*file1 file2 ...*
- The search will be restricted to these source files. If none are given, then
- the search will be conducted for every library file in the search path.
- These files must appear only after the pattern or sourcefile.
-
- These file names are considered to be regular expressions, so for instance
- specifying :file:`source\*.adb` is the same as giving every file in the current
- directory whose name starts with :file:`source` and whose extension is
- :file:`adb`.
-
- The location of the spec of the entity will always be displayed, even if it
- isn't in one of :file:`file1`, :file:`file2`, ... The
- occurrences of the entity in the separate units of the ones given on the
- command line will also be displayed.
-
- Note that if you specify at least one file in this part, ``gnatfind`` may
- sometimes not be able to find the body of the subprograms.
-
-At least one of 'sourcefile' or 'pattern' has to be present on
-the command line.
-
-The following switches are available:
-
-.. index:: --version (gnatfind)
-
-:switch:`--version`
- Display copyright and version, then exit disregarding all other options.
-
-
-.. index:: --help (gnatfind)
-
-:switch:`--help`
- If :switch:`--version` was not used, display usage, then exit disregarding
- all other options.
-
-
-.. index:: -a (gnatfind)
-
-:switch:`-a`
- If this switch is present, ``gnatfind`` and ``gnatxref`` will parse
- the read-only files found in the library search path. Otherwise, these files
- will be ignored. This option can be used to protect Gnat sources or your own
- libraries from being parsed, thus making ``gnatfind`` and ``gnatxref``
- much faster, and their output much smaller. Read-only here refers to access
- or permission status in the file system for the current user.
-
-
-.. index:: -aIDIR (gnatfind)
-
-:switch:`-aI{DIR}`
- When looking for source files also look in directory DIR. The order in which
- source file search is undertaken is the same as for ``gnatmake``.
-
-
-.. index:: -aODIR (gnatfind)
-
-:switch:`-aO{DIR}`
- When searching for library and object files, look in directory
- DIR. The order in which library files are searched is the same as for
- ``gnatmake``.
-
-
-.. index:: -nostdinc (gnatfind)
-
-:switch:`-nostdinc`
- Do not look for sources in the system default directory.
-
-
-.. index:: -nostdlib (gnatfind)
-
-:switch:`-nostdlib`
- Do not look for library files in the system default directory.
-
-
-.. index:: --ext (gnatfind)
-
-:switch:`--ext={extension}`
- Specify an alternate ali file extension. The default is ``ali`` and other
- extensions may be specified via this switch. Note that if this switch
- overrides the default, only the new extension will be considered.
-
-
-.. index:: --RTS (gnatfind)
-
-:switch:`--RTS={rts-path}`
- Specifies the default location of the runtime library. Same meaning as the
- equivalent ``gnatmake`` flag (:ref:`Switches_for_gnatmake`).
-
-
-.. index:: -d (gnatfind)
-
-:switch:`-d`
- If this switch is set, then ``gnatfind`` will output the parent type
- reference for each matching derived types.
-
-
-.. index:: -e (gnatfind)
-
-:switch:`-e`
- By default, ``gnatfind`` accept the simple regular expression set for
- ``pattern``. If this switch is set, then the pattern will be
- considered as full Unix-style regular expression.
-
-
-.. index:: -f (gnatfind)
-
-:switch:`-f`
- If this switch is set, the output file names will be preceded by their
- directory (if the file was found in the search path). If this switch is
- not set, the directory will not be printed.
-
-
-.. index:: -g (gnatfind)
-
-:switch:`-g`
- If this switch is set, information is output only for library-level
- entities, ignoring local entities. The use of this switch may accelerate
- ``gnatfind`` and ``gnatxref``.
-
-
-.. index:: -IDIR (gnatfind)
-
-:switch:`-I{DIR}`
- Equivalent to :switch:`-aODIR -aIDIR`.
-
-
-.. index:: -pFILE (gnatfind)
-
-:switch:`-p{FILE}`
- Specify a configuration file to use to list the source and object directories.
-
- If a file is specified, then the content of the source directory and object
- directory lines are added as if they had been specified respectively
- by :switch:`-aI` and :switch:`-aO`.
-
- See :ref:`Configuration_Files_for_gnatxref_and_gnatfind` for the syntax
- of this configuration file.
-
-.. index:: -r (gnatfind)
-
-:switch:`-r`
- By default, ``gnatfind`` will output only the information about the
- declaration, body or type completion of the entities. If this switch is
- set, the ``gnatfind`` will locate every reference to the entities in
- the files specified on the command line (or in every file in the search
- path if no file is given on the command line).
-
-
-.. index:: -s (gnatfind)
-
-:switch:`-s`
- If this switch is set, then ``gnatfind`` will output the content
- of the Ada source file lines were the entity was found.
-
-
-.. index:: -t (gnatfind)
-
-:switch:`-t`
- If this switch is set, then ``gnatfind`` will output the type hierarchy for
- the specified type. It act like -d option but recursively from parent
- type to parent type. When this switch is set it is not possible to
- specify more than one file.
-
-
-All these switches may be in any order on the command line, and may even
-appear after the file names. They need not be separated by spaces, thus
-you can say ``gnatxref -ag`` instead of
-``gnatxref -a -g``.
-
-As stated previously, ``gnatfind`` will search in every directory in the
-search path. You can force it to look only in the current directory if
-you specify ``*`` at the end of the command line.
-
-.. _Configuration_Files_for_gnatxref_and_gnatfind:
-
-Configuration Files for ``gnatxref`` and ``gnatfind``
------------------------------------------------------
-
-Configuration files are used by ``gnatxref`` and ``gnatfind`` to specify
-the list of source and object directories to consider. They can be
-specified via the :switch:`-p` switch.
-
-The following lines can be included, in any order in the file:
-
-* *src_dir=DIR*
- [default: ``"./"``].
- Specifies a directory where to look for source files. Multiple ``src_dir``
- lines can be specified and they will be searched in the order they
- are specified.
-
-* *obj_dir=DIR*
- [default: ``"./"``].
- Specifies a directory where to look for object and library files. Multiple
- ``obj_dir`` lines can be specified, and they will be searched in the order
- they are specified
-
-Any other line will be silently ignored.
-
-.. _Regular_Expressions_in_gnatfind_and_gnatxref:
-
-Regular Expressions in ``gnatfind`` and ``gnatxref``
-----------------------------------------------------
-
-As specified in the section about ``gnatfind``, the pattern can be a
-regular expression. Two kinds of regular expressions
-are recognized:
-
-* *Globbing pattern*
- These are the most common regular expression. They are the same as are
- generally used in a Unix shell command line, or in a DOS session.
-
- Here is a more formal grammar:
-
- ::
-
- regexp ::= term
- term ::= elmt -- matches elmt
- term ::= elmt elmt -- concatenation (elmt then elmt)
- term ::= * -- any string of 0 or more characters
- term ::= ? -- matches any character
- term ::= [char {char}] -- matches any character listed
- term ::= [char - char] -- matches any character in range
-
-* *Full regular expression*
- The second set of regular expressions is much more powerful. This is the
- type of regular expressions recognized by utilities such as ``grep``.
-
- The following is the form of a regular expression, expressed in same BNF
- style as is found in the Ada Reference Manual:
-
- ::
-
- regexp ::= term {| term} -- alternation (term or term ...)
-
- term ::= item {item} -- concatenation (item then item)
-
- item ::= elmt -- match elmt
- item ::= elmt * -- zero or more elmt's
- item ::= elmt + -- one or more elmt's
- item ::= elmt ? -- matches elmt or nothing
-
- elmt ::= nschar -- matches given character
- elmt ::= [nschar {nschar}] -- matches any character listed
- elmt ::= [^ nschar {nschar}] -- matches any character not listed
- elmt ::= [char - char] -- matches chars in given range
- elmt ::= \\ char -- matches given character
- elmt ::= . -- matches any single character
- elmt ::= ( regexp ) -- parens used for grouping
-
- char ::= any character, including special characters
- nschar ::= any character except ()[].*+?^
-
- Here are a few examples:
-
- ``abcde|fghi``
- will match any of the two strings ``abcde`` and ``fghi``,
-
- ``abc*d``
- will match any string like ``abd``, ``abcd``, ``abccd``,
- ``abcccd``, and so on,
-
- ``[a-z]+``
- will match any string which has only lowercase characters in it (and at
- least one character.
-
-
-.. _Examples_of_gnatxref_Usage:
-
-Examples of ``gnatxref`` Usage
-------------------------------
-
-General Usage
-^^^^^^^^^^^^^
-
-For the following examples, we will consider the following units:
-
- .. code-block:: ada
-
- main.ads:
- 1: with Bar;
- 2: package Main is
- 3: procedure Foo (B : in Integer);
- 4: C : Integer;
- 5: private
- 6: D : Integer;
- 7: end Main;
-
- main.adb:
- 1: package body Main is
- 2: procedure Foo (B : in Integer) is
- 3: begin
- 4: C := B;
- 5: D := B;
- 6: Bar.Print (B);
- 7: Bar.Print (C);
- 8: end Foo;
- 9: end Main;
-
- bar.ads:
- 1: package Bar is
- 2: procedure Print (B : Integer);
- 3: end bar;
-
-The first thing to do is to recompile your application (for instance, in
-that case just by doing a ``gnatmake main``, so that GNAT generates
-the cross-referencing information.
-You can then issue any of the following commands:
-
- * ``gnatxref main.adb``
- ``gnatxref`` generates cross-reference information for main.adb
- and every unit 'with'ed by main.adb.
-
- The output would be:
-
- ::
-
- B Type: Integer
- Decl: bar.ads 2:22
- B Type: Integer
- Decl: main.ads 3:20
- Body: main.adb 2:20
- Ref: main.adb 4:13 5:13 6:19
- Bar Type: Unit
- Decl: bar.ads 1:9
- Ref: main.adb 6:8 7:8
- main.ads 1:6
- C Type: Integer
- Decl: main.ads 4:5
- Modi: main.adb 4:8
- Ref: main.adb 7:19
- D Type: Integer
- Decl: main.ads 6:5
- Modi: main.adb 5:8
- Foo Type: Unit
- Decl: main.ads 3:15
- Body: main.adb 2:15
- Main Type: Unit
- Decl: main.ads 2:9
- Body: main.adb 1:14
- Print Type: Unit
- Decl: bar.ads 2:15
- Ref: main.adb 6:12 7:12
-
-
- This shows that the entity ``Main`` is declared in main.ads, line 2, column 9,
- its body is in main.adb, line 1, column 14 and is not referenced any where.
-
- The entity ``Print`` is declared in :file:`bar.ads`, line 2, column 15 and it
- is referenced in :file:`main.adb`, line 6 column 12 and line 7 column 12.
-
-
- * ``gnatxref package1.adb package2.ads``
- ``gnatxref`` will generates cross-reference information for
- :file:`package1.adb`, :file:`package2.ads` and any other package ``with``\ ed by any
- of these.
-
-
-Using ``gnatxref`` with ``vi``
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-``gnatxref`` can generate a tags file output, which can be used
-directly from ``vi``. Note that the standard version of ``vi``
-will not work properly with overloaded symbols. Consider using another
-free implementation of ``vi``, such as ``vim``.
-
- ::
-
- $ gnatxref -v gnatfind.adb > tags
-
-
-The following command will generate the tags file for ``gnatfind`` itself
-(if the sources are in the search path!):
-
- ::
-
- $ gnatxref -v gnatfind.adb > tags
-
-From ``vi``, you can then use the command :samp:`:tag {entity}`
-(replacing ``entity`` by whatever you are looking for), and vi will
-display a new file with the corresponding declaration of entity.
-
-
-.. _Examples_of_gnatfind_Usage:
-
-Examples of ``gnatfind`` Usage
-------------------------------
-
-* ``gnatfind -f xyz:main.adb``
- Find declarations for all entities xyz referenced at least once in
- main.adb. The references are search in every library file in the search
- path.
-
- The directories will be printed as well (as the ``-f``
- switch is set)
-
- The output will look like:
-
- ::
-
- directory/main.ads:106:14: xyz <= declaration
- directory/main.adb:24:10: xyz <= body
- directory/foo.ads:45:23: xyz <= declaration
-
- I.e., one of the entities xyz found in main.adb is declared at
- line 12 of main.ads (and its body is in main.adb), and another one is
- declared at line 45 of foo.ads
-
-* ``gnatfind -fs xyz:main.adb``
- This is the same command as the previous one, but ``gnatfind`` will
- display the content of the Ada source file lines.
-
- The output will look like:
-
- ::
-
- directory/main.ads:106:14: xyz <= declaration
- procedure xyz;
- directory/main.adb:24:10: xyz <= body
- procedure xyz is
- directory/foo.ads:45:23: xyz <= declaration
- xyz : Integer;
-
- This can make it easier to find exactly the location your are looking
- for.
-
-
-* ``gnatfind -r "*x*":main.ads:123 foo.adb``
- Find references to all entities containing an x that are
- referenced on line 123 of main.ads.
- The references will be searched only in main.ads and foo.adb.
-
-
-* ``gnatfind main.ads:123``
- Find declarations and bodies for all entities that are referenced on
- line 123 of main.ads.
-
- This is the same as ``gnatfind "*":main.adb:123```
-
-* ``gnatfind mydir/main.adb:123:45``
- Find the declaration for the entity referenced at column 45 in
- line 123 of file main.adb in directory mydir. Note that it
- is usual to omit the identifier name when the column is given,
- since the column position identifies a unique reference.
-
- The column has to be the beginning of the identifier, and should not
- point to any character in the middle of the identifier.
-
-
-.. _The_Ada_to_HTML_Converter_gnathtml:
-
-The Ada to HTML Converter ``gnathtml``
-======================================
-
-.. index:: ! gnathtml
-
-``gnathtml`` is a Perl script that allows Ada source files to be browsed using
-standard Web browsers. For installation information, see :ref:`Installing_gnathtml`.
-
-Ada reserved keywords are highlighted in a bold font and Ada comments in
-a blue font. Unless your program was compiled with the gcc :switch:`-gnatx`
-switch to suppress the generation of cross-referencing information, user
-defined variables and types will appear in a different color; you will
-be able to click on any identifier and go to its declaration.
-
-.. _Invoking_gnathtml:
-
-Invoking ``gnathtml``
----------------------
-
-The command line is as follows:
-
- ::
-
- $ perl gnathtml.pl [ switches ] ada-files
-
-You can specify as many Ada files as you want. ``gnathtml`` will generate
-an html file for every ada file, and a global file called :file:`index.htm`.
-This file is an index of every identifier defined in the files.
-
-The following switches are available:
-
-.. index:: -83 (gnathtml)
-
-:samp:`83`
- Only the Ada 83 subset of keywords will be highlighted.
-
-.. index:: -cc (gnathtml)
-
-:samp:`cc {color}`
- This option allows you to change the color used for comments. The default
- value is green. The color argument can be any name accepted by html.
-
-.. index:: -d (gnathtml)
-
-:samp:`d`
- If the Ada files depend on some other files (for instance through
- ``with`` clauses, the latter files will also be converted to html.
- Only the files in the user project will be converted to html, not the files
- in the run-time library itself.
-
-.. index:: -D (gnathtml)
-
-:samp:`D`
- This command is the same as :switch:`-d` above, but ``gnathtml`` will
- also look for files in the run-time library, and generate html files for them.
-
-.. index:: -ext (gnathtml)
-
-:samp:`ext {extension}`
- This option allows you to change the extension of the generated HTML files.
- If you do not specify an extension, it will default to :file:`htm`.
-
-.. index:: -f (gnathtml)
-
-:samp:`f`
- By default, gnathtml will generate html links only for global entities
- ('with'ed units, global variables and types,...). If you specify
- :switch:`-f` on the command line, then links will be generated for local
- entities too.
-
-.. index:: -l (gnathtml)
-
-:samp:`l {number}`
- If this switch is provided and ``number`` is not 0, then
- ``gnathtml`` will number the html files every ``number`` line.
-
-.. index:: -I (gnathtml)
-
-:samp:`I {dir}`
- Specify a directory to search for library files (:file:`.ALI` files) and
- source files. You can provide several -I switches on the command line,
- and the directories will be parsed in the order of the command line.
-
-.. index:: -o (gnathtml)
-
-:samp:`o {dir}`
- Specify the output directory for html files. By default, gnathtml will
- saved the generated html files in a subdirectory named :file:`html/`.
-
-.. index:: -p (gnathtml)
-
-:samp:`p {file}`
- If you are using Emacs and the most recent Emacs Ada mode, which provides
- a full Integrated Development Environment for compiling, checking,
- running and debugging applications, you may use :file:`.gpr` files
- to give the directories where Emacs can find sources and object files.
-
- Using this switch, you can tell gnathtml to use these files.
- This allows you to get an html version of your application, even if it
- is spread over multiple directories.
-
-.. index:: -sc (gnathtml)
-
-:samp:`sc {color}`
- This switch allows you to change the color used for symbol
- definitions.
- The default value is red. The color argument can be any name accepted by html.
-
-.. index:: -t (gnathtml)
-
-:samp:`t {file}`
- This switch provides the name of a file. This file contains a list of
- file names to be converted, and the effect is exactly as though they had
- appeared explicitly on the command line. This
- is the recommended way to work around the command line length limit on some
- systems.
-
-.. _Installing_gnathtml:
-
-Installing ``gnathtml``
------------------------
-
-``Perl`` needs to be installed on your machine to run this script.
-``Perl`` is freely available for almost every architecture and
-operating system via the Internet.
-
-On Unix systems, you may want to modify the first line of the script
-``gnathtml``, to explicitly specify where Perl
-is located. The syntax of this line is:
-
- ::
-
- #!full_path_name_to_perl
-
-Alternatively, you may run the script using the following command line:
-
- ::
-
- $ perl gnathtml.pl [ switches ] files
-
-
-
-
-.. -- +---------------------------------------------------------------------+
-.. -- | The following sections are present only in the PRO and GPL editions |
-.. -- +---------------------------------------------------------------------+
-
-.. only:: PRO or GPL
-
- .. _The_Ada-to-XML_converter_gnat2xml:
-
- The Ada-to-XML converter ``gnat2xml``
- =====================================
-
- .. index:: ! gnat2xml
- .. index:: XML generation
-
- The ``gnat2xml`` tool is an ASIS-based utility that converts
- Ada source code into XML.
-
- ``gnat2xml`` is a project-aware tool
- (see :ref:`Using_Project_Files_with_GNAT_Tools` for a description of
- the project-related switches). The project file package that can specify
- ``gnat2xml`` switches is named ``gnat2xml``.
-
- .. _Switches_for_``gnat2xml``:
-
- Switches for ``gnat2xml``
- -------------------------
-
- ``gnat2xml`` takes Ada source code as input, and produces XML
- that conforms to the schema.
-
- Usage:
-
- ::
-
- $ gnat2xml [options] filenames [-files filename] [-cargs gcc_switches]
-
- Options:
-
- :switch:`--help`
- Generate usage information and quit, ignoring all other options
-
- :switch:`-h`
- Same as ``--help``
-
- :switch:`--version`
- Print version and quit, ignoring all other options
-
- :switch:`-P{file}`
- indicates the name of the project file that describes
- the set of sources to be processed. The exact set of argument
- sources depends on other options specified, see below.
-
- :switch:`-U`
- If a project file is specified and no argument source is explicitly
- specified, process all the units of the closure of the argument project.
- Otherwise this option has no effect.
-
- :switch:`-U {main_unit}`
- If a project file is specified and no argument source
- is explicitly specified (either directly or by means of :switch:`-files`
- option), process the closure of units rooted at ``main_unit``.
- Otherwise this option has no effect.
-
- :switch:`-X{name}={value}`
- Indicates that external variable ``name`` in
- the argument project has the value ``value``. Has no effect if no
- project is specified.
-
- :switch:`--RTS={rts-path}`
- Specifies the default location of the runtime
- library. Same meaning as the equivalent ``gnatmake`` flag
- (:ref:`Switches_for_gnatmake`).
-
- :switch:`--incremental`
- Incremental processing on a per-file basis. Source files are
- only processed if they have been modified, or if files they depend
- on have been modified. This is similar to the way gnatmake/gprbuild
- only compiles files that need to be recompiled. A project file
- is required in this mode.
-
- :switch:`-j{n}`
- In :switch:`--incremental` mode, use ``n`` ``gnat2xml``
- processes to perform XML generation in parallel. If ``n`` is 0, then
- the maximum number of parallel tree creations is the number of core
- processors on the platform.
-
- :switch:`--output-dir={dir}`
- Generate one .xml file for each Ada source file, in
- directory :file:`dir`. (Default is to generate the XML to standard
- output.)
-
- :switch:`-I{include-dir}`
- Directories to search for dependencies.
- You can also set the ADA_INCLUDE_PATH environment variable for this.
-
- :switch:`--compact`
- Debugging version, with interspersed source, and a more
- compact representation of "sloc". This version does not conform
- to any schema.
-
- :switch:`--rep-clauses`
- generate representation clauses (see :ref:`Generating_Representation_Clauses`).
-
- :switch:`-files={filename}`
- Take as arguments the files listed in text file ``file``.
- Text file ``file`` may contain empty lines that are ignored.
- Each nonempty line should contain the name of an existing file.
- Several such switches may be specified simultaneously.
-
- :switch:`--ignore={filename}`
- Do not process the sources listed in a specified file. This option cannot
- be used in incremental mode.
-
- :switch:`-q`
- Quiet
-
- :switch:`-v`
- Verbose
-
- :switch:`-cargs` ...
- Options to pass to gcc
-
- If a project file is specified and no argument source is explicitly
- specified, and no :switch:`-U` is specified, then the set of processed
- sources is all the immediate units of the argument project.
-
- Example:
-
- ::
-
- $ gnat2xml -v -output-dir=xml-files *.ad[sb]
-
- The above will create \*.xml files in the :file:`xml-files` subdirectory.
- For example, if there is an Ada package Mumble.Dumble, whose spec and
- body source code lives in mumble-dumble.ads and mumble-dumble.adb,
- the above will produce xml-files/mumble-dumble.ads.xml and
- xml-files/mumble-dumble.adb.xml.
-
- .. _Other_Programs:
-
- Other Programs
- --------------
-
- The distribution includes two other programs that are related to
- ``gnat2xml``:
-
- ``gnat2xsd`` is the schema generator, which generates the schema
- to standard output, based on the structure of Ada as encoded by
- ASIS. You don't need to run ``gnat2xsd`` in order to use
- ``gnat2xml``. To generate the schema, type:
-
-
- ::
-
- $ gnat2xsd > ada-schema.xsd
-
-
- ``gnat2xml`` generates XML files that will validate against
- :file:`ada-schema.xsd`.
-
- ``xml2gnat`` is a back-translator that translates the XML back into
- Ada source code. This is primarily for the purpose of testing
- ``gnat2xml``, rather than for users. The Ada generated by ``xml2gnat``
- has identical semantics to the original Ada code passed to
- ``gnat2xml``. It is not textually identical, however --- for example,
- no attempt is made to preserve the original indentation.
-
- The ``xml2gnat`` command line contains a list of the same Ada files
- passed to gnat2xml (not the names of xml files). The xml files are
- assumed to be in an 'xml' subdirectory of the directory in which the
- Ada source files are. So for example, if the Ada source file is
- some/dir/mumble.adb, then the xml file is found in
- some/dir/xml/mumble.adb.xml. You should use the :switch:`--output-dir`
- switch of ``gnat2xml`` to tell it to generate the output in the xml
- subdirectory, so ``xml2gnat`` can find it.
-
- Output goes into subdirectories "generated_ada" and "self_rep" of the
- output directory, which is the current directory by default, but can
- be overridden with --output-dir=dir on the command line.
-
- .. _Structure_of_the_XML:
-
- Structure of the XML
- --------------------
-
- The primary documentation for the structure of the XML generated by
- ``gnat2xml`` is the schema (see ``gnat2xsd`` above). The
- following documentation gives additional details needed to understand
- the schema and therefore the XML.
-
- The elements listed under Defining Occurrences, Usage Occurrences, and
- Other Elements represent the syntactic structure of the Ada program.
- Element names are given in lower case, with the corresponding element
- type Capitalized_Like_This. The element and element type names are
- derived directly from the ASIS enumeration type Flat_Element_Kinds,
- declared in Asis.Extensions.Flat_Kinds, with the leading ``An_`` or ``A_``
- removed. For example, the ASIS enumeration literal
- An_Assignment_Statement corresponds to the XML element
- assignment_statement of XML type Assignment_Statement.
-
- To understand the details of the schema and the corresponding XML, it is
- necessary to understand the ASIS standard, as well as the GNAT-specific
- extension to ASIS.
-
- A defining occurrence is an identifier (or character literal or operator
- symbol) declared by a declaration. A usage occurrence is an identifier
- (or ...) that references such a declared entity. For example, in:
-
-
- .. code-block:: ada
-
- type T is range 1..10;
- X, Y : constant T := 1;
-
-
- The first 'T' is the defining occurrence of a type. The 'X' is the
- defining occurrence of a constant, as is the 'Y', and the second 'T' is
- a usage occurrence referring to the defining occurrence of T.
-
- Each element has a 'sloc' (source location), and subelements for each
- syntactic subtree, reflecting the Ada grammar as implemented by ASIS.
- The types of subelements are as defined in the ASIS standard. For
- example, for the right-hand side of an assignment_statement we have
- the following comment in asis-statements.ads:
-
- .. code-block:: ada
-
- ------------------------------------------------------------------------------
- -- 18.3 function Assignment_Expression
- ------------------------------------------------------------------------------
-
- function Assignment_Expression
- (Statement : Asis.Statement)
- return Asis.Expression;
-
- ------------------------------------------------------------------------------
- ...
- -- Returns the expression from the right hand side of the assignment.
- ...
- -- Returns Element_Kinds:
- -- An_Expression
-
-
- The corresponding sub-element of type Assignment_Statement is:
-
- ::
-
- <xsd:element name="assignment_expression_q" type="Expression_Class"/>
-
- where Expression_Class is defined by an xsd:choice of all the
- various kinds of expression.
-
- The 'sloc' of each element indicates the starting and ending line and
- column numbers. Column numbers are character counts; that is, a tab
- counts as 1, not as however many spaces it might expand to.
-
- Subelements of type Element have names ending in '_q' (for ASIS
- "Query"), and those of type Element_List end in '_ql'
- ("Query returning List").
-
- Some subelements are 'Boolean'. For example, Private_Type_Definition
- has has_abstract_q and has_limited_q, to indicate whether those
- keywords are present, as in ``type T is abstract limited private;``.
- False is represented by a Nil_Element. True is represented
- by an element type specific to that query (for example, Abstract and
- Limited).
-
- The root of the tree is a Compilation_Unit, with attributes:
-
- * unit_kind, unit_class, and unit_origin. These are strings that match the
- enumeration literals of types Unit_Kinds, Unit_Classes, and Unit_Origins
- in package Asis.
-
- * unit_full_name is the full expanded name of the unit, starting from a
- root library unit. So for ``package P.Q.R is ...``,
- ``unit_full_name="P.Q.R"``. Same for ``separate (P.Q) package R is ...``.
-
- * def_name is the same as unit_full_name for library units; for subunits,
- it is just the simple name.
-
- * source_file is the name of the Ada source file. For example, for
- the spec of ``P.Q.R``, ``source_file="p-q-r.ads"``. This allows one to
- interpret the source locations --- the 'sloc' of all elements
- within this Compilation_Unit refers to line and column numbers
- within the named file.
-
- Defining occurrences have these attributes:
-
- * def_name is the simple name of the declared entity, as written in the Ada
- source code.
-
- * def is a unique URI of the form:
-
- ::
-
- ada://kind/fully/qualified/name
-
- where:
-
- * kind indicates the kind of Ada entity being declared (see below), and
-
- * fully/qualified/name, is the fully qualified name of the Ada
- entity, with each of 'fully', 'qualified', and 'name' being
- mangled for uniqueness. We do not document the mangling
- algorithm, which is subject to change; we just guarantee that the
- names are unique in the face of overloading.
-
- * type is the type of the declared object, or ``null`` for
- declarations of things other than objects.
-
- Usage occurrences have these attributes:
-
- * ref_name is the same as the def_name of the corresponding defining
- occurrence. This attribute is not of much use, because of
- overloading; use ref for lookups, instead.
-
- * ref is the same as the def of the corresponding defining
- occurrence.
-
- In summary, ``def_name`` and ``ref_name`` are as in the source
- code of the declaration, possibly overloaded, whereas ``def`` and
- ``ref`` are unique-ified.
-
- Literal elements have this attribute:
-
- * lit_val is the value of the literal as written in the source text,
- appropriately escaped (e.g. ``"`` |rightarrow| ``&quot;``). This applies
- only to numeric and string literals. Enumeration literals in Ada are
- not really "literals" in the usual sense; they are usage occurrences,
- and have ref_name and ref as described above. Note also that string
- literals used as operator symbols are treated as defining or usage
- occurrences, not as literals.
-
- Elements that can syntactically represent names and expressions (which
- includes usage occurrences, plus function calls and so forth) have this
- attribute:
-
- * type. If the element represents an expression or the name of an object,
- 'type' is the 'def' for the defining occurrence of the type of that
- expression or name. Names of other kinds of entities, such as package
- names and type names, do not have a type in Ada; these have type="null"
- in the XML.
-
- Pragma elements have this attribute:
-
- * pragma_name is the name of the pragma. For language-defined pragmas, the
- pragma name is redundant with the element kind (for example, an
- assert_pragma element necessarily has pragma_name="Assert"). However, all
- implementation-defined pragmas are lumped together in ASIS as a single
- element kind (for example, the GNAT-specific pragma Unreferenced is
- represented by an implementation_defined_pragma element with
- pragma_name="Unreferenced").
-
- Defining occurrences of formal parameters and generic formal objects have this
- attribute:
-
- * mode indicates that the parameter is of mode 'in', 'in out', or 'out'.
-
- All elements other than Not_An_Element have this attribute:
-
- * checks is a comma-separated list of run-time checks that are needed
- for that element. The possible checks are: do_accessibility_check,
- do_discriminant_check,do_division_check,do_length_check,
- do_overflow_check,do_range_check,do_storage_check,do_tag_check.
-
- The "kind" part of the "def" and "ref" attributes is taken from the ASIS
- enumeration type Flat_Declaration_Kinds, declared in
- Asis.Extensions.Flat_Kinds, with the leading ``An_`` or ``A_`` removed, and
- any trailing ``_Declaration`` or ``_Specification`` removed. Thus, the
- possible kinds are as follows:
-
- ::
-
- ordinary_type
- task_type
- protected_type
- incomplete_type
- tagged_incomplete_type
- private_type
- private_extension
- subtype
- variable
- constant
- deferred_constant
- single_task
- single_protected
- integer_number
- real_number
- enumeration_literal
- discriminant
- component
- loop_parameter
- generalized_iterator
- element_iterator
- procedure
- function
- parameter
- procedure_body
- function_body
- return_variable
- return_constant
- null_procedure
- expression_function
- package
- package_body
- object_renaming
- exception_renaming
- package_renaming
- procedure_renaming
- function_renaming
- generic_package_renaming
- generic_procedure_renaming
- generic_function_renaming
- task_body
- protected_body
- entry
- entry_body
- entry_index
- procedure_body_stub
- function_body_stub
- package_body_stub
- task_body_stub
- protected_body_stub
- exception
- choice_parameter
- generic_procedure
- generic_function
- generic_package
- package_instantiation
- procedure_instantiation
- function_instantiation
- formal_object
- formal_type
- formal_incomplete_type
- formal_procedure
- formal_function
- formal_package
- formal_package_declaration_with_box
-
- .. _Generating_Representation_Clauses:
-
- Generating Representation Clauses
- ---------------------------------
-
- If the :switch:`--rep-clauses` switch is given, ``gnat2xml`` will
- generate representation clauses for certain types showing the
- representation chosen by the compiler. The information is produced by
- the ASIS 'Data Decomposition' facility --- see the
- ``Asis.Data_Decomposition`` package for details.
-
- Not all types are supported. For example, ``Type_Model_Kind`` must
- be ``A_Simple_Static_Model``. Types declared within generic units
- have no representation. The clauses that are generated include
- ``attribute_definition_clauses`` for ``Size`` and
- ``Component_Size``, as well as
- ``record_representation_clauses``.
-
- There is no guarantee that the generated representation clauses could
- have actually come from legal Ada code; Ada has some restrictions that
- are not necessarily obeyed by the generated clauses.
-
- The representation clauses are surrounded by comment elements to
- indicate that they are automatically generated, something like this:
-
- ::
-
- <comment text="--gen+">
- ...
- <attribute_definition_clause>
- ...
- <comment text="--gen-">
- ...
-
-
.. only:: PRO or GPL
.. _The_Coding_Standard_Verifier_gnatcheck:
@@ -2338,11 +1040,11 @@ Alternatively, you may run the script using the following command line:
Do not report the number of public subprograms with complete contracts
- :switch:`--contract-all`
+ :switch:`--contract-cyclomatic`
Report the McCabe complexity of public subprograms
- :switch:`--no-contract-all`
+ :switch:`--no-contract-cyclomatic`
Do not report the McCabe complexity of public subprograms
@@ -2790,7 +1492,7 @@ Alternatively, you may run the script using the following command line:
Use the specified subdirectory of the project objects file (or of the
project file directory if the project does not specify an object directory)
for tool output files. Has no effect if no project is specified as
- tool argument r if :switch:`--no_objects_dir` is specified.
+ tool argument r if :switch:`--no-objects-dir` is specified.
.. index:: --files (gnatmetric)
@@ -3245,6 +1947,14 @@ Alternatively, you may run the script using the following command line:
Do not place the keyword ``is`` on a separate line in a subprogram body in
case if the spec occupies more than one line.
+ .. index:: --no-separate-return (gnatpp)
+
+
+ :switch:`--no-separate-return`
+ In :switch:`--no-compact` mode, if a subprogram spec does not fit on
+ one line, try to place the ``return`` on the same line as the last
+ formal parameter.
+
.. index:: --separate-loop (gnatpp)
@@ -3412,7 +2122,35 @@ Alternatively, you may run the script using the following command line:
:switch:`--RM-style-spacing`
Do not insert an extra blank before various occurrences of
- '(' and ':'. This also turns off alignment.
+ '(' and ':'. Alignment is off by default in this mode;
+ use :switch:`--alignment` to turn it on.
+
+
+ .. index:: --compact (gnatpp)
+ .. index:: --no-compact (gnatpp)
+
+ :switch:`--compact`
+ This is the default. In calls and similar, this packs as many
+ subexpressions on the same line as possible. Example:
+
+ .. code-block:: ada
+
+ Some_Procedure
+ (Short_One, Another_Short_One,
+ A_Very_Very_Very_Very_Very_Very_Very_Very_Long_One);
+
+ :switch:`--no-compact`
+ Turns off --compact mode. In calls and similar, if it is necessary
+ to split a line between two subexpressions (because otherwise the
+ construct would exceed --max-line-length), then all such subexpressions
+ are placed on separate lines. Example:
+
+ .. code-block:: ada
+
+ Some_Procedure
+ (Short_One,
+ Another_Short_One,
+ A_Very_Very_Very_Very_Very_Very_Very_Very_Long_One);
.. index:: --call_threshold (gnatpp)
@@ -4246,7 +2984,7 @@ Alternatively, you may run the script using the following command line:
(See :ref:`Using_Project_Files_with_GNAT_Tools` for a description of
the project-related switches but note that ``gnatstub`` does not support
the :switch:`-U`, :switch:`-U {main_unit}`, :switch:`--subdirs={dir}`, or
- :switch:`--no_objects_dir` switches.)
+ :switch:`--no-objects-dir` switches.)
The project file package that can specify
``gnatstub`` switches is named ``gnatstub``.
@@ -4543,7 +3281,7 @@ Alternatively, you may run the script using the following command line:
(See :ref:`Using_Project_Files_with_GNAT_Tools` for a description of
the project-related switches but note that ``gnattest`` does not support
the :switch:`-U`, :switch:`-eL`, :switch:`--subdirs={dir}`, or
- :switch:`--no_objects_dir` switches.)
+ :switch:`--no-objects-dir` switches.)
The project file package that can specify
``gnattest`` switches is named ``gnattest``.
@@ -5634,9 +4372,9 @@ Alternatively, you may run the script using the following command line:
Use the ``dir`` subdirectory of the project's object directory (or the ``dir``
subdirectory of the project file directory if the project does not specify
an object directory) for tool output files. Has no effect if no project
- has been specified or if :switch:`--no_objects_dir` is specified.
+ has been specified or if :switch:`--no-objects-dir` is specified.
- :switch:`--no_objects_dir`
+ :switch:`--no-objects-dir`
Place all the result files into the current directory (i.e., the directory
from which the tool invocation command is issued) instead of the project's
object directory. Has no effect if no project has been specified.
diff --git a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst
index d7388bb..b8729d0 100644
--- a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst
+++ b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst
@@ -1067,23 +1067,18 @@ The basic compilation model of GNAT requires that a file submitted to the
compiler have only one unit and there be a strict correspondence
between the file name and the unit name.
-The ``gnatchop`` utility allows both of these rules to be relaxed,
-allowing GNAT to process files which contain multiple compilation units
-and files with arbitrary file names. ``gnatchop``
-reads the specified file and generates one or more output files,
-containing one unit per file. The unit and the file name correspond,
-as required by GNAT.
-
-If you want to permanently restructure a set of 'foreign' files so that
-they match the GNAT rules, and do the remaining development using the
-GNAT structure, you can simply use ``gnatchop`` once, generate the
-new set of files and work with them from that point on.
+If you want to keep your files with multiple units,
+perhaps to maintain compatibility with some other Ada compilation system,
+you can use ``gnatname`` to generate or update your project files.
+Generated or modified project files can be processed by GNAT.
+
+See :ref:`Handling_Arbitrary_File_Naming_Conventions_with_gnatname`
+for more details on how to use `gnatname`.
-Alternatively, if you want to keep your files in the 'foreign' format,
-perhaps to maintain compatibility with some other Ada compilation
-system, you can set up a procedure where you use ``gnatchop`` each
-time you compile, regarding the source files that it writes as temporary
-files that you throw away.
+Alternatively, if you want to permanently restructure a set of 'foreign'
+files so that they match the GNAT rules, and do the remaining development
+using the GNAT structure, you can simply use ``gnatchop`` once, generate the
+new set of files and work with them from that point on.
Note that if your file containing multiple units starts with a byte order
mark (BOM) specifying UTF-8 encoding, then the files generated by gnatchop
@@ -2393,10 +2388,9 @@ Rebuilding the GNAT Run-Time Library
.. index:: Rebuilding the GNAT Run-Time Library
.. index:: Run-Time Library, rebuilding
-It may be useful to recompile the GNAT library in various contexts, the
-most important one being the use of partition-wide configuration pragmas
-such as ``Normalize_Scalars``. A special Makefile called
-:file:`Makefile.adalib` is provided to that effect and can be found in
+It may be useful to recompile the GNAT library in various debugging or
+experimentation contexts. A project file called
+:file:`libada.gpr` is provided to that effect and can be found in
the directory containing the GNAT library. The location of this
directory depends on the way the GNAT environment has been installed and can
be determined by means of the command:
@@ -2405,10 +2399,13 @@ be determined by means of the command:
$ gnatls -v
-The last entry in the object search path usually contains the
-gnat library. This Makefile contains its own documentation and in
-particular the set of instructions needed to rebuild a new library and
-to use it.
+The last entry in the source search path usually contains the
+gnat library (the :file:`adainclude` directory). This project file contains its
+own documentation and in particular the set of instructions needed to rebuild a
+new library and to use it.
+
+Note that rebuilding the GNAT Run-Time is only recommended for temporary
+experiments or debugging, and is not supported.
.. index:: ! Conditional compilation
@@ -3953,7 +3950,7 @@ The following example, provided as part of the GNAT examples, shows how
to achieve procedural interfacing between Ada and C++ in both
directions. The C++ class A has two methods. The first method is exported
to Ada by the means of an extern C wrapper function. The second method
-calls an Ada subprogram. On the Ada side, The C++ calls are modelled by
+calls an Ada subprogram. On the Ada side, the C++ calls are modelled by
a limited record with a layout comparable to the C++ class. The Ada
subprogram, in turn, calls the C++ method. So, starting from the C++
main program, the process passes back and forth between the two
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 98b508f..bf839a5 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -282,6 +282,7 @@ package body Einfo is
-- SPARK_Pragma Node40
+ -- Access_Subprogram_Wrapper Node41
-- Original_Protected_Subprogram Node41
-- SPARK_Aux_Pragma Node41
@@ -422,6 +423,7 @@ package body Einfo is
-- Never_Set_In_Source Flag115
-- Is_Visible_Lib_Unit Flag116
-- Is_Unchecked_Union Flag117
+ -- Is_CUDA_Kernel Flag118
-- Has_Convention_Pragma Flag119
-- Has_Primitive_Operations Flag120
@@ -521,8 +523,8 @@ package body Einfo is
-- Known_To_Have_Preelab_Init Flag207
-- Must_Have_Preelab_Init Flag208
-- Is_Return_Object Flag209
- -- Elaborate_Body_Desirable Flag210
+ -- Elaborate_Body_Desirable Flag210
-- Has_Static_Discriminants Flag211
-- Has_Pragma_Unreferenced_Objects Flag212
-- Requires_Overriding Flag213
@@ -532,8 +534,8 @@ package body Einfo is
-- Suppress_Value_Tracking_On_Call Flag217
-- Is_Primitive Flag218
-- Has_Initial_Value Flag219
- -- Has_Dispatch_Table Flag220
+ -- Has_Dispatch_Table Flag220
-- Has_Pragma_Preelab_Init Flag221
-- Used_As_Generic_Actual Flag222
-- Is_Descendant_Of_Address Flag223
@@ -543,8 +545,8 @@ package body Einfo is
-- Referenced_As_Out_Parameter Flag227
-- Has_Thunks Flag228
-- Can_Use_Internal_Rep Flag229
- -- Has_Pragma_Inline_Always Flag230
+ -- Has_Pragma_Inline_Always Flag230
-- Renamed_In_Spec Flag231
-- Has_Own_Invariants Flag232
-- Has_Pragma_Unmodified Flag233
@@ -554,8 +556,8 @@ package body Einfo is
-- Warnings_Off_Used_Unmodified Flag237
-- Warnings_Off_Used_Unreferenced Flag238
-- No_Reordering Flag239
- -- Has_Expanded_Contract Flag240
+ -- Has_Expanded_Contract Flag240
-- Optimize_Alignment_Space Flag241
-- Optimize_Alignment_Time Flag242
-- Overlays_Constant Flag243
@@ -565,8 +567,8 @@ package body Einfo is
-- OK_To_Rename Flag247
-- Has_Inheritable_Invariants Flag248
-- Is_Safe_To_Reevaluate Flag249
- -- Has_Predicates Flag250
+ -- Has_Predicates Flag250
-- Has_Implicit_Dereference Flag251
-- Is_Finalized_Transient Flag252
-- Disable_Controlled Flag253
@@ -576,8 +578,8 @@ package body Einfo is
-- Is_Invariant_Procedure Flag257
-- Has_Dynamic_Predicate_Aspect Flag258
-- Has_Static_Predicate_Aspect Flag259
- -- Has_Loop_Entry_Attributes Flag260
+ -- Has_Loop_Entry_Attributes Flag260
-- Has_Delayed_Rep_Aspects Flag261
-- May_Inherit_Delayed_Rep_Aspects Flag262
-- Has_Visible_Refinement Flag263
@@ -587,8 +589,8 @@ package body Einfo is
-- Has_Shift_Operator Flag267
-- Is_Independent Flag268
-- Has_Static_Predicate Flag269
- -- Stores_Attribute_Old_Prefix Flag270
+ -- Stores_Attribute_Old_Prefix Flag270
-- Has_Protected Flag271
-- SSO_Set_Low_By_Default Flag272
-- SSO_Set_High_By_Default Flag273
@@ -598,8 +600,8 @@ package body Einfo is
-- Is_Checked_Ghost_Entity Flag277
-- Is_Ignored_Ghost_Entity Flag278
-- Contains_Ignored_Ghost_Code Flag279
- -- Partial_View_Has_Unknown_Discr Flag280
+ -- Partial_View_Has_Unknown_Discr Flag280
-- Is_Static_Type Flag281
-- Has_Nested_Subprogram Flag282
-- Is_Uplevel_Referenced_Entity Flag283
@@ -609,8 +611,8 @@ package body Einfo is
-- Rewritten_For_C Flag287
-- Predicates_Ignored Flag288
-- Has_Timing_Event Flag289
- -- Is_Class_Wide_Clone Flag290
+ -- Is_Class_Wide_Clone Flag290
-- Has_Inherited_Invariants Flag291
-- Is_Partial_Invariant_Procedure Flag292
-- Is_Actual_Subtype Flag293
@@ -620,8 +622,8 @@ package body Einfo is
-- Is_Entry_Wrapper Flag297
-- Is_Underlying_Full_View Flag298
-- Body_Needed_For_Inlining Flag299
- -- Has_Private_Extension Flag300
+ -- Has_Private_Extension Flag300
-- Ignore_SPARK_Mode_Pragmas Flag301
-- Is_Initial_Condition_Procedure Flag302
-- Suppress_Elaboration_Warnings Flag303
@@ -629,7 +631,7 @@ package body Einfo is
-- Is_Activation_Record Flag305
-- Needs_Activation_Record Flag306
-- Is_Loop_Parameter Flag307
- -- Invariants_Ignored Flag308
+ -- Has_Yield_Aspect Flag308
-- (unused) Flag309
@@ -713,7 +715,7 @@ package body Einfo is
function Abstract_States (Id : E) return L is
begin
- pragma Assert (Ekind_In (Id, E_Generic_Package, E_Package));
+ pragma Assert (Is_Package_Or_Generic_Package (Id));
return Elist25 (Id);
end Abstract_States;
@@ -724,35 +726,41 @@ package body Einfo is
function Access_Disp_Table (Id : E) return L is
begin
- pragma Assert (Ekind_In (Id, E_Record_Subtype,
- E_Record_Type,
- E_Record_Type_With_Private));
+ pragma Assert (Ekind (Id) in E_Record_Subtype
+ | E_Record_Type
+ | E_Record_Type_With_Private);
return Elist16 (Implementation_Base_Type (Id));
end Access_Disp_Table;
function Access_Disp_Table_Elab_Flag (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Record_Subtype,
- E_Record_Type,
- E_Record_Type_With_Private));
+ pragma Assert (Ekind (Id) in E_Record_Subtype
+ | E_Record_Type
+ | E_Record_Type_With_Private);
return Node30 (Implementation_Base_Type (Id));
end Access_Disp_Table_Elab_Flag;
+ function Access_Subprogram_Wrapper (Id : E) return E is
+ begin
+ pragma Assert (Ekind (Id) = E_Subprogram_Type);
+ return Node41 (Id);
+ end Access_Subprogram_Wrapper;
+
function Activation_Record_Component (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Constant,
- E_In_Parameter,
- E_In_Out_Parameter,
- E_Loop_Parameter,
- E_Out_Parameter,
- E_Variable));
+ pragma Assert (Ekind (Id) in E_Constant
+ | E_In_Parameter
+ | E_In_Out_Parameter
+ | E_Loop_Parameter
+ | E_Out_Parameter
+ | E_Variable);
return Node31 (Id);
end Activation_Record_Component;
function Actual_Subtype (Id : E) return E is
begin
pragma Assert
- (Ekind_In (Id, E_Constant, E_Variable, E_Generic_In_Out_Parameter)
+ (Ekind (Id) in E_Constant | E_Variable | E_Generic_In_Out_Parameter
or else Is_Formal (Id));
return Node17 (Id);
end Actual_Subtype;
@@ -773,10 +781,10 @@ package body Einfo is
begin
pragma Assert (Is_Type (Id)
or else Is_Formal (Id)
- or else Ekind_In (Id, E_Loop_Parameter,
- E_Constant,
- E_Exception,
- E_Variable));
+ or else Ekind (Id) in E_Loop_Parameter
+ | E_Constant
+ | E_Exception
+ | E_Variable);
return Uint14 (Id);
end Alignment;
@@ -788,16 +796,16 @@ package body Einfo is
function Anonymous_Masters (Id : E) return L is
begin
- pragma Assert (Ekind_In (Id, E_Function,
- E_Package,
- E_Procedure,
- E_Subprogram_Body));
+ pragma Assert (Ekind (Id) in E_Function
+ | E_Package
+ | E_Procedure
+ | E_Subprogram_Body);
return Elist29 (Id);
end Anonymous_Masters;
function Anonymous_Object (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Protected_Type, E_Task_Type));
+ pragma Assert (Ekind (Id) in E_Protected_Type | E_Task_Type);
return Node30 (Id);
end Anonymous_Object;
@@ -837,7 +845,7 @@ package body Einfo is
function Body_Entity (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package));
+ pragma Assert (Is_Package_Or_Generic_Package (Id));
return Node19 (Id);
end Body_Entity;
@@ -864,7 +872,7 @@ package body Einfo is
function BIP_Initialization_Call (Id : E) return N is
begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
+ pragma Assert (Ekind (Id) in E_Constant | E_Variable);
return Node29 (Id);
end BIP_Initialization_Call;
@@ -898,19 +906,19 @@ package body Einfo is
function Cloned_Subtype (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Class_Wide_Subtype));
+ pragma Assert (Ekind (Id) in E_Record_Subtype | E_Class_Wide_Subtype);
return Node16 (Id);
end Cloned_Subtype;
function Component_Bit_Offset (Id : E) return U is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
+ pragma Assert (Ekind (Id) in E_Component | E_Discriminant);
return Uint11 (Id);
end Component_Bit_Offset;
function Component_Clause (Id : E) return N is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
+ pragma Assert (Ekind (Id) in E_Component | E_Discriminant);
return Node13 (Id);
end Component_Clause;
@@ -967,7 +975,7 @@ package body Einfo is
function Corresponding_Record_Component (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
+ pragma Assert (Ekind (Id) in E_Component | E_Discriminant);
return Node21 (Id);
end Corresponding_Record_Component;
@@ -990,7 +998,7 @@ package body Einfo is
function Current_Value (Id : E) return N is
begin
- pragma Assert (Ekind (Id) in Object_Kind);
+ pragma Assert (Is_Object (Id));
return Node9 (Id);
end Current_Value;
@@ -1139,8 +1147,7 @@ package body Einfo is
function Dispatch_Table_Wrappers (Id : E) return L is
begin
- pragma Assert (Ekind_In (Id, E_Record_Type,
- E_Record_Subtype));
+ pragma Assert (Ekind (Id) in E_Record_Type | E_Record_Subtype);
return Elist26 (Implementation_Base_Type (Id));
end Dispatch_Table_Wrappers;
@@ -1158,14 +1165,14 @@ package body Einfo is
function DT_Position (Id : E) return U is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure)
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure
and then Present (DTC_Entity (Id)));
return Uint15 (Id);
end DT_Position;
function DTC_Entity (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
return Node16 (Id);
end DTC_Entity;
@@ -1180,7 +1187,7 @@ package body Einfo is
pragma Assert
(Is_Subprogram (Id)
or else
- Ekind_In (Id, E_Entry, E_Entry_Family, E_Package)
+ Ekind (Id) in E_Entry | E_Entry_Family | E_Package
or else
Is_Generic_Unit (Id));
return Node13 (Id);
@@ -1191,7 +1198,7 @@ package body Einfo is
pragma Assert
(Is_Subprogram (Id)
or else
- Ekind_In (Id, E_Entry, E_Entry_Family, E_Package)
+ Ekind (Id) in E_Entry | E_Entry_Family | E_Package
or else
Is_Generic_Unit (Id));
return Flag174 (Id);
@@ -1199,7 +1206,7 @@ package body Einfo is
function Encapsulating_State (Id : E) return N is
begin
- pragma Assert (Ekind_In (Id, E_Abstract_State, E_Constant, E_Variable));
+ pragma Assert (Ekind (Id) in E_Abstract_State | E_Constant | E_Variable);
return Node32 (Id);
end Encapsulating_State;
@@ -1249,40 +1256,42 @@ package body Einfo is
function Contains_Ignored_Ghost_Code (Id : E) return B is
begin
pragma Assert
- (Ekind_In (Id, E_Block,
- E_Function,
- E_Generic_Function,
- E_Generic_Package,
- E_Generic_Procedure,
- E_Package,
- E_Package_Body,
- E_Procedure,
- E_Subprogram_Body));
+ (Ekind (Id) in E_Block
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Package
+ | E_Generic_Procedure
+ | E_Package
+ | E_Package_Body
+ | E_Procedure
+ | E_Subprogram_Body);
return Flag279 (Id);
end Contains_Ignored_Ghost_Code;
function Contract (Id : E) return N is
begin
pragma Assert
- (Ekind_In (Id, E_Protected_Type, -- concurrent types
- E_Task_Body,
- E_Task_Type)
+ (Ekind (Id) in E_Protected_Type -- concurrent types
+ | E_Task_Body
+ | E_Task_Type
+ or else
+ Ekind (Id) in E_Constant -- objects
+ | E_Variable
or else
- Ekind_In (Id, E_Constant, -- objects
- E_Variable)
+ Ekind (Id) in E_Entry -- overloadable
+ | E_Entry_Family
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Procedure
+ | E_Operator
+ | E_Procedure
+ | E_Subprogram_Body
or else
- Ekind_In (Id, E_Entry, -- overloadable
- E_Entry_Family,
- E_Function,
- E_Generic_Function,
- E_Generic_Procedure,
- E_Operator,
- E_Procedure,
- E_Subprogram_Body)
+ Ekind (Id) in E_Generic_Package -- packages
+ | E_Package
+ | E_Package_Body
or else
- Ekind_In (Id, E_Generic_Package, -- packages
- E_Package,
- E_Package_Body)
+ Is_Type (Id) -- types
or else
Ekind (Id) = E_Void); -- special purpose
return Node34 (Id);
@@ -1290,7 +1299,7 @@ package body Einfo is
function Contract_Wrapper (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Entry, E_Entry_Family));
+ pragma Assert (Is_Entry (Id));
return Node25 (Id);
end Contract_Wrapper;
@@ -1326,13 +1335,12 @@ package body Einfo is
function Equivalent_Type (Id : E) return E is
begin
pragma Assert
- (Ekind_In (Id, E_Class_Wide_Type,
- E_Class_Wide_Subtype,
- E_Access_Subprogram_Type,
- E_Access_Protected_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type,
- E_Access_Subprogram_Type,
- E_Exception_Type));
+ (Ekind (Id) in E_Class_Wide_Type
+ | E_Class_Wide_Subtype
+ | E_Access_Subprogram_Type
+ | E_Access_Protected_Subprogram_Type
+ | E_Anonymous_Access_Protected_Subprogram_Type
+ | E_Exception_Type);
return Node18 (Id);
end Equivalent_Type;
@@ -1344,13 +1352,14 @@ package body Einfo is
function Extra_Accessibility (Id : E) return E is
begin
pragma Assert
- (Is_Formal (Id) or else Ekind_In (Id, E_Variable, E_Constant));
+ (Is_Formal (Id) or else Ekind (Id) in E_Variable | E_Constant);
return Node13 (Id);
end Extra_Accessibility;
function Extra_Accessibility_Of_Result (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Operator, E_Subprogram_Type));
+ pragma Assert
+ (Ekind (Id) in E_Function | E_Operator | E_Subprogram_Type);
return Node19 (Id);
end Extra_Accessibility_Of_Result;
@@ -1369,9 +1378,9 @@ package body Einfo is
begin
pragma Assert
(Is_Overloadable (Id)
- or else Ekind_In (Id, E_Entry_Family,
- E_Subprogram_Body,
- E_Subprogram_Type));
+ or else Ekind (Id) in E_Entry_Family
+ | E_Subprogram_Body
+ | E_Subprogram_Type);
return Node28 (Id);
end Extra_Formals;
@@ -1395,7 +1404,7 @@ package body Einfo is
function Finalizer (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Package, E_Package_Body));
+ pragma Assert (Ekind (Id) in E_Package | E_Package_Body);
return Node28 (Id);
end Finalizer;
@@ -1424,8 +1433,8 @@ package body Einfo is
function First_Private_Entity (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)
- or else Ekind (Id) in Concurrent_Kind);
+ pragma Assert (Is_Package_Or_Generic_Package (Id)
+ or else Is_Concurrent_Type (Id));
return Node16 (Id);
end First_Private_Entity;
@@ -1671,7 +1680,7 @@ package body Einfo is
function Has_Missing_Return (Id : E) return B is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function));
+ pragma Assert (Ekind (Id) in E_Function | E_Generic_Function);
return Flag142 (Id);
end Has_Missing_Return;
@@ -1700,8 +1709,7 @@ package body Einfo is
function Has_Out_Or_In_Out_Parameter (Id : E) return B is
begin
pragma Assert
- (Ekind_In (Id, E_Entry, E_Entry_Family)
- or else Is_Subprogram_Or_Generic_Subprogram (Id));
+ (Is_Entry (Id) or else Is_Subprogram_Or_Generic_Subprogram (Id));
return Flag110 (Id);
end Has_Out_Or_In_Out_Parameter;
@@ -1981,6 +1989,11 @@ package body Einfo is
return Flag182 (Id);
end Has_Xref_Entry;
+ function Has_Yield_Aspect (Id : E) return B is
+ begin
+ return Flag308 (Id);
+ end Has_Yield_Aspect;
+
function Hiding_Loop_Variable (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Variable);
@@ -2001,23 +2014,23 @@ package body Einfo is
function Ignore_SPARK_Mode_Pragmas (Id : E) return B is
begin
pragma Assert
- (Ekind_In (Id, E_Protected_Body, -- concurrent types
- E_Protected_Type,
- E_Task_Body,
- E_Task_Type)
+ (Ekind (Id) in E_Protected_Body -- concurrent types
+ | E_Protected_Type
+ | E_Task_Body
+ | E_Task_Type
or else
- Ekind_In (Id, E_Entry, -- overloadable
- E_Entry_Family,
- E_Function,
- E_Generic_Function,
- E_Generic_Procedure,
- E_Operator,
- E_Procedure,
- E_Subprogram_Body)
+ Ekind (Id) in E_Entry -- overloadable
+ | E_Entry_Family
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Procedure
+ | E_Operator
+ | E_Procedure
+ | E_Subprogram_Body
or else
- Ekind_In (Id, E_Generic_Package, -- packages
- E_Package,
- E_Package_Body));
+ Ekind (Id) in E_Generic_Package -- packages
+ | E_Package
+ | E_Package_Body);
return Flag301 (Id);
end Ignore_SPARK_Mode_Pragmas;
@@ -2063,7 +2076,7 @@ package body Einfo is
function Initialization_Statements (Id : E) return N is
begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
+ pragma Assert (Ekind (Id) in E_Constant | E_Variable);
return Node28 (Id);
end Initialization_Statements;
@@ -2077,12 +2090,6 @@ package body Einfo is
return Node21 (Id);
end Interface_Name;
- function Invariants_Ignored (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag308 (Id);
- end Invariants_Ignored;
-
function Is_Abstract_Subprogram (Id : E) return B is
begin
pragma Assert (Is_Overloadable (Id));
@@ -2147,7 +2154,7 @@ package body Einfo is
function Is_Called (Id : E) return B is
begin
- pragma Assert (Ekind_In (Id, E_Procedure, E_Function, E_Package));
+ pragma Assert (Ekind (Id) in E_Procedure | E_Function | E_Package);
return Flag102 (Id);
end Is_Called;
@@ -2228,9 +2235,15 @@ package body Einfo is
return Flag74 (Id);
end Is_CPP_Class;
+ function Is_CUDA_Kernel (Id : E) return B is
+ begin
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
+ return Flag118 (Id);
+ end Is_CUDA_Kernel;
+
function Is_DIC_Procedure (Id : E) return B is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
return Flag132 (Id);
end Is_DIC_Procedure;
@@ -2300,7 +2313,7 @@ package body Einfo is
function Is_Finalized_Transient (Id : E) return B is
begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
+ pragma Assert (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable);
return Flag252 (Id);
end Is_Finalized_Transient;
@@ -2321,7 +2334,7 @@ package body Einfo is
function Is_Generic_Actual_Subprogram (Id : E) return B is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
return Flag274 (Id);
end Is_Generic_Actual_Subprogram;
@@ -2368,7 +2381,7 @@ package body Einfo is
function Is_Ignored_Transient (Id : E) return B is
begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
+ pragma Assert (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable);
return Flag295 (Id);
end Is_Ignored_Transient;
@@ -2395,7 +2408,7 @@ package body Einfo is
function Is_Initial_Condition_Procedure (Id : E) return B is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
return Flag302 (Id);
end Is_Initial_Condition_Procedure;
@@ -2406,7 +2419,7 @@ package body Einfo is
function Is_Inlined_Always (Id : E) return B is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
return Flag1 (Id);
end Is_Inlined_Always;
@@ -2439,7 +2452,7 @@ package body Einfo is
function Is_Invariant_Procedure (Id : E) return B is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
return Flag257 (Id);
end Is_Invariant_Procedure;
@@ -2541,7 +2554,7 @@ package body Einfo is
function Is_Partial_Invariant_Procedure (Id : E) return B is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
return Flag292 (Id);
end Is_Partial_Invariant_Procedure;
@@ -2553,13 +2566,13 @@ package body Einfo is
function Is_Predicate_Function (Id : E) return B is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
return Flag255 (Id);
end Is_Predicate_Function;
function Is_Predicate_Function_M (Id : E) return B is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
return Flag256 (Id);
end Is_Predicate_Function_M;
@@ -2570,15 +2583,13 @@ package body Einfo is
function Is_Primitive (Id : E) return B is
begin
- pragma Assert
- (Is_Overloadable (Id)
- or else Ekind_In (Id, E_Generic_Function, E_Generic_Procedure));
+ pragma Assert (Is_Overloadable (Id) or else Is_Generic_Subprogram (Id));
return Flag218 (Id);
end Is_Primitive;
function Is_Primitive_Wrapper (Id : E) return B is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
return Flag195 (Id);
end Is_Primitive_Wrapper;
@@ -2595,7 +2606,7 @@ package body Einfo is
function Is_Private_Primitive (Id : E) return B is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
return Flag245 (Id);
end Is_Private_Primitive;
@@ -2781,7 +2792,7 @@ package body Einfo is
function Last_Aggregate_Assignment (Id : E) return N is
begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
+ pragma Assert (Ekind (Id) in E_Constant | E_Variable);
return Node30 (Id);
end Last_Aggregate_Assignment;
@@ -2892,7 +2903,7 @@ package body Einfo is
begin
pragma Assert
(Is_Overloadable (Id)
- or else Ekind_In (Id, E_Subprogram_Type, E_Entry_Family));
+ or else Ekind (Id) in E_Subprogram_Type | E_Entry_Family);
return Flag22 (Id);
end Needs_No_Actuals;
@@ -2972,19 +2983,19 @@ package body Einfo is
function Normalized_First_Bit (Id : E) return U is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
+ pragma Assert (Ekind (Id) in E_Component | E_Discriminant);
return Uint8 (Id);
end Normalized_First_Bit;
function Normalized_Position (Id : E) return U is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
+ pragma Assert (Ekind (Id) in E_Component | E_Discriminant);
return Uint14 (Id);
end Normalized_Position;
function Normalized_Position_Max (Id : E) return U is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
+ pragma Assert (Ekind (Id) in E_Component | E_Discriminant);
return Uint10 (Id);
end Normalized_Position_Max;
@@ -2997,14 +3008,14 @@ package body Einfo is
function Optimize_Alignment_Space (Id : E) return B is
begin
pragma Assert
- (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable));
+ (Is_Type (Id) or else Ekind (Id) in E_Constant | E_Variable);
return Flag241 (Id);
end Optimize_Alignment_Space;
function Optimize_Alignment_Time (Id : E) return B is
begin
pragma Assert
- (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable));
+ (Is_Type (Id) or else Ekind (Id) in E_Constant | E_Variable);
return Flag242 (Id);
end Optimize_Alignment_Time;
@@ -3027,7 +3038,7 @@ package body Einfo is
function Original_Record_Component (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant));
+ pragma Assert (Ekind (Id) in E_Void | E_Component | E_Discriminant);
return Node22 (Id);
end Original_Record_Component;
@@ -3044,7 +3055,7 @@ package body Einfo is
function Package_Instantiation (Id : E) return N is
begin
- pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package));
+ pragma Assert (Is_Package_Or_Generic_Package (Id));
return Node26 (Id);
end Package_Instantiation;
@@ -3062,7 +3073,7 @@ package body Einfo is
function Part_Of_Constituents (Id : E) return L is
begin
- pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
+ pragma Assert (Ekind (Id) in E_Abstract_State | E_Variable);
return Elist10 (Id);
end Part_Of_Constituents;
@@ -3086,18 +3097,17 @@ package body Einfo is
function Postconditions_Proc (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Entry,
- E_Entry_Family,
- E_Function,
- E_Procedure));
+ pragma Assert
+ (Ekind (Id) in E_Entry | E_Entry_Family | E_Function | E_Procedure);
return Node14 (Id);
end Postconditions_Proc;
function Predicated_Parent (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Array_Subtype,
- E_Record_Subtype,
- E_Record_Subtype_With_Private));
+ pragma Assert
+ (Ekind (Id) in E_Array_Subtype |
+ E_Record_Subtype |
+ E_Record_Subtype_With_Private);
return Node38 (Id);
end Predicated_Parent;
@@ -3120,7 +3130,7 @@ package body Einfo is
function Prival_Link (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
+ pragma Assert (Ekind (Id) in E_Constant | E_Variable);
return Node20 (Id);
end Prival_Link;
@@ -3144,16 +3154,14 @@ package body Einfo is
function Protected_Subprogram (Id : E) return N is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
return Node39 (Id);
end Protected_Subprogram;
function Protection_Object (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Entry,
- E_Entry_Family,
- E_Function,
- E_Procedure));
+ pragma Assert
+ (Ekind (Id) in E_Entry | E_Entry_Family | E_Function | E_Procedure);
return Node23 (Id);
end Protection_Object;
@@ -3203,20 +3211,19 @@ package body Einfo is
function Related_Expression (Id : E) return N is
begin
- pragma Assert (Ekind (Id) in Type_Kind
- or else Ekind_In (Id, E_Constant, E_Variable));
+ pragma Assert (Ekind (Id) in Type_Kind | E_Constant | E_Variable);
return Node24 (Id);
end Related_Expression;
function Related_Instance (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Package, E_Package_Body));
+ pragma Assert (Ekind (Id) in E_Package | E_Package_Body);
return Node15 (Id);
end Related_Instance;
function Related_Type (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable));
+ pragma Assert (Ekind (Id) in E_Component | E_Constant | E_Variable);
return Node27 (Id);
end Related_Type;
@@ -3320,7 +3327,7 @@ package body Einfo is
function Size_Check_Code (Id : E) return N is
begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
+ pragma Assert (Ekind (Id) in E_Constant | E_Variable);
return Node19 (Id);
end Size_Check_Code;
@@ -3343,51 +3350,51 @@ package body Einfo is
function SPARK_Aux_Pragma (Id : E) return N is
begin
pragma Assert
- (Ekind_In (Id, E_Protected_Type, -- concurrent types
- E_Task_Type)
+ (Ekind (Id) in E_Protected_Type -- concurrent types
+ | E_Task_Type
or else
- Ekind_In (Id, E_Generic_Package, -- packages
- E_Package,
- E_Package_Body));
+ Ekind (Id) in E_Generic_Package -- packages
+ | E_Package
+ | E_Package_Body);
return Node41 (Id);
end SPARK_Aux_Pragma;
function SPARK_Aux_Pragma_Inherited (Id : E) return B is
begin
pragma Assert
- (Ekind_In (Id, E_Protected_Type, -- concurrent types
- E_Task_Type)
+ (Ekind (Id) in E_Protected_Type -- concurrent types
+ | E_Task_Type
or else
- Ekind_In (Id, E_Generic_Package, -- packages
- E_Package,
- E_Package_Body));
+ Ekind (Id) in E_Generic_Package -- packages
+ | E_Package
+ | E_Package_Body);
return Flag266 (Id);
end SPARK_Aux_Pragma_Inherited;
function SPARK_Pragma (Id : E) return N is
begin
pragma Assert
- (Ekind_In (Id, E_Constant, -- objects
- E_Variable)
+ (Ekind (Id) in E_Constant -- objects
+ | E_Variable
or else
- Ekind_In (Id, E_Abstract_State, -- overloadable
- E_Entry,
- E_Entry_Family,
- E_Function,
- E_Generic_Function,
- E_Generic_Procedure,
- E_Operator,
- E_Procedure,
- E_Subprogram_Body)
+ Ekind (Id) in E_Abstract_State -- overloadable
+ | E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Procedure
+ | E_Operator
+ | E_Procedure
+ | E_Subprogram_Body
or else
- Ekind_In (Id, E_Generic_Package, -- packages
- E_Package,
- E_Package_Body)
+ Ekind (Id) in E_Generic_Package -- packages
+ | E_Package
+ | E_Package_Body
or else
- Ekind (Id) = E_Void -- special purpose
+ Ekind (Id) = E_Void -- special purpose
or else
- Ekind_In (Id, E_Protected_Body, -- types
- E_Task_Body)
+ Ekind (Id) in E_Protected_Body -- types
+ | E_Task_Body
or else
Is_Type (Id));
return Node40 (Id);
@@ -3396,27 +3403,27 @@ package body Einfo is
function SPARK_Pragma_Inherited (Id : E) return B is
begin
pragma Assert
- (Ekind_In (Id, E_Constant, -- objects
- E_Variable)
+ (Ekind (Id) in E_Constant -- objects
+ | E_Variable
or else
- Ekind_In (Id, E_Abstract_State, -- overloadable
- E_Entry,
- E_Entry_Family,
- E_Function,
- E_Generic_Function,
- E_Generic_Procedure,
- E_Operator,
- E_Procedure,
- E_Subprogram_Body)
+ Ekind (Id) in E_Abstract_State -- overloadable
+ | E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Procedure
+ | E_Operator
+ | E_Procedure
+ | E_Subprogram_Body
or else
- Ekind_In (Id, E_Generic_Package, -- packages
- E_Package,
- E_Package_Body)
+ Ekind (Id) in E_Generic_Package -- packages
+ | E_Package
+ | E_Package_Body
or else
- Ekind (Id) = E_Void -- special purpose
+ Ekind (Id) = E_Void -- special purpose
or else
- Ekind_In (Id, E_Protected_Body, -- types
- E_Task_Body)
+ Ekind (Id) in E_Protected_Body -- types
+ | E_Task_Body
or else
Is_Type (Id));
return Flag265 (Id);
@@ -3454,9 +3461,8 @@ package body Einfo is
function Status_Flag_Or_Transient_Decl (Id : E) return N is
begin
- pragma Assert (Ekind_In (Id, E_Constant,
- E_Loop_Parameter,
- E_Variable));
+ pragma Assert
+ (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable);
return Node15 (Id);
end Status_Flag_Or_Transient_Decl;
@@ -3547,7 +3553,7 @@ package body Einfo is
function Thunk_Entity (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure)
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure
and then Is_Thunk (Id));
return Node31 (Id);
end Thunk_Entity;
@@ -3621,22 +3627,27 @@ package body Einfo is
return Flag238 (Id);
end Warnings_Off_Used_Unreferenced;
+ function Was_Hidden (Id : E) return B is
+ begin
+ return Flag196 (Id);
+ end Was_Hidden;
+
function Wrapped_Entity (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure)
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure
and then Is_Primitive_Wrapper (Id));
return Node27 (Id);
end Wrapped_Entity;
- function Was_Hidden (Id : E) return B is
- begin
- return Flag196 (Id);
- end Was_Hidden;
-
------------------------------
-- Classification Functions --
------------------------------
+ function Is_Access_Object_Type (Id : E) return B is
+ begin
+ return Is_Access_Type (Id) and then not Is_Access_Subprogram_Type (Id);
+ end Is_Access_Object_Type;
+
function Is_Access_Type (Id : E) return B is
begin
return Ekind (Id) in Access_Kind;
@@ -3787,6 +3798,12 @@ package body Einfo is
return Ekind (Id) in Modular_Integer_Kind;
end Is_Modular_Integer_Type;
+ function Is_Named_Access_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in E_Access_Type ..
+ E_Access_Protected_Subprogram_Type;
+ end Is_Named_Access_Type;
+
function Is_Named_Number (Id : E) return B is
begin
return Ekind (Id) in Named_Kind;
@@ -3883,7 +3900,7 @@ package body Einfo is
procedure Set_Abstract_States (Id : E; V : L) is
begin
- pragma Assert (Ekind_In (Id, E_Generic_Package, E_Package));
+ pragma Assert (Is_Package_Or_Generic_Package (Id));
Set_Elist25 (Id, V);
end Set_Abstract_States;
@@ -3908,6 +3925,12 @@ package body Einfo is
Set_Node30 (Id, V);
end Set_Access_Disp_Table_Elab_Flag;
+ procedure Set_Access_Subprogram_Wrapper (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind (Id) = E_Subprogram_Type);
+ Set_Node41 (Id, V);
+ end Set_Access_Subprogram_Wrapper;
+
procedure Set_Anonymous_Designated_Type (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Variable);
@@ -3916,16 +3939,15 @@ package body Einfo is
procedure Set_Anonymous_Masters (Id : E; V : L) is
begin
- pragma Assert (Ekind_In (Id, E_Function,
- E_Package,
- E_Procedure,
- E_Subprogram_Body));
+ pragma Assert
+ (Ekind (Id)
+ in E_Function | E_Package | E_Procedure | E_Subprogram_Body);
Set_Elist29 (Id, V);
end Set_Anonymous_Masters;
procedure Set_Anonymous_Object (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Protected_Type, E_Task_Type));
+ pragma Assert (Ekind (Id) in E_Protected_Type | E_Task_Type);
Set_Node30 (Id, V);
end Set_Anonymous_Object;
@@ -3952,19 +3974,20 @@ package body Einfo is
procedure Set_Activation_Record_Component (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Constant,
- E_In_Parameter,
- E_In_Out_Parameter,
- E_Loop_Parameter,
- E_Out_Parameter,
- E_Variable));
+ pragma Assert
+ (Ekind (Id) in E_Constant
+ | E_In_Parameter
+ | E_In_Out_Parameter
+ | E_Loop_Parameter
+ | E_Out_Parameter
+ | E_Variable);
Set_Node31 (Id, V);
end Set_Activation_Record_Component;
procedure Set_Actual_Subtype (Id : E; V : E) is
begin
pragma Assert
- (Ekind_In (Id, E_Constant, E_Variable, E_Generic_In_Out_Parameter)
+ (Ekind (Id) in E_Constant | E_Variable | E_Generic_In_Out_Parameter
or else Is_Formal (Id));
Set_Node17 (Id, V);
end Set_Actual_Subtype;
@@ -3985,10 +4008,10 @@ package body Einfo is
begin
pragma Assert (Is_Type (Id)
or else Is_Formal (Id)
- or else Ekind_In (Id, E_Loop_Parameter,
- E_Constant,
- E_Exception,
- E_Variable));
+ or else Ekind (Id) in E_Loop_Parameter
+ | E_Constant
+ | E_Exception
+ | E_Variable);
Set_Uint14 (Id, V);
end Set_Alignment;
@@ -4006,7 +4029,7 @@ package body Einfo is
procedure Set_Body_Entity (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package));
+ pragma Assert (Is_Package_Or_Generic_Package (Id));
Set_Node19 (Id, V);
end Set_Body_Entity;
@@ -4033,7 +4056,7 @@ package body Einfo is
procedure Set_BIP_Initialization_Call (Id : E; V : N) is
begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
+ pragma Assert (Ekind (Id) in E_Constant | E_Variable);
Set_Node29 (Id, V);
end Set_BIP_Initialization_Call;
@@ -4074,19 +4097,19 @@ package body Einfo is
procedure Set_Cloned_Subtype (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Class_Wide_Subtype));
+ pragma Assert (Ekind (Id) in E_Record_Subtype | E_Class_Wide_Subtype);
Set_Node16 (Id, V);
end Set_Cloned_Subtype;
procedure Set_Component_Bit_Offset (Id : E; V : U) is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
+ pragma Assert (Ekind (Id) in E_Component | E_Discriminant);
Set_Uint11 (Id, V);
end Set_Component_Bit_Offset;
procedure Set_Component_Clause (Id : E; V : N) is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
+ pragma Assert (Ekind (Id) in E_Component | E_Discriminant);
Set_Node13 (Id, V);
end Set_Component_Clause;
@@ -4105,48 +4128,52 @@ package body Einfo is
procedure Set_Contains_Ignored_Ghost_Code (Id : E; V : B := True) is
begin
pragma Assert
- (Ekind_In (Id, E_Block,
- E_Function,
- E_Generic_Function,
- E_Generic_Package,
- E_Generic_Procedure,
- E_Package,
- E_Package_Body,
- E_Procedure,
- E_Subprogram_Body));
+ (Ekind (Id) in E_Block
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Package
+ | E_Generic_Procedure
+ | E_Package
+ | E_Package_Body
+ | E_Procedure
+ | E_Subprogram_Body);
Set_Flag279 (Id, V);
end Set_Contains_Ignored_Ghost_Code;
procedure Set_Contract (Id : E; V : N) is
begin
pragma Assert
- (Ekind_In (Id, E_Protected_Type, -- concurrent types
- E_Task_Body,
- E_Task_Type)
+ (Ekind (Id) in E_Protected_Type -- concurrent types
+ | E_Task_Body
+ | E_Task_Type
or else
- Ekind_In (Id, E_Constant, -- objects
- E_Variable)
+ Ekind (Id) in E_Constant -- objects
+ | E_Variable
or else
- Ekind_In (Id, E_Entry, -- overloadable
- E_Entry_Family,
- E_Function,
- E_Generic_Function,
- E_Generic_Procedure,
- E_Operator,
- E_Procedure,
- E_Subprogram_Body)
+ Ekind (Id) in E_Entry -- overloadable
+ | E_Entry_Family
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Procedure
+ | E_Operator
+ | E_Procedure
+ | E_Subprogram_Body
or else
- Ekind_In (Id, E_Generic_Package, -- packages
- E_Package,
- E_Package_Body)
+ Ekind (Id) in E_Generic_Package -- packages
+ | E_Package
+ | E_Package_Body
+
or else
- Ekind (Id) = E_Void); -- special purpose
+ Is_Type (Id) -- types
+
+ or else
+ Ekind (Id) = E_Void); -- special purpose
Set_Node34 (Id, V);
end Set_Contract;
procedure Set_Contract_Wrapper (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Entry, E_Entry_Family));
+ pragma Assert (Is_Entry (Id));
Set_Node25 (Id, V);
end Set_Contract_Wrapper;
@@ -4186,13 +4213,13 @@ package body Einfo is
procedure Set_Corresponding_Protected_Entry (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Void, E_Subprogram_Body));
+ pragma Assert (Ekind (Id) in E_Void | E_Subprogram_Body);
Set_Node18 (Id, V);
end Set_Corresponding_Protected_Entry;
procedure Set_Corresponding_Record_Component (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
+ pragma Assert (Ekind (Id) in E_Component | E_Discriminant);
Set_Node21 (Id, V);
end Set_Corresponding_Record_Component;
@@ -4275,7 +4302,7 @@ package body Einfo is
procedure Set_Delay_Subprogram_Descriptors (Id : E; V : B := True) is
begin
pragma Assert
- (Is_Subprogram (Id) or else Ekind_In (Id, E_Package, E_Package_Body));
+ (Is_Subprogram (Id) or else Ekind (Id) in E_Package | E_Package_Body);
Set_Flag50 (Id, V);
end Set_Delay_Subprogram_Descriptors;
@@ -4383,13 +4410,13 @@ package body Einfo is
procedure Set_DT_Position (Id : E; V : U) is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
Set_Uint15 (Id, V);
end Set_DT_Position;
procedure Set_DTC_Entity (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
Set_Node16 (Id, V);
end Set_DTC_Entity;
@@ -4404,7 +4431,7 @@ package body Einfo is
pragma Assert
(Is_Subprogram (Id)
or else
- Ekind_In (Id, E_Entry, E_Entry_Family, E_Package)
+ Ekind (Id) in E_Entry | E_Entry_Family | E_Package
or else
Is_Generic_Unit (Id));
Set_Node13 (Id, V);
@@ -4415,7 +4442,7 @@ package body Einfo is
pragma Assert
(Is_Subprogram (Id)
or else
- Ekind_In (Id, E_Entry, E_Entry_Family, E_Package)
+ Ekind (Id) in E_Entry | E_Entry_Family | E_Package
or else
Is_Generic_Unit (Id));
Set_Flag174 (Id, V);
@@ -4423,7 +4450,7 @@ package body Einfo is
procedure Set_Encapsulating_State (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Abstract_State, E_Constant, E_Variable));
+ pragma Assert (Ekind (Id) in E_Abstract_State | E_Constant | E_Variable);
Set_Node32 (Id, V);
end Set_Encapsulating_State;
@@ -4502,12 +4529,12 @@ package body Einfo is
procedure Set_Equivalent_Type (Id : E; V : E) is
begin
pragma Assert
- (Ekind_In (Id, E_Class_Wide_Type,
- E_Class_Wide_Subtype,
- E_Access_Protected_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type,
- E_Access_Subprogram_Type,
- E_Exception_Type));
+ (Ekind (Id) in E_Class_Wide_Type
+ | E_Class_Wide_Subtype
+ | E_Access_Protected_Subprogram_Type
+ | E_Anonymous_Access_Protected_Subprogram_Type
+ | E_Access_Subprogram_Type
+ | E_Exception_Type);
Set_Node18 (Id, V);
end Set_Equivalent_Type;
@@ -4519,13 +4546,14 @@ package body Einfo is
procedure Set_Extra_Accessibility (Id : E; V : E) is
begin
pragma Assert
- (Is_Formal (Id) or else Ekind_In (Id, E_Variable, E_Constant));
+ (Is_Formal (Id) or else Ekind (Id) in E_Variable | E_Constant);
Set_Node13 (Id, V);
end Set_Extra_Accessibility;
procedure Set_Extra_Accessibility_Of_Result (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Operator, E_Subprogram_Type));
+ pragma Assert
+ (Ekind (Id) in E_Function | E_Operator | E_Subprogram_Type);
Set_Node19 (Id, V);
end Set_Extra_Accessibility_Of_Result;
@@ -4544,9 +4572,9 @@ package body Einfo is
begin
pragma Assert
(Is_Overloadable (Id)
- or else Ekind_In (Id, E_Entry_Family,
- E_Subprogram_Body,
- E_Subprogram_Type));
+ or else Ekind (Id) in E_Entry_Family
+ | E_Subprogram_Body
+ | E_Subprogram_Type);
Set_Node28 (Id, V);
end Set_Extra_Formals;
@@ -4564,7 +4592,7 @@ package body Einfo is
procedure Set_Finalizer (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Package, E_Package_Body));
+ pragma Assert (Ekind (Id) in E_Package | E_Package_Body);
Set_Node28 (Id, V);
end Set_Finalizer;
@@ -4593,8 +4621,8 @@ package body Einfo is
procedure Set_First_Private_Entity (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)
- or else Ekind (Id) in Concurrent_Kind);
+ pragma Assert (Is_Package_Or_Generic_Package (Id)
+ or else Is_Concurrent_Type (Id));
Set_Node16 (Id, V);
end Set_First_Private_Entity;
@@ -4617,7 +4645,7 @@ package body Einfo is
procedure Set_From_Limited_With (Id : E; V : B := True) is
begin
pragma Assert
- (Is_Type (Id) or else Ekind_In (Id, E_Abstract_State, E_Package));
+ (Is_Type (Id) or else Ekind (Id) in E_Abstract_State | E_Package);
Set_Flag159 (Id, V);
end Set_From_Limited_With;
@@ -4779,10 +4807,8 @@ package body Einfo is
procedure Set_Has_Expanded_Contract (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Entry,
- E_Entry_Family,
- E_Function,
- E_Procedure));
+ pragma Assert
+ (Ekind (Id) in E_Entry | E_Entry_Family | E_Function | E_Procedure);
Set_Flag240 (Id, V);
end Set_Has_Expanded_Contract;
@@ -4837,7 +4863,7 @@ package body Einfo is
procedure Set_Has_Initial_Value (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Variable, E_Out_Parameter));
+ pragma Assert (Ekind (Id) in E_Variable | E_Out_Parameter);
Set_Flag219 (Id, V);
end Set_Has_Initial_Value;
@@ -4860,7 +4886,7 @@ package body Einfo is
procedure Set_Has_Missing_Return (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function));
+ pragma Assert (Ekind (Id) in E_Function | E_Generic_Function);
Set_Flag142 (Id, V);
end Set_Has_Missing_Return;
@@ -4890,7 +4916,7 @@ package body Einfo is
procedure Set_Has_Out_Or_In_Out_Parameter (Id : E; V : B := True) is
begin
pragma Assert
- (Ekind_In (Id, E_Entry, E_Entry_Family)
+ (Ekind (Id) in E_Entry | E_Entry_Family
or else Is_Subprogram_Or_Generic_Subprogram (Id));
Set_Flag110 (Id, V);
end Set_Has_Out_Or_In_Out_Parameter;
@@ -5180,6 +5206,13 @@ package body Einfo is
Set_Flag182 (Id, V);
end Set_Has_Xref_Entry;
+ procedure Set_Has_Yield_Aspect (Id : E; V : B := True) is
+ begin
+ pragma Assert
+ (Is_Entry (Id) or else Is_Subprogram_Or_Generic_Subprogram (Id));
+ Set_Flag308 (Id, V);
+ end Set_Has_Yield_Aspect;
+
procedure Set_Hiding_Loop_Variable (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Variable);
@@ -5207,23 +5240,23 @@ package body Einfo is
procedure Set_Ignore_SPARK_Mode_Pragmas (Id : E; V : B := True) is
begin
pragma Assert
- (Ekind_In (Id, E_Protected_Body, -- concurrent types
- E_Protected_Type,
- E_Task_Body,
- E_Task_Type)
+ (Ekind (Id) in E_Protected_Body -- concurrent types
+ | E_Protected_Type
+ | E_Task_Body
+ | E_Task_Type
or else
- Ekind_In (Id, E_Entry, -- overloadable
- E_Entry_Family,
- E_Function,
- E_Generic_Function,
- E_Generic_Procedure,
- E_Operator,
- E_Procedure,
- E_Subprogram_Body)
+ Ekind (Id) in E_Entry -- overloadable
+ | E_Entry_Family
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Procedure
+ | E_Operator
+ | E_Procedure
+ | E_Subprogram_Body
or else
- Ekind_In (Id, E_Generic_Package, -- packages
- E_Package,
- E_Package_Body));
+ Ekind (Id) in E_Generic_Package -- packages
+ | E_Package
+ | E_Package_Body);
Set_Flag301 (Id, V);
end Set_Ignore_SPARK_Mode_Pragmas;
@@ -5238,7 +5271,7 @@ package body Einfo is
pragma Assert
(Is_Internal (Id)
and then Is_Hidden (Id)
- and then (Ekind_In (Id, E_Procedure, E_Function)));
+ and then (Ekind (Id) in E_Procedure | E_Function));
Set_Node25 (Id, V);
end Set_Interface_Alias;
@@ -5270,7 +5303,7 @@ package body Einfo is
-- an aggregate used as the initialization expression for an object
-- declaration, and this occurs before the Ekind for the object is set.
- pragma Assert (Ekind_In (Id, E_Void, E_Constant, E_Variable));
+ pragma Assert (Ekind (Id) in E_Void | E_Constant | E_Variable);
Set_Node28 (Id, V);
end Set_Initialization_Statements;
@@ -5284,12 +5317,6 @@ package body Einfo is
Set_Node21 (Id, V);
end Set_Interface_Name;
- procedure Set_Invariants_Ignored (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag308 (Id, V);
- end Set_Invariants_Ignored;
-
procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True) is
begin
pragma Assert (Is_Overloadable (Id));
@@ -5363,7 +5390,7 @@ package body Einfo is
procedure Set_Is_Called (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Procedure, E_Function, E_Package));
+ pragma Assert (Ekind (Id) in E_Procedure | E_Function | E_Package);
Set_Flag102 (Id, V);
end Set_Is_Called;
@@ -5450,6 +5477,12 @@ package body Einfo is
Set_Flag74 (Id, V);
end Set_Is_CPP_Class;
+ procedure Set_Is_CUDA_Kernel (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
+ Set_Flag118 (Id, V);
+ end Set_Is_CUDA_Kernel;
+
procedure Set_Is_DIC_Procedure (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Procedure);
@@ -5529,7 +5562,7 @@ package body Einfo is
procedure Set_Is_Finalized_Transient (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
+ pragma Assert (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable);
Set_Flag252 (Id, V);
end Set_Is_Finalized_Transient;
@@ -5551,7 +5584,7 @@ package body Einfo is
procedure Set_Is_Generic_Actual_Subprogram (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
Set_Flag274 (Id, V);
end Set_Is_Generic_Actual_Subprogram;
@@ -5579,7 +5612,7 @@ package body Einfo is
procedure Set_Is_Hidden_Non_Overridden_Subpgm (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
Set_Flag2 (Id, V);
end Set_Is_Hidden_Non_Overridden_Subpgm;
@@ -5599,7 +5632,7 @@ package body Einfo is
procedure Set_Is_Ignored_Transient (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
+ pragma Assert (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable);
Set_Flag295 (Id, V);
end Set_Is_Ignored_Transient;
@@ -5626,7 +5659,7 @@ package body Einfo is
procedure Set_Is_Initial_Condition_Procedure (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
Set_Flag302 (Id, V);
end Set_Is_Initial_Condition_Procedure;
@@ -5637,7 +5670,7 @@ package body Einfo is
procedure Set_Is_Inlined_Always (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
Set_Flag1 (Id, V);
end Set_Is_Inlined_Always;
@@ -5764,7 +5797,7 @@ package body Einfo is
procedure Set_Is_Param_Block_Component_Type (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Void, E_General_Access_Type));
+ pragma Assert (Ekind (Id) in E_Void | E_General_Access_Type);
Set_Flag215 (Id, V);
end Set_Is_Param_Block_Component_Type;
@@ -5788,7 +5821,7 @@ package body Einfo is
procedure Set_Is_Predicate_Function_M (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
Set_Flag256 (Id, V);
end Set_Is_Predicate_Function_M;
@@ -5799,15 +5832,13 @@ package body Einfo is
procedure Set_Is_Primitive (Id : E; V : B := True) is
begin
- pragma Assert
- (Is_Overloadable (Id)
- or else Ekind_In (Id, E_Generic_Function, E_Generic_Procedure));
+ pragma Assert (Is_Overloadable (Id) or else Is_Generic_Subprogram (Id));
Set_Flag218 (Id, V);
end Set_Is_Primitive;
procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
Set_Flag195 (Id, V);
end Set_Is_Primitive_Wrapper;
@@ -5824,7 +5855,7 @@ package body Einfo is
procedure Set_Is_Private_Primitive (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
Set_Flag245 (Id, V);
end Set_Is_Private_Primitive;
@@ -5898,16 +5929,14 @@ package body Einfo is
begin
pragma Assert
(Is_Type (Id)
- or else Ekind_In (Id, E_Exception,
- E_Variable,
- E_Constant,
- E_Void));
+ or else
+ Ekind (Id) in E_Exception | E_Variable | E_Constant | E_Void);
Set_Flag28 (Id, V);
end Set_Is_Statically_Allocated;
procedure Set_Is_Tag (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable));
+ pragma Assert (Ekind (Id) in E_Component | E_Constant | E_Variable);
Set_Flag78 (Id, V);
end Set_Is_Tag;
@@ -5964,7 +5993,7 @@ package body Einfo is
procedure Set_Is_Uplevel_Referenced_Entity (Id : E; V : B := True) is
begin
pragma Assert
- (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable)
+ (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable
or else Is_Formal (Id)
or else Is_Type (Id));
Set_Flag283 (Id, V);
@@ -6021,7 +6050,7 @@ package body Einfo is
procedure Set_Last_Aggregate_Assignment (Id : E; V : N) is
begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
+ pragma Assert (Ekind (Id) in E_Constant | E_Variable);
Set_Node30 (Id, V);
end Set_Last_Aggregate_Assignment;
@@ -6133,7 +6162,7 @@ package body Einfo is
begin
pragma Assert
(Is_Overloadable (Id)
- or else Ekind_In (Id, E_Subprogram_Type, E_Entry_Family));
+ or else Ekind (Id) in E_Subprogram_Type | E_Entry_Family);
Set_Flag22 (Id, V);
end Set_Needs_No_Actuals;
@@ -6173,8 +6202,7 @@ package body Einfo is
procedure Set_No_Return (Id : E; V : B := True) is
begin
- pragma Assert
- (V = False or else Ekind_In (Id, E_Procedure, E_Generic_Procedure));
+ pragma Assert (Is_Subprogram (Id) or else Is_Generic_Subprogram (Id));
Set_Flag113 (Id, V);
end Set_No_Return;
@@ -6200,7 +6228,7 @@ package body Einfo is
begin
pragma Assert
(Ekind (Id) in Incomplete_Kind
- or else Ekind_In (Id, E_Abstract_State, E_Class_Wide_Type));
+ or else Ekind (Id) in E_Abstract_State | E_Class_Wide_Type);
Set_Node19 (Id, V);
end Set_Non_Limited_View;
@@ -6214,19 +6242,19 @@ package body Einfo is
procedure Set_Normalized_First_Bit (Id : E; V : U) is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
+ pragma Assert (Ekind (Id) in E_Component | E_Discriminant);
Set_Uint8 (Id, V);
end Set_Normalized_First_Bit;
procedure Set_Normalized_Position (Id : E; V : U) is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
+ pragma Assert (Ekind (Id) in E_Component | E_Discriminant);
Set_Uint14 (Id, V);
end Set_Normalized_Position;
procedure Set_Normalized_Position_Max (Id : E; V : U) is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
+ pragma Assert (Ekind (Id) in E_Component | E_Discriminant);
Set_Uint10 (Id, V);
end Set_Normalized_Position_Max;
@@ -6239,14 +6267,14 @@ package body Einfo is
procedure Set_Optimize_Alignment_Space (Id : E; V : B := True) is
begin
pragma Assert
- (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable));
+ (Is_Type (Id) or else Ekind (Id) in E_Constant | E_Variable);
Set_Flag241 (Id, V);
end Set_Optimize_Alignment_Space;
procedure Set_Optimize_Alignment_Time (Id : E; V : B := True) is
begin
pragma Assert
- (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable));
+ (Is_Type (Id) or else Ekind (Id) in E_Constant | E_Variable);
Set_Flag242 (Id, V);
end Set_Optimize_Alignment_Time;
@@ -6264,13 +6292,13 @@ package body Einfo is
procedure Set_Original_Protected_Subprogram (Id : E; V : N) is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
Set_Node41 (Id, V);
end Set_Original_Protected_Subprogram;
procedure Set_Original_Record_Component (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant));
+ pragma Assert (Ekind (Id) in E_Void | E_Component | E_Discriminant);
Set_Node22 (Id, V);
end Set_Original_Record_Component;
@@ -6287,7 +6315,7 @@ package body Einfo is
procedure Set_Package_Instantiation (Id : E; V : N) is
begin
- pragma Assert (Ekind_In (Id, E_Void, E_Generic_Package, E_Package));
+ pragma Assert (Ekind (Id) in E_Void | E_Generic_Package | E_Package);
Set_Node26 (Id, V);
end Set_Package_Instantiation;
@@ -6305,7 +6333,7 @@ package body Einfo is
procedure Set_Part_Of_Constituents (Id : E; V : L) is
begin
- pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
+ pragma Assert (Ekind (Id) in E_Abstract_State | E_Variable);
Set_Elist10 (Id, V);
end Set_Part_Of_Constituents;
@@ -6329,18 +6357,16 @@ package body Einfo is
procedure Set_Postconditions_Proc (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Entry,
- E_Entry_Family,
- E_Function,
- E_Procedure));
+ pragma Assert
+ (Ekind (Id) in E_Entry | E_Entry_Family | E_Function | E_Procedure);
Set_Node14 (Id, V);
end Set_Postconditions_Proc;
procedure Set_Predicated_Parent (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Array_Subtype,
- E_Record_Subtype,
- E_Record_Subtype_With_Private));
+ pragma Assert (Ekind (Id) in E_Array_Subtype
+ | E_Record_Subtype
+ | E_Record_Subtype_With_Private);
Set_Node38 (Id, V);
end Set_Predicated_Parent;
@@ -6364,7 +6390,7 @@ package body Einfo is
procedure Set_Prival_Link (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
+ pragma Assert (Ekind (Id) in E_Constant | E_Variable);
Set_Node20 (Id, V);
end Set_Prival_Link;
@@ -6393,16 +6419,16 @@ package body Einfo is
procedure Set_Protected_Subprogram (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
Set_Node39 (Id, V);
end Set_Protected_Subprogram;
procedure Set_Protection_Object (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Entry,
- E_Entry_Family,
- E_Function,
- E_Procedure));
+ pragma Assert (Ekind (Id) in E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Procedure);
Set_Node23 (Id, V);
end Set_Protection_Object;
@@ -6452,20 +6478,20 @@ package body Einfo is
procedure Set_Related_Expression (Id : E; V : N) is
begin
- pragma Assert (Ekind (Id) in Type_Kind
- or else Ekind_In (Id, E_Constant, E_Variable, E_Void));
+ pragma Assert
+ (Ekind (Id) in Type_Kind | E_Constant | E_Variable | E_Void);
Set_Node24 (Id, V);
end Set_Related_Expression;
procedure Set_Related_Instance (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Package, E_Package_Body));
+ pragma Assert (Ekind (Id) in E_Package | E_Package_Body);
Set_Node15 (Id, V);
end Set_Related_Instance;
procedure Set_Related_Type (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable));
+ pragma Assert (Ekind (Id) in E_Component | E_Constant | E_Variable);
Set_Node27 (Id, V);
end Set_Related_Type;
@@ -6573,7 +6599,7 @@ package body Einfo is
procedure Set_Size_Check_Code (Id : E; V : N) is
begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
+ pragma Assert (Ekind (Id) in E_Constant | E_Variable);
Set_Node19 (Id, V);
end Set_Size_Check_Code;
@@ -6596,51 +6622,51 @@ package body Einfo is
procedure Set_SPARK_Aux_Pragma (Id : E; V : N) is
begin
pragma Assert
- (Ekind_In (Id, E_Protected_Type, -- concurrent types
- E_Task_Type)
+ (Ekind (Id) in E_Protected_Type -- concurrent types
+ | E_Task_Type
or else
- Ekind_In (Id, E_Generic_Package, -- packages
- E_Package,
- E_Package_Body));
+ Ekind (Id) in E_Generic_Package -- packages
+ | E_Package
+ | E_Package_Body);
Set_Node41 (Id, V);
end Set_SPARK_Aux_Pragma;
procedure Set_SPARK_Aux_Pragma_Inherited (Id : E; V : B := True) is
begin
pragma Assert
- (Ekind_In (Id, E_Protected_Type, -- concurrent types
- E_Task_Type)
+ (Ekind (Id) in E_Protected_Type -- concurrent types
+ | E_Task_Type
or else
- Ekind_In (Id, E_Generic_Package, -- packages
- E_Package,
- E_Package_Body));
+ Ekind (Id) in E_Generic_Package -- packages
+ | E_Package
+ | E_Package_Body);
Set_Flag266 (Id, V);
end Set_SPARK_Aux_Pragma_Inherited;
procedure Set_SPARK_Pragma (Id : E; V : N) is
begin
pragma Assert
- (Ekind_In (Id, E_Constant, -- objects
- E_Variable)
+ (Ekind (Id) in E_Constant -- objects
+ | E_Variable
or else
- Ekind_In (Id, E_Abstract_State, -- overloadable
- E_Entry,
- E_Entry_Family,
- E_Function,
- E_Generic_Function,
- E_Generic_Procedure,
- E_Operator,
- E_Procedure,
- E_Subprogram_Body)
+ Ekind (Id) in E_Abstract_State -- overloadable
+ | E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Procedure
+ | E_Operator
+ | E_Procedure
+ | E_Subprogram_Body
or else
- Ekind_In (Id, E_Generic_Package, -- packages
- E_Package,
- E_Package_Body)
+ Ekind (Id) in E_Generic_Package -- packages
+ | E_Package
+ | E_Package_Body
or else
- Ekind (Id) = E_Void -- special purpose
+ Ekind (Id) = E_Void -- special purpose
or else
- Ekind_In (Id, E_Protected_Body, -- types
- E_Task_Body)
+ Ekind (Id) in E_Protected_Body -- types
+ | E_Task_Body
or else
Is_Type (Id));
Set_Node40 (Id, V);
@@ -6649,27 +6675,27 @@ package body Einfo is
procedure Set_SPARK_Pragma_Inherited (Id : E; V : B := True) is
begin
pragma Assert
- (Ekind_In (Id, E_Constant, -- objects
- E_Variable)
+ (Ekind (Id) in E_Constant -- objects
+ | E_Variable
or else
- Ekind_In (Id, E_Abstract_State, -- overloadable
- E_Entry,
- E_Entry_Family,
- E_Function,
- E_Generic_Function,
- E_Generic_Procedure,
- E_Operator,
- E_Procedure,
- E_Subprogram_Body)
+ Ekind (Id) in E_Abstract_State -- overloadable
+ | E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Procedure
+ | E_Operator
+ | E_Procedure
+ | E_Subprogram_Body
or else
- Ekind_In (Id, E_Generic_Package, -- packages
- E_Package,
- E_Package_Body)
+ Ekind (Id) in E_Generic_Package -- packages
+ | E_Package
+ | E_Package_Body
or else
- Ekind (Id) = E_Void -- special purpose
+ Ekind (Id) = E_Void -- special purpose
or else
- Ekind_In (Id, E_Protected_Body, -- types
- E_Task_Body)
+ Ekind (Id) in E_Protected_Body -- types
+ | E_Task_Body
or else
Is_Type (Id));
Set_Flag265 (Id, V);
@@ -6712,9 +6738,9 @@ package body Einfo is
procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Constant,
- E_Loop_Parameter,
- E_Variable));
+ pragma Assert (Ekind (Id) in E_Constant
+ | E_Loop_Parameter
+ | E_Variable);
Set_Node15 (Id, V);
end Set_Status_Flag_Or_Transient_Decl;
@@ -6809,7 +6835,7 @@ package body Einfo is
procedure Set_Thunk_Entity (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure)
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure
and then Is_Thunk (Id));
Set_Node31 (Id, V);
end Set_Thunk_Entity;
@@ -6891,7 +6917,7 @@ package body Einfo is
procedure Set_Wrapped_Entity (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure)
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure
and then Is_Primitive_Wrapper (Id));
Set_Node27 (Id, V);
end Set_Wrapped_Entity;
@@ -7311,7 +7337,7 @@ package body Einfo is
end if;
loop
- if Nkind_In (P, N_Selected_Component, N_Expanded_Name)
+ if Nkind (P) in N_Selected_Component | N_Expanded_Name
or else (Nkind (P) = N_Defining_Program_Unit_Name
and then Is_Child_Unit (Id))
then
@@ -7405,7 +7431,7 @@ package body Einfo is
Comp_Id := First_Entity (Id);
while Present (Comp_Id) loop
exit when Ekind (Comp_Id) = E_Component;
- Comp_Id := Next_Entity (Comp_Id);
+ Next_Entity (Comp_Id);
end loop;
return Comp_Id;
@@ -7427,8 +7453,8 @@ package body Einfo is
Comp_Id := First_Entity (Id);
while Present (Comp_Id) loop
- exit when Ekind_In (Comp_Id, E_Component, E_Discriminant);
- Comp_Id := Next_Entity (Comp_Id);
+ exit when Ekind (Comp_Id) in E_Component | E_Discriminant;
+ Next_Entity (Comp_Id);
end loop;
return Comp_Id;
@@ -7445,9 +7471,9 @@ package body Einfo is
pragma Assert
(Is_Generic_Subprogram (Id)
or else Is_Overloadable (Id)
- or else Ekind_In (Id, E_Entry_Family,
- E_Subprogram_Body,
- E_Subprogram_Type));
+ or else Ekind (Id) in E_Entry_Family
+ | E_Subprogram_Body
+ | E_Subprogram_Type);
if Ekind (Id) = E_Enumeration_Literal then
return Empty;
@@ -7486,9 +7512,9 @@ package body Einfo is
pragma Assert
(Is_Generic_Subprogram (Id)
or else Is_Overloadable (Id)
- or else Ekind_In (Id, E_Entry_Family,
- E_Subprogram_Body,
- E_Subprogram_Type));
+ or else Ekind (Id) in E_Entry_Family
+ | E_Subprogram_Body
+ | E_Subprogram_Type);
if Ekind (Id) = E_Enumeration_Literal then
return Empty;
@@ -7755,7 +7781,7 @@ package body Einfo is
return True;
end if;
- Ent := Next_Entity (Ent);
+ Next_Entity (Ent);
end loop;
return False;
@@ -7827,7 +7853,7 @@ package body Einfo is
function Has_Non_Null_Abstract_State (Id : E) return B is
begin
- pragma Assert (Ekind_In (Id, E_Generic_Package, E_Package));
+ pragma Assert (Is_Package_Or_Generic_Package (Id));
return
Present (Abstract_States (Id))
@@ -7863,7 +7889,7 @@ package body Einfo is
-----------------------------
function Has_Null_Abstract_State (Id : E) return B is
- pragma Assert (Ekind_In (Id, E_Generic_Package, E_Package));
+ pragma Assert (Is_Package_Or_Generic_Package (Id));
States : constant Elist_Id := Abstract_States (Id);
@@ -8058,7 +8084,7 @@ package body Einfo is
function Is_Constant_Object (Id : E) return B is
begin
- return Ekind_In (Id, E_Constant, E_In_Parameter, E_Loop_Parameter);
+ return Ekind (Id) in E_Constant | E_In_Parameter | E_Loop_Parameter;
end Is_Constant_Object;
-------------------
@@ -8076,7 +8102,7 @@ package body Einfo is
function Is_Discriminal (Id : E) return B is
begin
- return Ekind_In (Id, E_Constant, E_In_Parameter)
+ return Ekind (Id) in E_Constant | E_In_Parameter
and then Present (Discriminal_Link (Id));
end Is_Discriminal;
@@ -8138,7 +8164,7 @@ package body Einfo is
function Is_Elaboration_Target (Id : Entity_Id) return Boolean is
begin
return
- Ekind_In (Id, E_Constant, E_Package, E_Variable)
+ Ekind (Id) in E_Constant | E_Package | E_Variable
or else Is_Entry (Id)
or else Is_Generic_Unit (Id)
or else Is_Subprogram (Id)
@@ -8180,6 +8206,15 @@ package body Einfo is
Ekind (Id) = E_Abstract_State and then Nkind (Parent (Id)) = N_Null;
end Is_Null_State;
+ -----------------------------------
+ -- Is_Package_Or_Generic_Package --
+ -----------------------------------
+
+ function Is_Package_Or_Generic_Package (Id : E) return B is
+ begin
+ return Ekind (Id) in E_Generic_Package | E_Package;
+ end Is_Package_Or_Generic_Package;
+
---------------------
-- Is_Packed_Array --
---------------------
@@ -8189,22 +8224,13 @@ package body Einfo is
return Is_Array_Type (Id) and then Is_Packed (Id);
end Is_Packed_Array;
- -----------------------------------
- -- Is_Package_Or_Generic_Package --
- -----------------------------------
-
- function Is_Package_Or_Generic_Package (Id : E) return B is
- begin
- return Ekind_In (Id, E_Generic_Package, E_Package);
- end Is_Package_Or_Generic_Package;
-
---------------
-- Is_Prival --
---------------
function Is_Prival (Id : E) return B is
begin
- return Ekind_In (Id, E_Constant, E_Variable)
+ return Ekind (Id) in E_Constant | E_Variable
and then Present (Prival_Link (Id));
end Is_Prival;
@@ -8244,6 +8270,20 @@ package body Einfo is
and then Is_Protected_Type (Corresponding_Concurrent_Type (Id));
end Is_Protected_Record_Type;
+ -------------------------------------
+ -- Is_Relaxed_Initialization_State --
+ -------------------------------------
+
+ function Is_Relaxed_Initialization_State (Id : E) return B is
+ begin
+ -- To qualify, the abstract state must appear with simple option
+ -- "Relaxed_Initialization" (SPARK RM 6.10).
+
+ return
+ Ekind (Id) = E_Abstract_State
+ and then Has_Option (Id, Name_Relaxed_Initialization);
+ end Is_Relaxed_Initialization_State;
+
--------------------------------
-- Is_Standard_Character_Type --
--------------------------------
@@ -8383,9 +8423,9 @@ package body Einfo is
begin
pragma Assert
(Is_Overloadable (Id)
- or else Ekind_In (Id, E_Entry_Family,
- E_Subprogram_Body,
- E_Subprogram_Type));
+ or else Ekind (Id) in E_Entry_Family
+ | E_Subprogram_Body
+ | E_Subprogram_Type);
if Ekind (Id) = E_Enumeration_Literal then
return Empty;
@@ -8416,44 +8456,6 @@ package body Einfo is
Set_Next_Entity (First, Second); -- First --> Second
end Link_Entities;
- ----------------------
- -- Model_Emin_Value --
- ----------------------
-
- function Model_Emin_Value (Id : E) return Uint is
- begin
- return Machine_Emin_Value (Id);
- end Model_Emin_Value;
-
- -------------------------
- -- Model_Epsilon_Value --
- -------------------------
-
- function Model_Epsilon_Value (Id : E) return Ureal is
- Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
- begin
- return Radix ** (1 - Model_Mantissa_Value (Id));
- end Model_Epsilon_Value;
-
- --------------------------
- -- Model_Mantissa_Value --
- --------------------------
-
- function Model_Mantissa_Value (Id : E) return Uint is
- begin
- return Machine_Mantissa_Value (Id);
- end Model_Mantissa_Value;
-
- -----------------------
- -- Model_Small_Value --
- -----------------------
-
- function Model_Small_Value (Id : E) return Ureal is
- Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
- begin
- return Radix ** (Model_Emin_Value (Id) - 1);
- end Model_Small_Value;
-
------------------------
-- Machine_Emax_Value --
------------------------
@@ -8529,6 +8531,44 @@ package body Einfo is
end case;
end Machine_Radix_Value;
+ ----------------------
+ -- Model_Emin_Value --
+ ----------------------
+
+ function Model_Emin_Value (Id : E) return Uint is
+ begin
+ return Machine_Emin_Value (Id);
+ end Model_Emin_Value;
+
+ -------------------------
+ -- Model_Epsilon_Value --
+ -------------------------
+
+ function Model_Epsilon_Value (Id : E) return Ureal is
+ Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
+ begin
+ return Radix ** (1 - Model_Mantissa_Value (Id));
+ end Model_Epsilon_Value;
+
+ --------------------------
+ -- Model_Mantissa_Value --
+ --------------------------
+
+ function Model_Mantissa_Value (Id : E) return Uint is
+ begin
+ return Machine_Mantissa_Value (Id);
+ end Model_Mantissa_Value;
+
+ -----------------------
+ -- Model_Small_Value --
+ -----------------------
+
+ function Model_Small_Value (Id : E) return Ureal is
+ Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
+ begin
+ return Radix ** (Model_Emin_Value (Id) - 1);
+ end Model_Small_Value;
+
--------------------
-- Next_Component --
--------------------
@@ -8540,7 +8580,7 @@ package body Einfo is
Comp_Id := Next_Entity (Id);
while Present (Comp_Id) loop
exit when Ekind (Comp_Id) = E_Component;
- Comp_Id := Next_Entity (Comp_Id);
+ Next_Entity (Comp_Id);
end loop;
return Comp_Id;
@@ -8556,8 +8596,8 @@ package body Einfo is
begin
Comp_Id := Next_Entity (Id);
while Present (Comp_Id) loop
- exit when Ekind_In (Comp_Id, E_Component, E_Discriminant);
- Comp_Id := Next_Entity (Comp_Id);
+ exit when Ekind (Comp_Id) in E_Component | E_Discriminant;
+ Next_Entity (Comp_Id);
end loop;
return Comp_Id;
@@ -8590,7 +8630,7 @@ package body Einfo is
pragma Assert (Ekind (Id) = E_Discriminant);
loop
- D := Next_Entity (D);
+ Next_Entity (D);
if No (D)
or else (Ekind (D) /= E_Discriminant
and then not Is_Itype (D))
@@ -8715,7 +8755,7 @@ package body Einfo is
N := N + 1;
end if;
- Ent := Next_Entity (Ent);
+ Next_Entity (Ent);
end loop;
return N;
@@ -8734,7 +8774,7 @@ package body Einfo is
Formal := First_Formal (Id);
while Present (Formal) loop
N := N + 1;
- Formal := Next_Formal (Formal);
+ Next_Formal (Formal);
end loop;
return N;
@@ -8894,9 +8934,9 @@ package body Einfo is
then
Typ := Full_View (Id);
- elsif Ekind_In (Id, E_Array_Subtype,
- E_Record_Subtype,
- E_Record_Subtype_With_Private)
+ elsif Ekind (Id) in E_Array_Subtype
+ | E_Record_Subtype
+ | E_Record_Subtype_With_Private
and then Present (Predicated_Parent (Id))
then
Typ := Predicated_Parent (Id);
@@ -9611,7 +9651,7 @@ package body Einfo is
return Empty;
end if;
- -- For non-incomplete, non-private types, return the type itself Also
+ -- For non-incomplete, non-private types, return the type itself. Also
-- for entities that are not types at all return the entity itself.
else
@@ -9793,11 +9833,11 @@ package body Einfo is
W ("Has_Visible_Refinement", Flag263 (Id));
W ("Has_Volatile_Components", Flag87 (Id));
W ("Has_Xref_Entry", Flag182 (Id));
+ W ("Has_Yield_Aspect", Flag308 (Id));
W ("Ignore_SPARK_Mode_Pragmas", Flag301 (Id));
W ("In_Package_Body", Flag48 (Id));
W ("In_Private_Part", Flag45 (Id));
W ("In_Use", Flag8 (Id));
- W ("Invariants_Ignored", Flag308 (Id));
W ("Is_Abstract_Subprogram", Flag19 (Id));
W ("Is_Abstract_Type", Flag146 (Id));
W ("Is_Access_Constant", Flag69 (Id));
@@ -9810,6 +9850,7 @@ package body Einfo is
W ("Is_Atomic", Flag85 (Id));
W ("Is_Bit_Packed_Array", Flag122 (Id));
W ("Is_CPP_Class", Flag74 (Id));
+ W ("Is_CUDA_Kernel", Flag118 (Id));
W ("Is_Called", Flag102 (Id));
W ("Is_Character_Type", Flag63 (Id));
W ("Is_Checked_Ghost_Entity", Flag277 (Id));
@@ -10166,7 +10207,9 @@ package body Einfo is
when E_Abstract_State =>
Write_Str ("Refinement_Constituents");
- when E_Return_Statement =>
+ when E_Block
+ | E_Return_Statement
+ =>
Write_Str ("Return_Applies_To");
when others =>
@@ -10935,6 +10978,7 @@ package body Einfo is
when Type_Kind
| E_Constant
+ | E_Loop_Parameter
| E_Variable
=>
Write_Str ("Related_Expression");
@@ -11271,11 +11315,10 @@ package body Einfo is
| E_Package
| E_Package_Body
| E_Procedure
- | E_Protected_Type
| E_Subprogram_Body
| E_Task_Body
- | E_Task_Type
| E_Variable
+ | Type_Kind
| E_Void
=>
Write_Str ("Contract");
@@ -11424,6 +11467,9 @@ package body Einfo is
=>
Write_Str ("SPARK_Aux_Pragma");
+ when E_Subprogram_Type =>
+ Write_Str ("Access_Subprogram_Wrapper");
+
when others =>
Write_Str ("Field41??");
end case;
@@ -11442,7 +11488,7 @@ package body Einfo is
begin
N := Next_Entity (N);
while Present (N) loop
- exit when Ekind_In (N, E_Component, E_Discriminant);
+ exit when Ekind (N) in E_Component | E_Discriminant;
N := Next_Entity (N);
end loop;
end Proc_Next_Component_Or_Discriminant;
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index a55d5a7..7932c92 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -111,12 +111,14 @@ package Einfo is
-- The function spec must be on a single line
--- There can only be a single statement, contained on a single line,
--- not counting any pragma Assert statements.
+-- There can only be a single return statement, not counting any pragma
+-- Assert statements, possibly followed by a comment.
--- This single statement must either be a function call with simple,
--- single token arguments, or it must be a membership test of the form
--- a in b, where a and b are single tokens.
+-- This single statement must either contain a function call with simple,
+-- single token arguments, or it must contain a membership test of the form
+-- a in b, where a and b are single tokens, or it must contain an equality
+-- or inequality test of single tokens, or it must contain a disjunction of
+-- the preceding constructs.
-- For functions that are not inlined, there is no restriction on the body,
-- and XEINFO generates a direct reference in the C header file which allows
@@ -264,28 +266,29 @@ package Einfo is
-- The flag Has_Delayed_Freeze indicates that an entity carries an explicit
-- freeze node, which appears later in the expanded tree.
--- a) The flag is used by the front-end to trigger expansion actions which
+-- a) The flag is used by the front end to trigger expansion activities which
-- include the generation of that freeze node. Typically this happens at the
-- end of the current compilation unit, or before the first subprogram body is
--- encountered in the current unit. See files freeze and exp_ch13 for details
+-- encountered in the current unit. See units Freeze and Exp_Ch13 for details
-- on the actions triggered by a freeze node, which include the construction
-- of initialization procedures and dispatch tables.
--- b) The presence of a freeze node on an entity is used by the backend to
+-- b) The presence of a freeze node on an entity is used by the back end to
-- defer elaboration of the entity until its freeze node is seen. In the
-- absence of an explicit freeze node, an entity is frozen (and elaborated)
-- at the point of declaration.
-- For object declarations, the flag is set when an address clause for the
-- object is encountered. Legality checks on the address expression only take
--- place at the freeze point of the object.
+-- place at the freeze point of the object. In Ada 2012, the flag is also set
+-- when an address aspect for the object is encountered.
-- Most types have an explicit freeze node, because they cannot be elaborated
-- until all representation and operational items that apply to them have been
-- analyzed. Private types and incomplete types have the flag set as well, as
-- do task and protected types.
--- Implicit base types created for type derivations, as well as classwide
+-- Implicit base types created for type derivations, as well as class-wide
-- types created for all tagged types, have the flag set.
-- If a subprogram has an access parameter whose designated type is incomplete
@@ -370,6 +373,15 @@ package Einfo is
-- on attribute 'Position applied to an object of the type; it is used by
-- the IP routine to avoid performing this elaboration twice.
+-- Access_Subprogram_Wrapper (Node41)
+-- Entity created for access_to_subprogram types that have pre/post
+-- conditions. Wrapper subprogram is created when analyzing corresponding
+-- aspect, and inherits said aspects. Body of subprogram includes code
+-- to check contracts, and a direct call to the designated subprogram.
+-- The body is part of the freeze actions for the type.
+-- The Subprogram_Type created for the Access_To_Subprogram carries the
+-- Access_Subprogram_Wrapper for use in the expansion of indirect calls.
+
-- Activation_Record_Component (Node31)
-- Defined for E_Variable, E_Constant, E_Loop_Parameter, and formal
-- parameter entities. Used in Opt.Unnest_Subprogram_Mode, in which case
@@ -527,7 +539,7 @@ package Einfo is
-- Block_Node (Node11)
-- Defined in block entities. Points to the identifier in the
-- Block_Statement itself. Used when retrieving the block construct
--- for finalization purposes, The block entity has an implicit label
+-- for finalization purposes, the block entity has an implicit label
-- declaration in the enclosing declarative part, and has otherwise
-- no direct connection in the tree with the block statement. The
-- link is to the identifier (which is an occurrence of the entity)
@@ -580,7 +592,7 @@ package Einfo is
-- never have a null value. Set for constant access values initialized to
-- a non-null value. This is also set for all access parameters in Ada 83
-- and Ada 95 modes, and for access parameters that explicitly exclude
--- exclude null in Ada 2005 mode.
+-- null in Ada 2005 mode.
--
-- This is used to avoid unnecessary resetting of the Is_Known_Non_Null
-- flag for such entities. In Ada 2005 mode, this is also used when
@@ -733,9 +745,9 @@ package Einfo is
-- Contract (Node34)
-- Defined in constant, entry, entry family, operator, [generic] package,
--- package body, protected type, [generic] subprogram, subprogram body,
--- variable and task type entities. Points to the contract of the entity,
--- holding various assertion items and data classifiers.
+-- package body, protected unit, [generic] subprogram, subprogram body,
+-- variable, task unit, and type entities. Points to the contract of the
+-- entity, holding various assertion items and data classifiers.
-- Contract_Wrapper (Node25)
-- Defined in entry and entry family entities. Set only when the entry
@@ -811,7 +823,7 @@ package Einfo is
-- Defined in all object entities. Set in E_Variable, E_Constant, formal
-- parameters and E_Loop_Parameter entities if we have trackable current
-- values. Set non-Empty if the (constant) current value of the variable
--- is known, This value is valid only for references from the same
+-- is known. This value is valid only for references from the same
-- sequential scope as the entity. The sequential scope of an entity
-- includes the immediate scope and any contained scopes that are package
-- specs, package bodies, blocks (at any nesting level) or statement
@@ -973,7 +985,7 @@ package Einfo is
-- list is always empty.
-- When expansion is disabled the corresponding record type of a
-- synchronized type is not constructed. In that case, such types
--- carry this attribute directly, for ASIS use.
+-- carry this attribute directly.
-- Directly_Designated_Type (Node20)
-- Defined in access types. This field points to the type that is
@@ -1217,14 +1229,16 @@ package Einfo is
-- for the same literal.
-- Enum_Pos_To_Rep (Node23)
--- Defined in enumeration types (but not enumeration subtypes). Set to
--- Empty unless the enumeration type has a non-standard representation
--- (i.e. at least one literal has a representation value different from
--- its pos value). In this case, Enum_Pos_To_Rep is the entity for an
--- array constructed when the type is frozen that maps Pos values to
--- corresponding Rep values. The index type of this array is Natural,
--- and the component type is a suitable integer type that holds the
--- full range of representation values.
+-- Defined in enumeration types, but not enumeration subtypes. Set to
+-- Empty unless the enumeration type has a non-standard representation,
+-- i.e. at least one literal has a representation value different from
+-- its position value. In this case, the alternative is the following:
+-- if the representation is not contiguous, then Enum_Pos_To_Rep is the
+-- entity for an array constant built when the type is frozen that maps
+-- Pos values to corresponding Rep values, whose index type is Natural
+-- and whose component type is the enumeration type itself; or else, if
+-- the representation is contiguous, then Enum_Pos_To_Rep is the entity
+-- of the index type defined above.
-- Equivalent_Type (Node18)
-- Defined in class wide types and subtypes, access to protected
@@ -1575,7 +1589,7 @@ package Einfo is
-- in sem_aux is used to test for this case.
-- Has_Contiguous_Rep (Flag181)
--- Defined in enumeration types. Set if the type as a representation
+-- Defined in enumeration types. Set if the type has a representation
-- clause whose entries are successive integers.
-- Has_Controlled_Component (Flag43) [base type only]
@@ -1679,9 +1693,10 @@ package Einfo is
-- rewritten into something else and subsequently reanalyzed/expanded.
-- Has_Foreign_Convention (synthesized)
--- Applies to all entities. Determines if the Convention for the
--- entity is a foreign convention (i.e. is other than Convention_Ada,
--- Convention_Intrinsic, Convention_Entry or Convention_Protected).
+-- Applies to all entities. Determines if the Convention for the entity
+-- is a foreign convention, i.e. non-native: other than Convention_Ada,
+-- Convention_Intrinsic, Convention_Entry, Convention_Protected,
+-- Convention_Stubbed and Convention_Ada_Pass_By_(Copy,Reference).
-- Has_Forward_Instantiation (Flag175)
-- Defined in package entities. Set for packages that instantiate local
@@ -1799,8 +1814,8 @@ package Einfo is
-- See documentation in backend for further details.
-- Has_Nested_Subprogram (Flag282)
--- Defined in subprogram entities. Set for a subprogram which contains at
--- least one nested subprogram.
+-- Defined in subprogram entities. Set for a subprogram which contains at
+-- least one nested subprogram.
-- Has_Non_Limited_View (synth)
-- Defined in E_Incomplete_Type, E_Incomplete_Subtype, E_Class_Wide_Type,
@@ -1846,12 +1861,16 @@ package Einfo is
-- Has_Own_DIC (Flag3) [base type only]
-- Defined in all type entities. Set for a private type and its full view
--- when the type is subject to pragma Default_Initial_Condition.
+-- (and its underlying full view, if the full view is itsef private) when
+-- the type is subject to pragma Default_Initial_Condition.
-- Has_Own_Invariants (Flag232) [base type only]
-- Defined in all type entities. Set on any type that defines at least
--- one invariant of its own. The flag is also set on the full view of a
--- private type for completeness.
+-- one invariant of its own.
+
+-- Note: this flag is set on both partial and full view of types to which
+-- an Invariant pragma or aspect applies, and on the underlying full view
+-- if the full view is private.
-- Has_Partial_Visible_Refinement (Flag296)
-- Defined in E_Abstract_State entities. Set when a state has at least
@@ -1971,7 +1990,8 @@ package Einfo is
-- Predicate aspect from its parent or progenitor types.
--
-- Note: this flag is set on both partial and full view of types to which
--- a Predicate pragma or aspect applies.
+-- a Predicate pragma or aspect applies, and on the underlying full view
+-- if the full view is private.
-- Has_Primitive_Operations (Flag120) [base type only]
-- Defined in all type entities. Set if at least one primitive operation
@@ -2170,6 +2190,10 @@ package Einfo is
-- references an entity with a type reference. See package Lib.Xref for
-- further details).
+-- Has_Yield_Aspect (Flag308)
+-- Defined in subprograms, generic subprograms, entries, entry families.
+-- Set if the entity has aspect Yield.
+
-- Hiding_Loop_Variable (Node8)
-- Defined in variables. Set only if a variable of a discrete type is
-- hidden by a loop variable in the same local scope, in which case
@@ -2267,11 +2291,6 @@ package Einfo is
-- implemented by a tagged type that are not already implemented by the
-- ancestors (Ada 2005: AI-251).
--- Invariants_Ignored (Flag308)
--- Defined on all types. Indicates whether the type declaration is in
--- a context where Assertion_Policy is Ignore, in which case no checks
--- (static or dynamic) must be generated for objects of the type.
-
-- Invariant_Procedure (synthesized)
-- Defined in types and subtypes. Set for private types and their full
-- views if one or more [class-wide] invariants apply to the type, or
@@ -2313,6 +2332,9 @@ package Einfo is
-- Is_Access_Type (synthesized)
-- Applies to all entities, true for access types and subtypes
+-- Is_Access_Object_Type (synthesized)
+-- Applies to all entities, true for access-to-object types and subtypes
+
-- Is_Activation_Record (Flag305)
-- Applies to E_In_Parameters generated in Exp_Unst for nested
-- subprograms, to mark the added formal that carries the activation
@@ -2486,6 +2508,10 @@ package Einfo is
-- Defined in all type entities, set only for tagged types to which a
-- valid pragma Import (CPP, ...) or pragma CPP_Class has been applied.
+-- Is_CUDA_Kernel (Flag118)
+-- Defined in function and procedure entities. Set if the subprogram is a
+-- CUDA kernel.
+
-- Is_Decimal_Fixed_Point_Type (synthesized)
-- Applies to all type entities, true for decimal fixed point
-- types and subtypes.
@@ -3170,6 +3196,10 @@ package Einfo is
-- Applies to all entities, true for record types and subtypes,
-- includes class-wide types and subtypes (which are also records).
+-- Is_Relaxed_Initialization_State (synthesized)
+-- Applies to all entities, true for abstract states that are subject to
+-- option Relaxed_Initialization.
+
-- Is_Remote_Call_Interface (Flag62)
-- Defined in all entities. Set in E_Package and E_Generic_Package
-- entities to which a pragma Remote_Call_Interface is applied, and
@@ -3706,8 +3736,8 @@ package Einfo is
-- pragma No_Component_Reordering applies.
-- No_Return (Flag113)
--- Defined in all entities. Always false except in the case of procedures
--- and generic procedures for which a pragma No_Return is given.
+-- Defined in all entities. Set for subprograms and generic subprograms
+-- to which a valid aspect or pragma No_Return applies.
-- No_Strict_Aliasing (Flag136) [base type only]
-- Defined in access types. Set to direct the backend to avoid any
@@ -4166,6 +4196,10 @@ package Einfo is
-- RM-6.5(4/2). Note that a (simple) return statement within an
-- extended_return_statement applies to the extended_return_statement,
-- even though it causes the whole function to return.
+-- Also defined in special E_Block entities built as E_Return_Statement
+-- for extended return statements and attached to the block statement
+-- by Expand_N_Extended_Return_Statement before being turned into an
+-- E_Block by semantic analysis.
-- Return_Present (Flag54)
-- Defined in function and generic function entities. Set if the
@@ -4175,9 +4209,10 @@ package Einfo is
-- for the function case.
-- Returns_By_Ref (Flag90)
--- Defined in function entities. Set if the function returns the result
--- by reference, either because its return type is a by-reference-type
--- or because the function explicitly uses the secondary stack.
+-- Defined in subprogram type entities and functions. Set if a function
+-- (or an access-to-function type) returns a result by reference, either
+-- because its return type is a by-reference-type or because the function
+-- explicitly uses the secondary stack.
-- Reverse_Bit_Order (Flag164) [base type only]
-- Defined in all record type entities. Set if entity has a Bit_Order
@@ -5184,10 +5219,6 @@ package Einfo is
-- there are some attributes that are significant for the body entity.
-- For example, collection of exception handlers.
- E_Protected_Object,
- -- A protected object, created by an object declaration that declares
- -- an object of a protected type.
-
E_Protected_Body,
-- A protected body. This entity serves almost no function, since all
-- semantic analysis uses the protected entity (E_Protected_Type).
@@ -5817,6 +5848,7 @@ package Einfo is
-- Has_Null_Visible_Refinement (synth)
-- Is_External_State (synth)
-- Is_Null_State (synth)
+ -- Is_Relaxed_Initialization_State (synth)
-- Is_Synchronized_State (synth)
-- Partial_Refinement_Constituents (synth)
@@ -5897,6 +5929,7 @@ package Einfo is
-- (plus type attributes)
-- E_Block
+ -- Return_Applies_To (Node8)
-- Block_Node (Node11)
-- First_Entity (Node17)
-- Last_Entity (Node20)
@@ -6067,6 +6100,7 @@ package Einfo is
-- SPARK_Pragma (Node40) (protected kind)
-- Default_Expressions_Processed (Flag108)
-- Entry_Accepted (Flag152)
+ -- Has_Yield_Aspect (Flag308)
-- Has_Expanded_Contract (Flag240)
-- Ignore_SPARK_Mode_Pragmas (Flag301)
-- Is_Elaboration_Checks_OK_Id (Flag148)
@@ -6204,10 +6238,12 @@ package Einfo is
-- Has_Nested_Subprogram (Flag282)
-- Has_Out_Or_In_Out_Parameter (Flag110)
-- Has_Recursive_Call (Flag143)
+ -- Has_Yield_Aspect (Flag308)
-- Ignore_SPARK_Mode_Pragmas (Flag301)
-- Is_Abstract_Subprogram (Flag19) (non-generic case only)
-- Is_Called (Flag102) (non-generic case only)
-- Is_Constructor (Flag76)
+ -- Is_CUDA_Kernel (Flag118) (non-generic case only)
-- Is_DIC_Procedure (Flag132) (non-generic case only)
-- Is_Discrim_SO_Function (Flag176)
-- Is_Discriminant_Check_Function (Flag264)
@@ -6529,11 +6565,13 @@ package Einfo is
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
-- Has_Nested_Subprogram (Flag282)
+ -- Has_Yield_Aspect (Flag308)
-- Ignore_SPARK_Mode_Pragmas (Flag301)
-- Is_Abstract_Subprogram (Flag19) (non-generic case only)
-- Is_Asynchronous (Flag81)
-- Is_Called (Flag102) (non-generic case only)
-- Is_Constructor (Flag76)
+ -- Is_CUDA_Kernel (Flag118)
-- Is_DIC_Procedure (Flag132) (non-generic case only)
-- Is_Elaboration_Checks_OK_Id (Flag148)
-- Is_Elaboration_Warnings_OK_Id (Flag304)
@@ -6715,10 +6753,12 @@ package Einfo is
-- Extra_Accessibility_Of_Result (Node19)
-- Directly_Designated_Type (Node20)
-- Extra_Formals (Node28)
+ -- Access_Subprogram_Wrapper (Node41)
-- First_Formal (synth)
-- First_Formal_With_Extras (synth)
-- Last_Formal (synth)
-- Number_Formals (synth)
+ -- Returns_By_Ref (Flag90)
-- (plus type attributes)
-- E_Task_Body
@@ -7061,6 +7101,7 @@ package Einfo is
function Accept_Address (Id : E) return L;
function Access_Disp_Table (Id : E) return L;
function Access_Disp_Table_Elab_Flag (Id : E) return E;
+ function Access_Subprogram_Wrapper (Id : E) return E;
function Activation_Record_Component (Id : E) return E;
function Actual_Subtype (Id : E) return E;
function Address_Taken (Id : E) return B;
@@ -7087,7 +7128,6 @@ package Einfo is
function Class_Wide_Clone (Id : E) return E;
function Class_Wide_Type (Id : E) return E;
function Cloned_Subtype (Id : E) return E;
- function Component_Alignment (Id : E) return C;
function Component_Bit_Offset (Id : E) return U;
function Component_Clause (Id : E) return N;
function Component_Size (Id : E) return U;
@@ -7195,7 +7235,6 @@ package Einfo is
function Has_Delayed_Aspects (Id : E) return B;
function Has_Delayed_Freeze (Id : E) return B;
function Has_Delayed_Rep_Aspects (Id : E) return B;
- function Has_DIC (Id : E) return B;
function Has_Discriminants (Id : E) return B;
function Has_Dispatch_Table (Id : E) return B;
function Has_Dynamic_Predicate_Aspect (Id : E) return B;
@@ -7212,8 +7251,6 @@ package Einfo is
function Has_Inherited_DIC (Id : E) return B;
function Has_Inherited_Invariants (Id : E) return B;
function Has_Initial_Value (Id : E) return B;
- function Has_Interrupt_Handler (Id : E) return B;
- function Has_Invariants (Id : E) return B;
function Has_Loop_Entry_Attributes (Id : E) return B;
function Has_Machine_Radix_Clause (Id : E) return B;
function Has_Master_Entity (Id : E) return B;
@@ -7273,6 +7310,7 @@ package Einfo is
function Has_Visible_Refinement (Id : E) return B;
function Has_Volatile_Components (Id : E) return B;
function Has_Xref_Entry (Id : E) return B;
+ function Has_Yield_Aspect (Id : E) return B;
function Hiding_Loop_Variable (Id : E) return E;
function Hidden_In_Formal_Instance (Id : E) return L;
function Homonym (Id : E) return E;
@@ -7287,7 +7325,6 @@ package Einfo is
function Interface_Alias (Id : E) return E;
function Interface_Name (Id : E) return N;
function Interfaces (Id : E) return L;
- function Invariants_Ignored (Id : E) return B;
function Is_Abstract_Subprogram (Id : E) return B;
function Is_Abstract_Type (Id : E) return B;
function Is_Access_Constant (Id : E) return B;
@@ -7298,7 +7335,6 @@ package Einfo is
function Is_Aliased (Id : E) return B;
function Is_Asynchronous (Id : E) return B;
function Is_Atomic (Id : E) return B;
- function Is_Atomic_Or_VFA (Id : E) return B;
function Is_Bit_Packed_Array (Id : E) return B;
function Is_Called (Id : E) return B;
function Is_Character_Type (Id : E) return B;
@@ -7315,6 +7351,7 @@ package Einfo is
function Is_Controlled_Active (Id : E) return B;
function Is_Controlling_Formal (Id : E) return B;
function Is_CPP_Class (Id : E) return B;
+ function Is_CUDA_Kernel (Id : E) return B;
function Is_Descendant_Of_Address (Id : E) return B;
function Is_DIC_Procedure (Id : E) return B;
function Is_Discrim_SO_Function (Id : E) return B;
@@ -7558,6 +7595,7 @@ package Einfo is
-- Is_Generic_Type where the Ekind does not provide the needed
-- information).
+ function Is_Access_Object_Type (Id : E) return B;
function Is_Access_Type (Id : E) return B;
function Is_Access_Protected_Subprogram_Type (Id : E) return B;
function Is_Access_Subprogram_Type (Id : E) return B;
@@ -7593,6 +7631,7 @@ package Einfo is
function Is_Integer_Type (Id : E) return B;
function Is_Limited_Record (Id : E) return B;
function Is_Modular_Integer_Type (Id : E) return B;
+ function Is_Named_Access_Type (Id : E) return B;
function Is_Named_Number (Id : E) return B;
function Is_Numeric_Type (Id : E) return B;
function Is_Object (Id : E) return B;
@@ -7621,6 +7660,7 @@ package Einfo is
function Aft_Value (Id : E) return U;
function Alignment_Clause (Id : E) return N;
function Base_Type (Id : E) return E;
+ function Component_Alignment (Id : E) return C;
function Declaration_Node (Id : E) return N;
function Designated_Type (Id : E) return E;
function First_Component (Id : E) return E;
@@ -7628,14 +7668,18 @@ package Einfo is
function First_Formal (Id : E) return E;
function First_Formal_With_Extras (Id : E) return E;
function Has_Attach_Handler (Id : E) return B;
+ function Has_DIC (Id : E) return B;
function Has_Entries (Id : E) return B;
function Has_Foreign_Convention (Id : E) return B;
+ function Has_Interrupt_Handler (Id : E) return B;
+ function Has_Invariants (Id : E) return B;
function Has_Non_Limited_View (Id : E) return B;
function Has_Non_Null_Abstract_State (Id : E) return B;
function Has_Non_Null_Visible_Refinement (Id : E) return B;
function Has_Null_Abstract_State (Id : E) return B;
function Has_Null_Visible_Refinement (Id : E) return B;
function Implementation_Base_Type (Id : E) return E;
+ function Is_Atomic_Or_VFA (Id : E) return B;
function Is_Base_Type (Id : E) return B;
function Is_Boolean_Type (Id : E) return B;
function Is_Constant_Object (Id : E) return B;
@@ -7652,6 +7696,7 @@ package Einfo is
function Is_Protected_Component (Id : E) return B;
function Is_Protected_Interface (Id : E) return B;
function Is_Protected_Record_Type (Id : E) return B;
+ function Is_Relaxed_Initialization_State (Id : E) return B;
function Is_Standard_Character_Type (Id : E) return B;
function Is_Standard_String_Type (Id : E) return B;
function Is_String_Type (Id : E) return B;
@@ -7674,6 +7719,7 @@ package Einfo is
function Next_Discriminant (Id : E) return E;
function Next_Formal (Id : E) return E;
function Next_Formal_With_Extras (Id : E) return E;
+ function Next_Index (Id : N) return N;
function Next_Literal (Id : E) return E;
function Next_Stored_Discriminant (Id : E) return E;
function Number_Dimensions (Id : E) return Pos;
@@ -7687,6 +7733,7 @@ package Einfo is
function Safe_Emax_Value (Id : E) return U;
function Safe_First_Value (Id : E) return R;
function Safe_Last_Value (Id : E) return R;
+ function Scope_Depth (Id : E) return U;
function Scope_Depth_Set (Id : E) return B;
function Size_Clause (Id : E) return N;
function Stream_Size_Clause (Id : E) return N;
@@ -7767,6 +7814,7 @@ package Einfo is
procedure Set_Accept_Address (Id : E; V : L);
procedure Set_Access_Disp_Table (Id : E; V : L);
procedure Set_Access_Disp_Table_Elab_Flag (Id : E; V : E);
+ procedure Set_Access_Subprogram_Wrapper (Id : E; V : E);
procedure Set_Activation_Record_Component (Id : E; V : E);
procedure Set_Actual_Subtype (Id : E; V : E);
procedure Set_Address_Taken (Id : E; V : B := True);
@@ -7977,6 +8025,7 @@ package Einfo is
procedure Set_Has_Visible_Refinement (Id : E; V : B := True);
procedure Set_Has_Volatile_Components (Id : E; V : B := True);
procedure Set_Has_Xref_Entry (Id : E; V : B := True);
+ procedure Set_Has_Yield_Aspect (Id : E; V : B := True);
procedure Set_Hiding_Loop_Variable (Id : E; V : E);
procedure Set_Hidden_In_Formal_Instance (Id : E; V : L);
procedure Set_Homonym (Id : E; V : E);
@@ -7991,7 +8040,6 @@ package Einfo is
procedure Set_Interface_Alias (Id : E; V : E);
procedure Set_Interface_Name (Id : E; V : N);
procedure Set_Interfaces (Id : E; V : L);
- procedure Set_Invariants_Ignored (Id : E; V : B := True);
procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True);
procedure Set_Is_Abstract_Type (Id : E; V : B := True);
procedure Set_Is_Access_Constant (Id : E; V : B := True);
@@ -8019,6 +8067,7 @@ package Einfo is
procedure Set_Is_Controlled_Active (Id : E; V : B := True);
procedure Set_Is_Controlling_Formal (Id : E; V : B := True);
procedure Set_Is_CPP_Class (Id : E; V : B := True);
+ procedure Set_Is_CUDA_Kernel (Id : E; V : B := True);
procedure Set_Is_Descendant_Of_Address (Id : E; V : B := True);
procedure Set_Is_DIC_Procedure (Id : E; V : B := True);
procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True);
@@ -8301,8 +8350,8 @@ package Einfo is
-- entities whose Ekind has not been set yet).
procedure Init_Alignment (Id : E; V : Int);
- procedure Init_Component_Size (Id : E; V : Int);
procedure Init_Component_Bit_Offset (Id : E; V : Int);
+ procedure Init_Component_Size (Id : E; V : Int);
procedure Init_Digits_Value (Id : E; V : Int);
procedure Init_Esize (Id : E; V : Int);
procedure Init_Normalized_First_Bit (Id : E; V : Int);
@@ -8311,8 +8360,8 @@ package Einfo is
procedure Init_RM_Size (Id : E; V : Int);
procedure Init_Alignment (Id : E);
- procedure Init_Component_Size (Id : E);
procedure Init_Component_Bit_Offset (Id : E);
+ procedure Init_Component_Size (Id : E);
procedure Init_Digits_Value (Id : E);
procedure Init_Esize (Id : E);
procedure Init_Normalized_First_Bit (Id : E);
@@ -8320,6 +8369,14 @@ package Einfo is
procedure Init_Normalized_Position_Max (Id : E);
procedure Init_RM_Size (Id : E);
+ procedure Init_Component_Location (Id : E);
+ -- Initializes all fields describing the location of a component
+ -- (Normalized_Position, Component_Bit_Offset, Normalized_First_Bit,
+ -- Normalized_Position_Max, Esize) to all be Unknown.
+
+ procedure Init_Size (Id : E; V : Int);
+ -- Initialize both the Esize and RM_Size fields of E to V
+
procedure Init_Size_Align (Id : E);
-- This procedure initializes both size fields and the alignment
-- field to all be Unknown.
@@ -8328,14 +8385,6 @@ package Einfo is
-- Same as Init_Size_Align except RM_Size field (which is only for types)
-- is unaffected.
- procedure Init_Size (Id : E; V : Int);
- -- Initialize both the Esize and RM_Size fields of E to V
-
- procedure Init_Component_Location (Id : E);
- -- Initializes all fields describing the location of a component
- -- (Normalized_Position, Component_Bit_Offset, Normalized_First_Bit,
- -- Normalized_Position_Max, Esize) to all be Unknown.
-
---------------
-- Iterators --
---------------
@@ -8522,18 +8571,9 @@ package Einfo is
-- NOTE: No updates are done to the First_Entity and Last_Entity fields
-- of the scope.
- function Next_Index (Id : Node_Id) return Node_Id;
- -- Given an index from a previous call to First_Index or Next_Index,
- -- returns a node representing the occurrence of the next index subtype,
- -- or Empty if there are no more index subtypes.
-
procedure Remove_Entity (Id : Entity_Id);
-- Remove entity Id from the entity chain of its scope
- function Scope_Depth (Id : Entity_Id) return Uint;
- -- Returns the scope depth value of the Id, unless the Id is a record
- -- type, in which case it returns the scope depth of the record scope.
-
function Subtype_Kind (K : Entity_Kind) return Entity_Kind;
-- Given an entity_kind K this function returns the entity_kind
-- corresponding to subtype kind of the type represented by K. For
@@ -8595,9 +8635,9 @@ package Einfo is
-- the given field, depending on the Ekind. No blanks or end of lines are
-- output, just the characters of the field name.
- --------------------
- -- Inline Pragmas --
- --------------------
+ ----------------------------------
+ -- Inline Pragmas for functions --
+ ----------------------------------
-- Note that these inline pragmas are referenced by the XEINFO utility
-- program in preparing the corresponding C header, and only those
@@ -8608,6 +8648,7 @@ package Einfo is
pragma Inline (Accept_Address);
pragma Inline (Access_Disp_Table);
pragma Inline (Access_Disp_Table_Elab_Flag);
+ pragma Inline (Access_Subprogram_Wrapper);
pragma Inline (Activation_Record_Component);
pragma Inline (Actual_Subtype);
pragma Inline (Address_Taken);
@@ -8644,6 +8685,8 @@ package Einfo is
pragma Inline (Corresponding_Concurrent_Type);
pragma Inline (Corresponding_Discriminant);
pragma Inline (Corresponding_Equality);
+ pragma Inline (Corresponding_Function);
+ pragma Inline (Corresponding_Procedure);
pragma Inline (Corresponding_Protected_Entry);
pragma Inline (Corresponding_Record_Component);
pragma Inline (Corresponding_Record_Type);
@@ -8692,6 +8735,7 @@ package Einfo is
pragma Inline (Entry_Formal);
pragma Inline (Entry_Index_Constant);
pragma Inline (Entry_Index_Type);
+ pragma Inline (Entry_Max_Queue_Lengths_Array);
pragma Inline (Entry_Parameters_Type);
pragma Inline (Enum_Pos_To_Rep);
pragma Inline (Enumeration_Pos);
@@ -8704,6 +8748,7 @@ package Einfo is
pragma Inline (Extra_Constrained);
pragma Inline (Extra_Formal);
pragma Inline (Extra_Formals);
+ pragma Inline (Finalize_Storage_Only);
pragma Inline (Finalization_Master);
pragma Inline (Finalizer);
pragma Inline (First_Entity);
@@ -8736,6 +8781,7 @@ package Einfo is
pragma Inline (Has_Delayed_Aspects);
pragma Inline (Has_Delayed_Freeze);
pragma Inline (Has_Delayed_Rep_Aspects);
+ pragma Inline (Has_DIC);
pragma Inline (Has_Discriminants);
pragma Inline (Has_Dispatch_Table);
pragma Inline (Has_Dynamic_Predicate_Aspect);
@@ -8752,6 +8798,7 @@ package Einfo is
pragma Inline (Has_Inherited_DIC);
pragma Inline (Has_Inherited_Invariants);
pragma Inline (Has_Initial_Value);
+ pragma Inline (Has_Invariants);
pragma Inline (Has_Loop_Entry_Attributes);
pragma Inline (Has_Machine_Radix_Clause);
pragma Inline (Has_Master_Entity);
@@ -8811,6 +8858,7 @@ package Einfo is
pragma Inline (Has_Visible_Refinement);
pragma Inline (Has_Volatile_Components);
pragma Inline (Has_Xref_Entry);
+ pragma Inline (Has_Yield_Aspect);
pragma Inline (Hiding_Loop_Variable);
pragma Inline (Hidden_In_Formal_Instance);
pragma Inline (Homonym);
@@ -8820,11 +8868,11 @@ package Einfo is
pragma Inline (In_Package_Body);
pragma Inline (In_Private_Part);
pragma Inline (In_Use);
+ pragma Inline (Initialization_Statements);
pragma Inline (Inner_Instances);
pragma Inline (Interface_Alias);
pragma Inline (Interface_Name);
pragma Inline (Interfaces);
- pragma Inline (Invariants_Ignored);
pragma Inline (Is_Abstract_Subprogram);
pragma Inline (Is_Abstract_Type);
pragma Inline (Is_Access_Constant);
@@ -8837,6 +8885,7 @@ package Einfo is
pragma Inline (Is_Ada_2012_Only);
pragma Inline (Is_Aggregate_Type);
pragma Inline (Is_Aliased);
+ pragma Inline (Is_Anonymous_Access_Type);
pragma Inline (Is_Array_Type);
pragma Inline (Is_Assignable);
pragma Inline (Is_Asynchronous);
@@ -8863,6 +8912,7 @@ package Einfo is
pragma Inline (Is_Controlled_Active);
pragma Inline (Is_Controlling_Formal);
pragma Inline (Is_CPP_Class);
+ pragma Inline (Is_CUDA_Kernel);
pragma Inline (Is_Decimal_Fixed_Point_Type);
pragma Inline (Is_Descendant_Of_Address);
pragma Inline (Is_DIC_Procedure);
@@ -8973,6 +9023,8 @@ package Einfo is
pragma Inline (Is_Static_Type);
pragma Inline (Is_Statically_Allocated);
pragma Inline (Is_Subprogram);
+ pragma Inline (Is_Subprogram_Or_Entry);
+ pragma Inline (Is_Subprogram_Or_Generic_Subprogram);
pragma Inline (Is_Tag);
pragma Inline (Is_Tagged_Type);
pragma Inline (Is_Task_Type);
@@ -9019,6 +9071,7 @@ package Einfo is
pragma Inline (Next_Index);
pragma Inline (Next_Inlined_Subprogram);
pragma Inline (Next_Literal);
+ pragma Inline (Next_Stored_Discriminant);
pragma Inline (No_Dynamic_Predicate_On_Actual);
pragma Inline (No_Pool_Assigned);
pragma Inline (No_Predicate_On_Actual);
@@ -9137,17 +9190,84 @@ package Einfo is
pragma Inline (Was_Hidden);
pragma Inline (Wrapped_Entity);
- pragma Inline (Init_Alignment);
- pragma Inline (Init_Component_Bit_Offset);
- pragma Inline (Init_Component_Size);
- pragma Inline (Init_Digits_Value);
- pragma Inline (Init_Esize);
- pragma Inline (Init_RM_Size);
+ -- END XEINFO INLINES
+
+ -- The following Inline pragmas are *not* read by XEINFO when building the
+ -- C version of this interface automatically (so the C version will end up
+ -- making out of line calls). The pragma scan in XEINFO will be terminated
+ -- on encountering the END XEINFO INLINES line. We inline things here which
+ -- are small, but not of the canonical attribute access/set format that can
+ -- be handled by XEINFO.
+
+ pragma Inline (Address_Clause);
+ pragma Inline (Alignment_Clause);
+ pragma Inline (Base_Type);
+ pragma Inline (Float_Rep);
+ pragma Inline (Has_Foreign_Convention);
+ pragma Inline (Has_Non_Limited_View);
+ pragma Inline (Is_Base_Type);
+ pragma Inline (Is_Boolean_Type);
+ pragma Inline (Is_Constant_Object);
+ pragma Inline (Is_Controlled);
+ pragma Inline (Is_Discriminal);
+ pragma Inline (Is_Entity_Name);
+ pragma Inline (Is_Finalizer);
+ pragma Inline (Is_Null_State);
+ pragma Inline (Is_Package_Or_Generic_Package);
+ pragma Inline (Is_Packed_Array);
+ pragma Inline (Is_Prival);
+ pragma Inline (Is_Protected_Component);
+ pragma Inline (Is_Protected_Record_Type);
+ pragma Inline (Is_String_Type);
+ pragma Inline (Is_Task_Record_Type);
+ pragma Inline (Is_Volatile);
+ pragma Inline (Is_Wrapper_Package);
+ pragma Inline (Scope_Depth);
+ pragma Inline (Scope_Depth_Set);
+ pragma Inline (Size_Clause);
+ pragma Inline (Stream_Size_Clause);
+ pragma Inline (Type_High_Bound);
+ pragma Inline (Type_Low_Bound);
+
+ pragma Inline (Known_Alignment);
+ pragma Inline (Known_Component_Bit_Offset);
+ pragma Inline (Known_Component_Size);
+ pragma Inline (Known_Esize);
+ pragma Inline (Known_Normalized_First_Bit);
+ pragma Inline (Known_Normalized_Position);
+ pragma Inline (Known_Normalized_Position_Max);
+ pragma Inline (Known_RM_Size);
+
+ pragma Inline (Known_Static_Component_Bit_Offset);
+ pragma Inline (Known_Static_Component_Size);
+ pragma Inline (Known_Static_Esize);
+ pragma Inline (Known_Static_Normalized_First_Bit);
+ pragma Inline (Known_Static_Normalized_Position);
+ pragma Inline (Known_Static_Normalized_Position_Max);
+ pragma Inline (Known_Static_RM_Size);
+
+ pragma Inline (Unknown_Alignment);
+ pragma Inline (Unknown_Component_Bit_Offset);
+ pragma Inline (Unknown_Component_Size);
+ pragma Inline (Unknown_Esize);
+ pragma Inline (Unknown_Normalized_First_Bit);
+ pragma Inline (Unknown_Normalized_Position);
+ pragma Inline (Unknown_Normalized_Position_Max);
+ pragma Inline (Unknown_RM_Size);
+
+ -----------------------------------
+ -- Inline Pragmas for procedures --
+ -----------------------------------
+
+ -- The following inline pragmas are *not* referenced by the XEINFO utility
+ -- program in preparing the corresponding C header, and therefore do *not*
+ -- need to meet the requirements documented in the section on XEINFO.
pragma Inline (Set_Abstract_States);
pragma Inline (Set_Accept_Address);
pragma Inline (Set_Access_Disp_Table);
pragma Inline (Set_Access_Disp_Table_Elab_Flag);
+ pragma Inline (Set_Access_Subprogram_Wrapper);
pragma Inline (Set_Activation_Record_Component);
pragma Inline (Set_Actual_Subtype);
pragma Inline (Set_Address_Taken);
@@ -9184,6 +9304,8 @@ package Einfo is
pragma Inline (Set_Corresponding_Concurrent_Type);
pragma Inline (Set_Corresponding_Discriminant);
pragma Inline (Set_Corresponding_Equality);
+ pragma Inline (Set_Corresponding_Function);
+ pragma Inline (Set_Corresponding_Procedure);
pragma Inline (Set_Corresponding_Protected_Entry);
pragma Inline (Set_Corresponding_Record_Component);
pragma Inline (Set_Corresponding_Record_Type);
@@ -9243,6 +9365,7 @@ package Einfo is
pragma Inline (Set_Extra_Constrained);
pragma Inline (Set_Extra_Formal);
pragma Inline (Set_Extra_Formals);
+ pragma Inline (Set_Finalize_Storage_Only);
pragma Inline (Set_Finalization_Master);
pragma Inline (Set_Finalizer);
pragma Inline (Set_First_Entity);
@@ -9251,6 +9374,7 @@ package Einfo is
pragma Inline (Set_First_Literal);
pragma Inline (Set_First_Private_Entity);
pragma Inline (Set_First_Rep_Item);
+ pragma Inline (Set_Float_Rep);
pragma Inline (Set_Freeze_Node);
pragma Inline (Set_From_Limited_With);
pragma Inline (Set_Full_View);
@@ -9349,6 +9473,7 @@ package Einfo is
pragma Inline (Set_Has_Visible_Refinement);
pragma Inline (Set_Has_Volatile_Components);
pragma Inline (Set_Has_Xref_Entry);
+ pragma Inline (Set_Has_Yield_Aspect);
pragma Inline (Set_Hiding_Loop_Variable);
pragma Inline (Set_Hidden_In_Formal_Instance);
pragma Inline (Set_Homonym);
@@ -9358,11 +9483,11 @@ package Einfo is
pragma Inline (Set_In_Package_Body);
pragma Inline (Set_In_Private_Part);
pragma Inline (Set_In_Use);
+ pragma Inline (Set_Initialization_Statements);
pragma Inline (Set_Inner_Instances);
pragma Inline (Set_Interface_Alias);
pragma Inline (Set_Interface_Name);
pragma Inline (Set_Interfaces);
- pragma Inline (Set_Invariants_Ignored);
pragma Inline (Set_Is_Abstract_Subprogram);
pragma Inline (Set_Is_Abstract_Type);
pragma Inline (Set_Is_Access_Constant);
@@ -9390,6 +9515,7 @@ package Einfo is
pragma Inline (Set_Is_Controlled_Active);
pragma Inline (Set_Is_Controlling_Formal);
pragma Inline (Set_Is_CPP_Class);
+ pragma Inline (Set_Is_CUDA_Kernel);
pragma Inline (Set_Is_Descendant_Of_Address);
pragma Inline (Set_Is_DIC_Procedure);
pragma Inline (Set_Is_Discrim_SO_Function);
@@ -9627,31 +9753,14 @@ package Einfo is
pragma Inline (Set_Was_Hidden);
pragma Inline (Set_Wrapped_Entity);
- -- END XEINFO INLINES
-
- -- The following Inline pragmas are *not* read by xeinfo when building the
- -- C version of this interface automatically (so the C version will end up
- -- making out of line calls). The pragma scan in xeinfo will be terminated
- -- on encountering the END XEINFO INLINES line. We inline things here which
- -- are small, but not of the canonical attribute access/set format that can
- -- be handled by xeinfo.
-
- pragma Inline (Base_Type);
- pragma Inline (Is_Base_Type);
- pragma Inline (Is_Boolean_Type);
- pragma Inline (Is_Controlled);
- pragma Inline (Is_Entity_Name);
- pragma Inline (Is_Package_Or_Generic_Package);
- pragma Inline (Is_Packed_Array);
- pragma Inline (Is_String_Type);
- pragma Inline (Is_Subprogram_Or_Generic_Subprogram);
- pragma Inline (Is_Volatile);
- pragma Inline (Is_Wrapper_Package);
- pragma Inline (Known_RM_Size);
- pragma Inline (Known_Static_Component_Bit_Offset);
- pragma Inline (Known_Static_RM_Size);
- pragma Inline (Scope_Depth);
- pragma Inline (Scope_Depth_Set);
- pragma Inline (Unknown_RM_Size);
+ pragma Inline (Init_Alignment);
+ pragma Inline (Init_Component_Bit_Offset);
+ pragma Inline (Init_Component_Size);
+ pragma Inline (Init_Digits_Value);
+ pragma Inline (Init_Esize);
+ pragma Inline (Init_Normalized_First_Bit);
+ pragma Inline (Init_Normalized_Position);
+ pragma Inline (Init_Normalized_Position_Max);
+ pragma Inline (Init_RM_Size);
end Einfo;
diff --git a/gcc/ada/elists.adb b/gcc/ada/elists.adb
index 9294cbd..90bcd2e 100644
--- a/gcc/ada/elists.adb
+++ b/gcc/ada/elists.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -580,26 +580,6 @@ package body Elists is
Elmts.Table (Elmt).Node := New_Node;
end Replace_Elmt;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- Elists.Tree_Read;
- Elmts.Tree_Read;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Elists.Tree_Write;
- Elmts.Tree_Write;
- end Tree_Write;
-
------------
-- Unlock --
------------
diff --git a/gcc/ada/elists.ads b/gcc/ada/elists.ads
index 8a3b364..12672a6 100644
--- a/gcc/ada/elists.ads
+++ b/gcc/ada/elists.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -57,8 +57,7 @@ package Elists is
procedure Initialize;
-- Initialize allocation of element list tables. Called at the start of
- -- compiling each new main source file. Note that Initialize must not be
- -- called if Tree_Read is used.
+ -- compiling each new main source file.
procedure Lock;
-- Lock tables used for element lists before calling backend
@@ -66,15 +65,6 @@ package Elists is
procedure Unlock;
-- Unlock list tables, in cases where the back end needs to modify them
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines. Note that Initialize should not be called if
- -- Tree_Read is used. Tree_Read includes all necessary initialization.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
function Last_Elist_Id return Elist_Id;
-- Returns Id of last allocated element list header
diff --git a/gcc/ada/elists.h b/gcc/ada/elists.h
index ac6efa2..75a009e 100644
--- a/gcc/ada/elists.h
+++ b/gcc/ada/elists.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/env.c b/gcc/ada/env.c
index 698b177..5df0539 100644
--- a/gcc/ada/env.c
+++ b/gcc/ada/env.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2005-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2005-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/env.h b/gcc/ada/env.h
index 69454e0..d0a2ae1 100644
--- a/gcc/ada/env.h
+++ b/gcc/ada/env.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2009-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2009-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/err_vars.ads b/gcc/ada/err_vars.ads
index cc0ffeb..7afe705 100644
--- a/gcc/ada/err_vars.ads
+++ b/gcc/ada/err_vars.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/errno.c b/gcc/ada/errno.c
index 18f14ea..061d0f0 100644
--- a/gcc/ada/errno.c
+++ b/gcc/ada/errno.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index a08c6df..1063d7d 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -311,6 +311,18 @@ package body Errout is
end Error_Msg;
procedure Error_Msg
+ (Msg : String;
+ Flag_Location : Source_Ptr;
+ Is_Compile_Time_Pragma : Boolean)
+ is
+ Save_Is_Compile_Time_Msg : constant Boolean := Is_Compile_Time_Msg;
+ begin
+ Is_Compile_Time_Msg := Is_Compile_Time_Pragma;
+ Error_Msg (Msg, Flag_Location, Current_Node);
+ Is_Compile_Time_Msg := Save_Is_Compile_Time_Msg;
+ end Error_Msg;
+
+ procedure Error_Msg
(Msg : String;
Flag_Location : Source_Ptr;
N : Node_Id)
@@ -618,6 +630,24 @@ package body Errout is
end if;
end Error_Msg_Ada_2012_Feature;
+ --------------------------------
+ -- Error_Msg_Ada_2020_Feature --
+ --------------------------------
+
+ procedure Error_Msg_Ada_2020_Feature (Feature : String; Loc : Source_Ptr) is
+ begin
+ if Ada_Version < Ada_2020 then
+ Error_Msg (Feature & " is an Ada 2020 feature", Loc);
+
+ if No (Ada_Version_Pragma) then
+ Error_Msg ("\unit must be compiled with -gnat2020 switch", Loc);
+ else
+ Error_Msg_Sloc := Sloc (Ada_Version_Pragma);
+ Error_Msg ("\incompatible with Ada version set#", Loc);
+ end if;
+ end if;
+ end Error_Msg_Ada_2020_Feature;
+
------------------
-- Error_Msg_AP --
------------------
@@ -1084,25 +1114,26 @@ package body Errout is
-- Here we build a new error object
Errors.Append
- ((Text => new String'(Msg_Buffer (1 .. Msglen)),
- Next => No_Error_Msg,
- Prev => No_Error_Msg,
- Sptr => Sptr,
- Optr => Optr,
- Sfile => Get_Source_File_Index (Sptr),
- Line => Get_Physical_Line_Number (Sptr),
- Col => Get_Column_Number (Sptr),
- Warn => Is_Warning_Msg,
- Info => Is_Info_Msg,
- Check => Is_Check_Msg,
- Warn_Err => False, -- reset below
- Warn_Chr => Warning_Msg_Char,
- Style => Is_Style_Msg,
- Serious => Is_Serious_Error,
- Uncond => Is_Unconditional_Msg,
- Msg_Cont => Continuation,
- Deleted => False,
- Node => Node));
+ ((Text => new String'(Msg_Buffer (1 .. Msglen)),
+ Next => No_Error_Msg,
+ Prev => No_Error_Msg,
+ Sptr => Sptr,
+ Optr => Optr,
+ Sfile => Get_Source_File_Index (Sptr),
+ Line => Get_Physical_Line_Number (Sptr),
+ Col => Get_Column_Number (Sptr),
+ Compile_Time_Pragma => Is_Compile_Time_Msg,
+ Warn => Is_Warning_Msg,
+ Info => Is_Info_Msg,
+ Check => Is_Check_Msg,
+ Warn_Err => False, -- reset below
+ Warn_Chr => Warning_Msg_Char,
+ Style => Is_Style_Msg,
+ Serious => Is_Serious_Error,
+ Uncond => Is_Unconditional_Msg,
+ Msg_Cont => Continuation,
+ Deleted => False,
+ Node => Node));
Cur_Msg := Errors.Last;
-- Test if warning to be treated as error
@@ -1857,30 +1888,77 @@ package body Errout is
Write_Str (" errors");
end if;
- if Warnings_Detected - Warning_Info_Messages /= 0 then
- Write_Str (", ");
- Write_Int (Warnings_Detected);
- Write_Str (" warning");
+ -- We now need to output warnings. When using -gnatwe, all warnings
+ -- should be treated as errors, except for warnings originating from
+ -- the use of the Compile_Time_Warning pragma. Another situation
+ -- where a warning might be treated as an error is when the source
+ -- code contains a Warning_As_Error pragma.
+ -- When warnings are treated as errors, we still log them as
+ -- warnings, but we add a message denoting how many of these warnings
+ -- are also errors.
- if Warnings_Detected - Warning_Info_Messages /= 1 then
- Write_Char ('s');
- end if;
+ declare
+ Warnings_Count : constant Int :=
+ Warnings_Detected - Warning_Info_Messages;
+
+ Compile_Time_Warnings : Int;
+ -- Number of warnings that come from a Compile_Time_Warning
+ -- pragma.
- if Warning_Mode = Treat_As_Error then
- Write_Str (" (treated as error");
+ Non_Compile_Time_Warnings : Int;
+ -- Number of warnings that do not come from a Compile_Time_Warning
+ -- pragmas.
- if Warnings_Detected /= 1 then
+ begin
+ if Warnings_Count > 0 then
+ Write_Str (", ");
+ Write_Int (Warnings_Count);
+ Write_Str (" warning");
+
+ if Warnings_Count > 1 then
Write_Char ('s');
end if;
- Write_Char (')');
+ Compile_Time_Warnings := Count_Compile_Time_Pragma_Warnings;
+ Non_Compile_Time_Warnings :=
+ Warnings_Count - Compile_Time_Warnings;
+
+ if Warning_Mode = Treat_As_Error
+ and then Non_Compile_Time_Warnings > 0
+ then
+ Write_Str (" (");
+
+ if Compile_Time_Warnings > 0 then
+ Write_Int (Non_Compile_Time_Warnings);
+ Write_Str (" ");
+ end if;
+
+ Write_Str ("treated as error");
+
+ if Non_Compile_Time_Warnings > 1 then
+ Write_Char ('s');
+ end if;
+
+ Write_Char (')');
+
+ elsif Warnings_Treated_As_Errors > 0 then
+ Write_Str (" (");
- elsif Warnings_Treated_As_Errors /= 0 then
- Write_Str (" (");
- Write_Int (Warnings_Treated_As_Errors);
- Write_Str (" treated as errors)");
+ if Warnings_Treated_As_Errors /= Warnings_Count then
+ Write_Int (Warnings_Treated_As_Errors);
+ Write_Str (" ");
+ end if;
+
+ Write_Str ("treated as error");
+
+ if Warnings_Treated_As_Errors > 1 then
+ Write_Str ("s");
+ end if;
+
+ Write_Str (")");
+ end if;
end if;
- end if;
+ end;
if Warning_Info_Messages + Report_Info_Messages /= 0 then
Write_Str (", ");
@@ -2195,9 +2273,15 @@ package body Errout is
-- must not be treated as errors when -gnatwe is in effect.
if Warning_Mode = Treat_As_Error then
- Total_Errors_Detected :=
- Total_Errors_Detected + Warnings_Detected - Warning_Info_Messages;
- Warnings_Detected := Warning_Info_Messages;
+ declare
+ Compile_Time_Pragma_Warnings : constant Int :=
+ Count_Compile_Time_Pragma_Warnings;
+ begin
+ Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected
+ - Warning_Info_Messages - Compile_Time_Pragma_Warnings;
+ Warnings_Detected :=
+ Warning_Info_Messages + Compile_Time_Pragma_Warnings;
+ end;
end if;
end Output_Messages;
@@ -3227,11 +3311,11 @@ package body Errout is
exit when Nkind (P) not in N_Subexpr;
end loop;
- if Nkind_In (P, N_Pragma_Argument_Association,
- N_Component_Association,
- N_Discriminant_Association,
- N_Generic_Association,
- N_Parameter_Association)
+ if Nkind (P) in N_Pragma_Argument_Association
+ | N_Component_Association
+ | N_Discriminant_Association
+ | N_Generic_Association
+ | N_Parameter_Association
then
Set_Error_Posted (Parent (P));
end if;
diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index 4cfb806..83a23cc 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -700,6 +700,14 @@ package Errout is
-- or the semantic analyzer. If N is set, points to the relevant node for
-- this message.
+ procedure Error_Msg
+ (Msg : String;
+ Flag_Location : Source_Ptr;
+ Is_Compile_Time_Pragma : Boolean);
+ -- Same as Error_Msg (String, Source_Ptr) except Is_Compile_Time_Pragma
+ -- lets the caller specify whether this is a Compile_Time_Warning or
+ -- Compile_Time_Error pragma.
+
procedure Error_Msg_S (Msg : String);
-- Output a message at current scan pointer location. This routine can be
-- called only from the parser, since it references Scan_Ptr.
@@ -887,12 +895,15 @@ package Errout is
-- first formal (RM 9.4(11.9/3)).
procedure Error_Msg_Ada_2012_Feature (Feature : String; Loc : Source_Ptr);
- -- If not operating in Ada 2012 mode, posts errors complaining that Feature
- -- is only supported in Ada 2012, with appropriate suggestions to fix this.
- -- Loc is the location at which the flag is to be posted. Feature, which
- -- appears at the start of the first generated message, may contain error
- -- message insertion characters in the normal manner, and in particular
- -- may start with | to flag a non-serious error.
+ -- If not operating in Ada 2012 mode or higher, posts errors complaining
+ -- that Feature is only supported in Ada 2012, with appropriate suggestions
+ -- to fix this. Loc is the location at which the flag is to be posted.
+ -- Feature, which appears at the start of the first generated message, may
+ -- contain error message insertion characters in the normal manner, and in
+ -- particular may start with | to flag a non-serious error.
+
+ procedure Error_Msg_Ada_2020_Feature (Feature : String; Loc : Source_Ptr);
+ -- Analogous to Error_Msg_Ada_2012_Feature
procedure dmsg (Id : Error_Msg_Id) renames Erroutc.dmsg;
-- Debugging routine to dump an error message
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index 3bab352..0c5d98c 100644
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -52,7 +52,7 @@ package body Erroutc is
-----------------------
function Matches (S : String; P : String) return Boolean;
- -- Returns true if the String S patches the pattern P, which can contain
+ -- Returns true if the String S matches the pattern P, which can contain
-- wildcard chars (*). The entire pattern must match the entire string.
-- Case is ignored in the comparison (so X matches x).
@@ -249,14 +249,48 @@ package body Erroutc is
------------------------
function Compilation_Errors return Boolean is
+ Warnings_Count : constant Int
+ := Warnings_Detected - Warning_Info_Messages;
begin
- return
- Total_Errors_Detected /= 0
- or else (Warnings_Detected - Warning_Info_Messages /= 0
- and then Warning_Mode = Treat_As_Error)
- or else Warnings_Treated_As_Errors /= 0;
+ if Total_Errors_Detected /= 0 then
+ return True;
+
+ elsif Warnings_Treated_As_Errors /= 0 then
+ return True;
+
+ -- We should never treat warnings that originate from a
+ -- Compile_Time_Warning pragma as an error. Warnings_Count is the sum
+ -- of both "normal" and Compile_Time_Warning warnings. This means that
+ -- there are only one or more non-Compile_Time_Warning warnings when
+ -- Warnings_Count is greater than Count_Compile_Time_Pragma_Warnings.
+
+ elsif Warning_Mode = Treat_As_Error
+ and then Warnings_Count > Count_Compile_Time_Pragma_Warnings
+ then
+ return True;
+ end if;
+
+ return False;
end Compilation_Errors;
+ ----------------------------------------
+ -- Count_Compile_Time_Pragma_Warnings --
+ ----------------------------------------
+
+ function Count_Compile_Time_Pragma_Warnings return Int is
+ Result : Int := 0;
+ begin
+ for J in 1 .. Errors.Last loop
+ begin
+ if Errors.Table (J).Warn and Errors.Table (J).Compile_Time_Pragma
+ then
+ Result := Result + 1;
+ end if;
+ end;
+ end loop;
+ return Result;
+ end Count_Compile_Time_Pragma_Warnings;
+
------------------
-- Debug_Output --
------------------
@@ -375,17 +409,17 @@ package body Erroutc is
if PPtr = PLast and then P (PPtr) = '*' then
return True;
- -- Return True if both pattern and string exhausted
+ -- Return True if both pattern and string exhausted
elsif PPtr > PLast and then SPtr > Slast then
return True;
- -- Return False, if one exhausted and not the other
+ -- Return False, if one exhausted and not the other
elsif PPtr > PLast or else SPtr > Slast then
return False;
- -- Case where pattern starts with asterisk
+ -- Case where pattern starts with asterisk
elsif P (PPtr) = '*' then
@@ -401,13 +435,13 @@ package body Erroutc is
return False;
- -- Dealt with end of string and *, advance if we have a match
+ -- Dealt with end of string and *, advance if we have a match
elsif Fold_Lower (S (SPtr)) = Fold_Lower (P (PPtr)) then
SPtr := SPtr + 1;
PPtr := PPtr + 1;
- -- If first characters do not match, that's decisive
+ -- If first characters do not match, that's decisive
else
return False;
diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads
index 3b34753..8472ee5 100644
--- a/gcc/ada/erroutc.ads
+++ b/gcc/ada/erroutc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -51,6 +51,10 @@ package Erroutc is
-- Set true to indicate that the current message contains the insertion
-- sequence !! (force warnings even in non-main unit source files).
+ Is_Compile_Time_Msg : Boolean := False;
+ -- Set true to indicate that the current message originates from a
+ -- Compile_Time_Warning or Compile_Time_Error pragma.
+
Is_Serious_Error : Boolean := False;
-- Set True for a serious error (i.e. any message that is not a warning
-- or style message, and that does not contain a | insertion character).
@@ -211,6 +215,10 @@ package Erroutc is
Col : Column_Number;
-- Column number for error message
+ Compile_Time_Pragma : Boolean;
+ -- True if the message originates from a Compile_Time_Warning or
+ -- Compile_Time_Error pragma
+
Warn : Boolean;
-- True if warning message
@@ -413,6 +421,10 @@ package Erroutc is
-- redundant. If so, the message to be deleted and all its continuations
-- are marked with the Deleted flag set to True.
+ function Count_Compile_Time_Pragma_Warnings return Int;
+ -- Returns the number of warnings in the Errors table that were triggered
+ -- by a Compile_Time_Warning pragma.
+
function Get_Warning_Tag (Id : Error_Msg_Id) return String;
-- Given an error message ID, return tag showing warning message class, or
-- the null string if this option is not enabled or this is not a warning.
diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb
index d84f3d3..75d29a9 100644
--- a/gcc/ada/errutil.adb
+++ b/gcc/ada/errutil.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -203,25 +203,26 @@ package body Errutil is
Errors.Append
(New_Val =>
- (Text => new String'(Msg_Buffer (1 .. Msglen)),
- Next => No_Error_Msg,
- Prev => No_Error_Msg,
- Sfile => Get_Source_File_Index (Sptr),
- Sptr => Sptr,
- Optr => Optr,
- Line => Get_Physical_Line_Number (Sptr),
- Col => Get_Column_Number (Sptr),
- Warn => Is_Warning_Msg,
- Info => Is_Info_Msg,
- Check => Is_Check_Msg,
- Warn_Err => Warning_Mode = Treat_As_Error,
- Warn_Chr => Warning_Msg_Char,
- Style => Is_Style_Msg,
- Serious => Is_Serious_Error,
- Uncond => Is_Unconditional_Msg,
- Msg_Cont => Continuation,
- Deleted => False,
- Node => Empty));
+ (Text => new String'(Msg_Buffer (1 .. Msglen)),
+ Next => No_Error_Msg,
+ Prev => No_Error_Msg,
+ Sfile => Get_Source_File_Index (Sptr),
+ Sptr => Sptr,
+ Optr => Optr,
+ Line => Get_Physical_Line_Number (Sptr),
+ Col => Get_Column_Number (Sptr),
+ Compile_Time_Pragma => Is_Compile_Time_Msg,
+ Warn => Is_Warning_Msg,
+ Info => Is_Info_Msg,
+ Check => Is_Check_Msg,
+ Warn_Err => Warning_Mode = Treat_As_Error,
+ Warn_Chr => Warning_Msg_Char,
+ Style => Is_Style_Msg,
+ Serious => Is_Serious_Error,
+ Uncond => Is_Unconditional_Msg,
+ Msg_Cont => Continuation,
+ Deleted => False,
+ Node => Empty));
Cur_Msg := Errors.Last;
Prev_Msg := No_Error_Msg;
diff --git a/gcc/ada/errutil.ads b/gcc/ada/errutil.ads
index f8b2fd8..56bd242 100644
--- a/gcc/ada/errutil.ads
+++ b/gcc/ada/errutil.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,8 +30,7 @@
-- Err_Vars. Like Errout, it also uses the common variables and routines
-- in package Erroutc.
--- This package is used by the preprocessor (gprep.adb) and the project
--- manager (prj-err.ads).
+-- This package is used by the preprocessor (gprep.adb).
with Styleg;
with Types; use Types;
diff --git a/gcc/ada/eval_fat.adb b/gcc/ada/eval_fat.adb
index b35ad3d..8160cba 100644
--- a/gcc/ada/eval_fat.adb
+++ b/gcc/ada/eval_fat.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/eval_fat.ads b/gcc/ada/eval_fat.ads
index ec73709..d83c035 100644
--- a/gcc/ada/eval_fat.ads
+++ b/gcc/ada/eval_fat.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exit.c b/gcc/ada/exit.c
index 3f6ef21..adf503e 100644
--- a/gcc/ada/exit.c
+++ b/gcc/ada/exit.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 60ad4d6..168a592 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@@ -52,7 +53,9 @@ with Sem; use Sem;
with Sem_Aggr; use Sem_Aggr;
with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
+with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
@@ -85,6 +88,12 @@ package body Exp_Aggr is
procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id);
procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id);
+ procedure Expand_Container_Aggregate (N : Node_Id);
+
+ function Get_Base_Object (N : Node_Id) return Entity_Id;
+ -- Return the base object, i.e. the outermost prefix object, that N refers
+ -- to statically, or Empty if it cannot be determined. The assumption is
+ -- that all dereferences are explicit in the tree rooted at N.
function Has_Default_Init_Comps (N : Node_Id) return Boolean;
-- N is an aggregate (record or array). Checks the presence of default
@@ -217,7 +226,9 @@ package body Exp_Aggr is
-- defaults. An aggregate for a type with mutable components must be
-- expanded into individual assignments.
- function In_Place_Assign_OK (N : Node_Id) return Boolean;
+ function In_Place_Assign_OK
+ (N : Node_Id;
+ Target_Object : Entity_Id := Empty) return Boolean;
-- Predicate to determine whether an aggregate assignment can be done in
-- place, because none of the new values can depend on the components of
-- the target of the assignment.
@@ -238,7 +249,10 @@ package body Exp_Aggr is
-- Local Subprograms for Array Aggregate Expansion --
-----------------------------------------------------
- function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean;
+ function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean;
+ -- Returns true if an aggregate assignment can be done by the back end
+
+ function Aggr_Size_OK (N : Node_Id) return Boolean;
-- Very large static aggregates present problems to the back-end, and are
-- transformed into assignments and loops. This function verifies that the
-- total number of components of an aggregate is acceptable for rewriting
@@ -289,19 +303,12 @@ package body Exp_Aggr is
-- construct the allocated object on the heap.
procedure Convert_To_Positional
- (N : Node_Id;
- Max_Others_Replicate : Nat := 32;
- Handle_Bit_Packed : Boolean := False);
+ (N : Node_Id;
+ Handle_Bit_Packed : Boolean := False);
-- If possible, convert named notation to positional notation. This
-- conversion is possible only in some static cases. If the conversion is
-- possible, then N is rewritten with the analyzed converted aggregate.
- -- The parameter Max_Others_Replicate controls the maximum number of
- -- values corresponding to an others choice that will be converted to
- -- positional notation (the default of 32 is the normal limit, and reflects
- -- the fact that normally the loop is better than a lot of separate
- -- assignments). Note that this limit gets overridden in any case if
- -- either of the restrictions No_Elaboration_Code or No_Implicit_Loops is
- -- set. The parameter Handle_Bit_Packed is usually set False (since we do
+ -- The parameter Handle_Bit_Packed is usually set False (since we do
-- not expect the back end to handle bit packed arrays, so the normal case
-- of conversion is pointless), but in the special case of a call from
-- Packed_Array_Aggregate_Handled, we set this parameter to True, since
@@ -320,6 +327,12 @@ package body Exp_Aggr is
-- an array that is suitable for this optimization: it returns True if Typ
-- is a two dimensional bit packed array with component size 1, 2, or 4.
+ function Max_Aggregate_Size
+ (N : Node_Id;
+ Default_Size : Nat := 5000) return Nat;
+ -- Return the max size for a static aggregate N. Return Default_Size if no
+ -- other special criteria trigger.
+
function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
-- Given an array aggregate, this function handles the case of a packed
-- array aggregate with all constant values, where the aggregate can be
@@ -336,11 +349,252 @@ package body Exp_Aggr is
-- false if this transformation cannot be performed. THis is similar to,
-- and reuses part of the machinery in Packed_Array_Aggregate_Handled.
+ ------------------------------------
+ -- Aggr_Assignment_OK_For_Backend --
+ ------------------------------------
+
+ -- Back-end processing by Gigi/gcc is possible only if all the following
+ -- conditions are met:
+
+ -- 1. N consists of a single OTHERS choice, possibly recursively, or
+ -- of a single choice, possibly recursively, if it is surrounded by
+ -- a qualified expression whose subtype mark is unconstrained.
+
+ -- 2. The array type has no null ranges (the purpose of this is to
+ -- avoid a bogus warning for an out-of-range value).
+
+ -- 3. The array type has no atomic components
+
+ -- 4. The component type is elementary
+
+ -- 5. The component size is a multiple of Storage_Unit
+
+ -- 6. The component size is Storage_Unit or the value is of the form
+ -- M * (1 + A**1 + A**2 + .. A**(K-1)) where A = 2**(Storage_Unit)
+ -- and M in 0 .. A-1. This can also be viewed as K occurrences of
+ -- the Storage_Unit value M, concatenated together.
+
+ -- The ultimate goal is to generate a call to a fast memset routine
+ -- specifically optimized for the target.
+
+ function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean is
+ Csiz : Uint := No_Uint;
+ Ctyp : Entity_Id;
+ Expr : Node_Id;
+ High : Node_Id;
+ Index : Entity_Id;
+ Low : Node_Id;
+ Nunits : Int;
+ Remainder : Uint;
+ Value : Uint;
+
+ function Is_OK_Aggregate (Aggr : Node_Id) return Boolean;
+ -- Return true if Aggr is suitable for back-end assignment
+
+ ---------------------
+ -- Is_OK_Aggregate --
+ ---------------------
+
+ function Is_OK_Aggregate (Aggr : Node_Id) return Boolean is
+ Assoc : constant List_Id := Component_Associations (Aggr);
+
+ begin
+ -- An "others" aggregate is most likely OK, but see below
+
+ if Is_Others_Aggregate (Aggr) then
+ null;
+
+ -- An aggregate with a single choice requires a qualified expression
+ -- whose subtype mark is an unconstrained type because we need it to
+ -- have the semantics of an "others" aggregate.
+
+ elsif Nkind (Parent (N)) = N_Qualified_Expression
+ and then not Is_Constrained (Entity (Subtype_Mark (Parent (N))))
+ and then Is_Single_Aggregate (Aggr)
+ then
+ null;
+
+ -- The other cases are not OK
+
+ else
+ return False;
+ end if;
+
+ -- In any case we do not support an iterated association
+
+ return Nkind (First (Assoc)) /= N_Iterated_Component_Association;
+ end Is_OK_Aggregate;
+
+ begin
+ -- Back end doesn't know about <>
+
+ if Has_Default_Init_Comps (N) then
+ return False;
+ end if;
+
+ -- Recurse as far as possible to find the innermost component type
+
+ Ctyp := Etype (N);
+ Expr := N;
+ while Is_Array_Type (Ctyp) loop
+ if Nkind (Expr) /= N_Aggregate
+ or else not Is_OK_Aggregate (Expr)
+ then
+ return False;
+ end if;
+
+ Index := First_Index (Ctyp);
+ while Present (Index) loop
+ Get_Index_Bounds (Index, Low, High);
+
+ if Is_Null_Range (Low, High) then
+ return False;
+ end if;
+
+ Next_Index (Index);
+ end loop;
+
+ Expr := Expression (First (Component_Associations (Expr)));
+
+ for J in 1 .. Number_Dimensions (Ctyp) - 1 loop
+ if Nkind (Expr) /= N_Aggregate
+ or else not Is_OK_Aggregate (Expr)
+ then
+ return False;
+ end if;
+
+ Expr := Expression (First (Component_Associations (Expr)));
+ end loop;
+
+ if Has_Atomic_Components (Ctyp) then
+ return False;
+ end if;
+
+ Csiz := Component_Size (Ctyp);
+ Ctyp := Component_Type (Ctyp);
+
+ if Is_Atomic_Or_VFA (Ctyp) then
+ return False;
+ end if;
+ end loop;
+
+ -- Access types need to be dealt with specially
+
+ if Is_Access_Type (Ctyp) then
+
+ -- Component_Size is not set by Layout_Type if the component
+ -- type is an access type ???
+
+ Csiz := Esize (Ctyp);
+
+ -- Fat pointers are rejected as they are not really elementary
+ -- for the backend.
+
+ if Csiz /= System_Address_Size then
+ return False;
+ end if;
+
+ -- The supported expressions are NULL and constants, others are
+ -- rejected upfront to avoid being analyzed below, which can be
+ -- problematic for some of them, for example allocators.
+
+ if Nkind (Expr) /= N_Null and then not Is_Entity_Name (Expr) then
+ return False;
+ end if;
+
+ -- Scalar types are OK if their size is a multiple of Storage_Unit
+
+ elsif Is_Scalar_Type (Ctyp) then
+ pragma Assert (Csiz /= No_Uint);
+
+ if Csiz mod System_Storage_Unit /= 0 then
+ return False;
+ end if;
+
+ -- Composite types are rejected
+
+ else
+ return False;
+ end if;
+
+ -- If the expression has side effects (e.g. contains calls with
+ -- potential side effects) reject as well. We only preanalyze the
+ -- expression to prevent the removal of intended side effects.
+
+ Preanalyze_And_Resolve (Expr, Ctyp);
+
+ if not Side_Effect_Free (Expr) then
+ return False;
+ end if;
+
+ -- The expression needs to be analyzed if True is returned
+
+ Analyze_And_Resolve (Expr, Ctyp);
+
+ -- Strip away any conversions from the expression as they simply
+ -- qualify the real expression.
+
+ while Nkind (Expr) in N_Unchecked_Type_Conversion | N_Type_Conversion
+ loop
+ Expr := Expression (Expr);
+ end loop;
+
+ Nunits := UI_To_Int (Csiz) / System_Storage_Unit;
+
+ if Nunits = 1 then
+ return True;
+ end if;
+
+ if not Compile_Time_Known_Value (Expr) then
+ return False;
+ end if;
+
+ -- The only supported value for floating point is 0.0
+
+ if Is_Floating_Point_Type (Ctyp) then
+ return Expr_Value_R (Expr) = Ureal_0;
+ end if;
+
+ -- For other types, we can look into the value as an integer, which
+ -- means the representation value for enumeration literals.
+
+ Value := Expr_Rep_Value (Expr);
+
+ if Has_Biased_Representation (Ctyp) then
+ Value := Value - Expr_Value (Type_Low_Bound (Ctyp));
+ end if;
+
+ -- Values 0 and -1 immediately satisfy the last check
+
+ if Value = Uint_0 or else Value = Uint_Minus_1 then
+ return True;
+ end if;
+
+ -- We need to work with an unsigned value
+
+ if Value < 0 then
+ Value := Value + 2**(System_Storage_Unit * Nunits);
+ end if;
+
+ Remainder := Value rem 2**System_Storage_Unit;
+
+ for J in 1 .. Nunits - 1 loop
+ Value := Value / 2**System_Storage_Unit;
+
+ if Value rem 2**System_Storage_Unit /= Remainder then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end Aggr_Assignment_OK_For_Backend;
+
------------------
-- Aggr_Size_OK --
------------------
- function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean is
+ function Aggr_Size_OK (N : Node_Id) return Boolean is
+ Typ : constant Entity_Id := Etype (N);
Lo : Node_Id;
Hi : Node_Id;
Indx : Node_Id;
@@ -429,43 +683,15 @@ package body Exp_Aggr is
-- Start of processing for Aggr_Size_OK
begin
- -- The normal aggregate limit is 500000, but we increase this limit to
- -- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code) or
- -- Restrictions (No_Implicit_Loops) is specified, since in either case
- -- we are at risk of declaring the program illegal because of this
- -- limit. We also increase the limit when Static_Elaboration_Desired,
- -- given that this means that objects are intended to be placed in data
- -- memory.
-
- -- We also increase the limit if the aggregate is for a packed two-
- -- dimensional array, because if components are static it is much more
- -- efficient to construct a one-dimensional equivalent array with static
- -- components.
-
- -- Conversely, we decrease the maximum size if none of the above
- -- requirements apply, and if the aggregate has a single component
+ -- We bump the maximum size unless the aggregate has a single component
-- association, which will be more efficient if implemented with a loop.
- -- Finally, we use a small limit in CodePeer mode where we favor loops
- -- instead of thousands of single assignments (from large aggregates).
-
- Max_Aggr_Size := 500000;
-
- if CodePeer_Mode then
- Max_Aggr_Size := 100;
-
- elsif Restriction_Active (No_Elaboration_Code)
- or else Restriction_Active (No_Implicit_Loops)
- or else Is_Two_Dim_Packed_Array (Typ)
- or else (Ekind (Current_Scope) = E_Package
- and then Static_Elaboration_Desired (Current_Scope))
- then
- Max_Aggr_Size := 2 ** 24;
-
- elsif No (Expressions (N))
+ if No (Expressions (N))
and then No (Next (First (Component_Associations (N))))
then
- Max_Aggr_Size := 5000;
+ Max_Aggr_Size := Max_Aggregate_Size (N);
+ else
+ Max_Aggr_Size := Max_Aggregate_Size (N, 500_000);
end if;
Size := UI_From_Int (Component_Count (Component_Type (Typ)));
@@ -629,8 +855,8 @@ package body Exp_Aggr is
Expr : Node_Id := Original_Node (N);
begin
- while Nkind_In (Expr, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ while Nkind (Expr) in
+ N_Type_Conversion | N_Unchecked_Type_Conversion
loop
Expr := Original_Node (Expression (Expr));
end loop;
@@ -772,7 +998,6 @@ package body Exp_Aggr is
-- Backend processing is possible
- Set_Size_Known_At_Compile_Time (Etype (N), True);
return True;
end Backend_Processing_Possible;
@@ -1329,9 +1554,9 @@ package body Exp_Aggr is
-- the initialization expression denotes. An unanalyzed function
-- call may appear as an identifier or an indexed component.
- if Nkind_In (Expr, N_Function_Call,
- N_Identifier,
- N_Indexed_Component)
+ if Nkind (Expr) in N_Function_Call
+ | N_Identifier
+ | N_Indexed_Component
and then not Analyzed (Expr)
then
Preanalyze_And_Resolve (Expr, Comp_Typ);
@@ -1512,7 +1737,7 @@ package body Exp_Aggr is
-- default initialized components (otherwise Expr_Q is not present).
if Present (Expr_Q)
- and then Nkind_In (Expr_Q, N_Aggregate, N_Extension_Aggregate)
+ and then Nkind (Expr_Q) in N_Aggregate | N_Extension_Aggregate
then
-- At this stage the Expression may not have been analyzed yet
-- because the array aggregate code has not been updated to use
@@ -2043,12 +2268,15 @@ package body Exp_Aggr is
and then Is_Bit_Packed_Array (Typ)
and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ))
then
- Append_To (New_Code,
- Make_Assignment_Statement (Loc,
- Name => New_Copy_Tree (Into),
- Expression =>
- Unchecked_Convert_To (Typ,
- Make_Integer_Literal (Loc, Uint_0))));
+ declare
+ Zero : constant Node_Id := Make_Integer_Literal (Loc, Uint_0);
+ begin
+ Analyze_And_Resolve (Zero, Packed_Array_Impl_Type (Typ));
+ Append_To (New_Code,
+ Make_Assignment_Statement (Loc,
+ Name => New_Copy_Tree (Into),
+ Expression => Unchecked_Convert_To (Typ, Zero)));
+ end;
end if;
-- If the component type contains tasks, we need to build a Master
@@ -2836,9 +3064,9 @@ package body Exp_Aggr is
-- the initialization expression denotes. Unanalyzed function calls
-- may appear as identifiers or indexed components.
- if Nkind_In (Init_Expr, N_Function_Call,
- N_Identifier,
- N_Indexed_Component)
+ if Nkind (Init_Expr) in N_Function_Call
+ | N_Identifier
+ | N_Indexed_Component
and then not Analyzed (Init_Expr)
then
Preanalyze_And_Resolve (Init_Expr, Comp_Typ);
@@ -3262,8 +3490,8 @@ package body Exp_Aggr is
-- qualified).
elsif Is_Limited_Type (Etype (Ancestor))
- and then Nkind_In (Unqualify (Ancestor), N_Aggregate,
- N_Extension_Aggregate)
+ and then Nkind (Unqualify (Ancestor)) in
+ N_Aggregate | N_Extension_Aggregate
then
Ancestor_Is_Expression := True;
@@ -3295,8 +3523,8 @@ package body Exp_Aggr is
-- If the ancestor part is an aggregate, force its full
-- expansion, which was delayed.
- if Nkind_In (Unqualify (Ancestor), N_Aggregate,
- N_Extension_Aggregate)
+ if Nkind (Unqualify (Ancestor)) in
+ N_Aggregate | N_Extension_Aggregate
then
Set_Analyzed (Ancestor, False);
Set_Analyzed (Expression (Ancestor), False);
@@ -4126,21 +4354,41 @@ package body Exp_Aggr is
Aggr : Node_Id;
Target : Node_Id)
is
- Aggr_Code : List_Id;
Typ : constant Entity_Id := Etype (Aggr);
Ctyp : constant Entity_Id := Component_Type (Typ);
+ Aggr_Code : List_Id;
+ New_Aggr : Node_Id;
begin
- -- The target is an explicit dereference of the allocated object.
- -- Generate component assignments to it, as for an aggregate that
- -- appears on the right-hand side of an assignment statement.
+ -- The target is an explicit dereference of the allocated object
- Aggr_Code :=
- Build_Array_Aggr_Code (Aggr,
- Ctype => Ctyp,
- Index => First_Index (Typ),
- Into => Target,
- Scalar_Comp => Is_Scalar_Type (Ctyp));
+ -- If the assignment can be done directly by the back end, then
+ -- reset Set_Expansion_Delayed and do not expand further.
+
+ if not CodePeer_Mode
+ and then not Modify_Tree_For_C
+ and then Aggr_Assignment_OK_For_Backend (Aggr)
+ then
+ New_Aggr := New_Copy_Tree (Aggr);
+ Set_Expansion_Delayed (New_Aggr, False);
+
+ Aggr_Code :=
+ New_List (
+ Make_OK_Assignment_Statement (Sloc (New_Aggr),
+ Name => Target,
+ Expression => New_Aggr));
+
+ -- Or else, generate component assignments to it, as for an aggregate
+ -- that appears on the right-hand side of an assignment statement.
+
+ else
+ Aggr_Code :=
+ Build_Array_Aggr_Code (Aggr,
+ Ctype => Ctyp,
+ Index => First_Index (Typ),
+ Into => Target,
+ Scalar_Comp => Is_Scalar_Type (Ctyp));
+ end if;
Insert_Actions_After (Decl, Aggr_Code);
end Convert_Array_Aggr_In_Allocator;
@@ -4149,23 +4397,40 @@ package body Exp_Aggr is
-- In_Place_Assign_OK --
------------------------
- function In_Place_Assign_OK (N : Node_Id) return Boolean is
+ function In_Place_Assign_OK
+ (N : Node_Id;
+ Target_Object : Entity_Id := Empty) return Boolean
+ is
Is_Array : constant Boolean := Is_Array_Type (Etype (N));
- Aggr_In : Node_Id;
- Aggr_Lo : Node_Id;
- Aggr_Hi : Node_Id;
- Obj_In : Node_Id;
- Obj_Lo : Node_Id;
- Obj_Hi : Node_Id;
+ Aggr_In : Node_Id;
+ Aggr_Lo : Node_Id;
+ Aggr_Hi : Node_Id;
+ Obj_In : Node_Id;
+ Obj_Lo : Node_Id;
+ Obj_Hi : Node_Id;
+ Parent_Kind : Node_Kind;
+ Parent_Node : Node_Id;
function Safe_Aggregate (Aggr : Node_Id) return Boolean;
-- Check recursively that each component of a (sub)aggregate does not
-- depend on the variable being assigned to.
function Safe_Component (Expr : Node_Id) return Boolean;
- -- Verify that an expression cannot depend on the variable being
- -- assigned to. Room for improvement here (but less than before).
+ -- Verify that an expression cannot depend on the target being assigned
+ -- to. Return true for compile-time known values, stand-alone objects,
+ -- parameters passed by copy, calls to functions that return by copy,
+ -- selected components thereof only if the aggregate's type is an array,
+ -- indexed components and slices thereof only if the aggregate's type is
+ -- a record, and simple expressions involving only these as operands.
+ -- This is OK whatever the target because, for a component to overlap
+ -- with the target, it must be either a direct reference to a component
+ -- of the target, in which case there must be a matching selection or
+ -- indexation or slicing, or an indirect reference to such a component,
+ -- which is excluded by the above condition. Additionally, if the target
+ -- is statically known, return true for arbitrarily nested selections,
+ -- indexations or slicings, provided that their ultimate prefix is not
+ -- the target itself.
--------------------
-- Safe_Aggregate --
@@ -4227,43 +4492,137 @@ package body Exp_Aggr is
function Safe_Component (Expr : Node_Id) return Boolean is
Comp : Node_Id := Expr;
- function Check_Component (Comp : Node_Id) return Boolean;
- -- Do the recursive traversal, after copy
+ function Check_Component (C : Node_Id; T_OK : Boolean) return Boolean;
+ -- Do the recursive traversal, after copy. If T_OK is True, return
+ -- True for a stand-alone object only if the target is statically
+ -- known and distinct from the object. At the top level, we start
+ -- with T_OK set to False and set it to True at a deeper level only
+ -- if we cannot disambiguate the component here without statically
+ -- knowing the target. Note that this is not optimal, we should do
+ -- something along the lines of Denotes_Same_Prefix for that.
---------------------
-- Check_Component --
---------------------
- function Check_Component (Comp : Node_Id) return Boolean is
+ function Check_Component (C : Node_Id; T_OK : Boolean) return Boolean
+ is
+
+ function SDO (E : Entity_Id) return Uint;
+ -- Return the Scope Depth Of the enclosing dynamic scope of E
+
+ ---------
+ -- SDO --
+ ---------
+
+ function SDO (E : Entity_Id) return Uint is
+ begin
+ return Scope_Depth (Enclosing_Dynamic_Scope (E));
+ end SDO;
+
+ -- Start of processing for Check_Component
+
begin
- if Is_Overloaded (Comp) then
+ if Is_Overloaded (C) then
return False;
+
+ elsif Compile_Time_Known_Value (C) then
+ return True;
end if;
- return Compile_Time_Known_Value (Comp)
+ case Nkind (C) is
+ when N_Attribute_Reference =>
+ return Check_Component (Prefix (C), T_OK);
+
+ when N_Function_Call =>
+ if Nkind (Name (C)) = N_Explicit_Dereference then
+ return not Returns_By_Ref (Etype (Name (C)));
+ else
+ return not Returns_By_Ref (Entity (Name (C)));
+ end if;
+
+ when N_Indexed_Component | N_Slice =>
+ -- In a target record, these operations cannot determine
+ -- alone a component so we can recurse whatever the target.
+ return Check_Component (Prefix (C), T_OK or else Is_Array);
+
+ when N_Selected_Component =>
+ -- In a target array, this operation cannot determine alone
+ -- a component so we can recurse whatever the target.
+ return
+ Check_Component (Prefix (C), T_OK or else not Is_Array);
+
+ when N_Type_Conversion | N_Unchecked_Type_Conversion =>
+ return Check_Component (Expression (C), T_OK);
+
+ when N_Binary_Op =>
+ return Check_Component (Left_Opnd (C), T_OK)
+ and then Check_Component (Right_Opnd (C), T_OK);
+
+ when N_Unary_Op =>
+ return Check_Component (Right_Opnd (C), T_OK);
+
+ when others =>
+ if Is_Entity_Name (C) and then Is_Object (Entity (C)) then
+ -- Case of a formal parameter component. It's either
+ -- trivial if passed by copy or very annoying if not,
+ -- because in the latter case it's almost equivalent
+ -- to a dereference, so the path-based disambiguation
+ -- logic is totally off and we always need the target.
+
+ if Is_Formal (Entity (C)) then
+
+ -- If it is passed by copy, then this is safe
+
+ if Mechanism (Entity (C)) = By_Copy then
+ return True;
+
+ -- Otherwise, this is safe if the target is present
+ -- and is at least as deeply nested as the component.
+
+ else
+ return Present (Target_Object)
+ and then not Is_Formal (Target_Object)
+ and then SDO (Target_Object) >= SDO (Entity (C));
+ end if;
+
+ -- For a renamed object, recurse
+
+ elsif Present (Renamed_Object (Entity (C))) then
+ return
+ Check_Component (Renamed_Object (Entity (C)), T_OK);
+
+ -- If this is safe whatever the target, we are done
+
+ elsif not T_OK then
+ return True;
+
+ -- If there is no target or the component is the target,
+ -- this is not safe.
+
+ elsif No (Target_Object)
+ or else Entity (C) = Target_Object
+ then
+ return False;
- or else (Is_Entity_Name (Comp)
- and then Present (Entity (Comp))
- and then Ekind (Entity (Comp)) not in Type_Kind
- and then No (Renamed_Object (Entity (Comp))))
+ -- Case of a formal parameter target. This is safe if it
+ -- is at most as deeply nested as the component.
- or else (Nkind (Comp) = N_Attribute_Reference
- and then Check_Component (Prefix (Comp)))
+ elsif Is_Formal (Target_Object) then
+ return SDO (Target_Object) <= SDO (Entity (C));
- or else (Nkind (Comp) in N_Binary_Op
- and then Check_Component (Left_Opnd (Comp))
- and then Check_Component (Right_Opnd (Comp)))
+ -- For distinct stand-alone objects, this is safe
- or else (Nkind (Comp) in N_Unary_Op
- and then Check_Component (Right_Opnd (Comp)))
+ else
+ return True;
+ end if;
- or else (Nkind (Comp) = N_Selected_Component
- and then Is_Array
- and then Check_Component (Prefix (Comp)))
+ -- For anything else than an object, this is not safe
- or else (Nkind_In (Comp, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
- and then Check_Component (Expression (Comp)));
+ else
+ return False;
+ end if;
+ end case;
end Check_Component;
-- Start of processing for Safe_Component
@@ -4280,11 +4639,6 @@ package body Exp_Aggr is
if Is_Overloaded (Expr) then
return False;
- elsif Nkind (Expr) = N_Aggregate
- and then not Is_Others_Aggregate (Expr)
- then
- return False;
-
elsif Nkind (Expr) = N_Allocator then
-- For now, too complex to analyze
@@ -4307,57 +4661,73 @@ package body Exp_Aggr is
if Nkind (Comp) = N_Aggregate then
return Safe_Aggregate (Comp);
else
- return Check_Component (Comp);
+ return Check_Component (Comp, False);
end if;
end Safe_Component;
-- Start of processing for In_Place_Assign_OK
begin
- -- By-copy semantic cannot be guaranteed for controlled objects or
- -- objects with discriminants.
+ -- By-copy semantic cannot be guaranteed for controlled objects
- if Needs_Finalization (Etype (N))
- or else Has_Discriminants (Etype (N))
- then
+ if Needs_Finalization (Etype (N)) then
return False;
+ end if;
- elsif Is_Array and then Present (Component_Associations (N)) then
+ Parent_Node := Parent (N);
+ Parent_Kind := Nkind (Parent_Node);
- -- On assignment, sliding can take place, so we cannot do the
- -- assignment in place unless the bounds of the aggregate are
- -- statically equal to those of the target.
+ if Parent_Kind = N_Qualified_Expression then
+ Parent_Node := Parent (Parent_Node);
+ Parent_Kind := Nkind (Parent_Node);
+ end if;
- -- If the aggregate is given by an others choice, the bounds are
- -- derived from the left-hand side, and the assignment is safe if
- -- the expression is.
+ -- On assignment, sliding can take place, so we cannot do the
+ -- assignment in place unless the bounds of the aggregate are
+ -- statically equal to those of the target.
- if Is_Others_Aggregate (N) then
- return
- Safe_Component
- (Expression (First (Component_Associations (N))));
- end if;
+ -- If the aggregate is given by an others choice, the bounds are
+ -- derived from the left-hand side, and the assignment is safe if
+ -- the expression is.
+ if Is_Array
+ and then Present (Component_Associations (N))
+ and then not Is_Others_Aggregate (N)
+ then
Aggr_In := First_Index (Etype (N));
- if Nkind (Parent (N)) = N_Assignment_Statement then
- Obj_In := First_Index (Etype (Name (Parent (N))));
+ -- Context is an assignment
- else
- -- Context is an allocator. Check bounds of aggregate against
- -- given type in qualified expression.
+ if Parent_Kind = N_Assignment_Statement then
+ Obj_In := First_Index (Etype (Name (Parent_Node)));
+
+ -- Context is an allocator. Check the bounds of the aggregate against
+ -- those of the designated type, except in the case where the type is
+ -- unconstrained (and then we can directly return true, see below).
+
+ else pragma Assert (Parent_Kind = N_Allocator);
+ declare
+ Desig_Typ : constant Entity_Id :=
+ Designated_Type (Etype (Parent_Node));
+ begin
+ if not Is_Constrained (Desig_Typ) then
+ return True;
+ end if;
- pragma Assert (Nkind (Parent (Parent (N))) = N_Allocator);
- Obj_In := First_Index (Etype (Entity (Subtype_Mark (Parent (N)))));
+ Obj_In := First_Index (Desig_Typ);
+ end;
end if;
while Present (Aggr_In) loop
Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi);
Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi);
- if not Compile_Time_Known_Value (Aggr_Lo)
- or else not Compile_Time_Known_Value (Obj_Lo)
+ -- We require static bounds for the target and a static matching
+ -- of low bound for the aggregate.
+
+ if not Compile_Time_Known_Value (Obj_Lo)
or else not Compile_Time_Known_Value (Obj_Hi)
+ or else not Compile_Time_Known_Value (Aggr_Lo)
or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo)
then
return False;
@@ -4371,8 +4741,8 @@ package body Exp_Aggr is
-- diminishing returns) for safely building arrays in place
-- here.
- elsif Nkind (Parent (N)) = N_Assignment_Statement
- or else Is_Constrained (Etype (Parent (N)))
+ elsif Parent_Kind = N_Assignment_Statement
+ or else Is_Constrained (Etype (Parent_Node))
then
if not Compile_Time_Known_Value (Aggr_Hi)
or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
@@ -4386,9 +4756,14 @@ package body Exp_Aggr is
end loop;
end if;
- -- Now check the component values themselves
+ -- Now check the component values themselves, except for an allocator
+ -- for which the target is newly allocated memory.
- return Safe_Aggregate (N);
+ if Parent_Kind = N_Allocator then
+ return True;
+ else
+ return Safe_Aggregate (N);
+ end if;
end In_Place_Assign_OK;
----------------------------
@@ -4408,7 +4783,7 @@ package body Exp_Aggr is
Parent_Node : Node_Id;
begin
- pragma Assert (Nkind_In (N, N_Aggregate, N_Extension_Aggregate));
+ pragma Assert (Nkind (N) in N_Aggregate | N_Extension_Aggregate);
pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N));
pragma Assert (Is_Record_Type (Typ));
@@ -4496,26 +4871,39 @@ package body Exp_Aggr is
-- assignment.
if Is_Limited_Type (Typ)
- and then Nkind (Parent (N)) = N_Assignment_Statement
+ and then Parent_Kind = N_Assignment_Statement
then
- Target_Expr := New_Copy_Tree (Name (Parent (N)));
- Insert_Actions (Parent (N),
+ Target_Expr := New_Copy_Tree (Name (Parent_Node));
+ Insert_Actions (Parent_Node,
Build_Record_Aggr_Code (N, Typ, Target_Expr));
- Rewrite (Parent (N), Make_Null_Statement (Loc));
+ Rewrite (Parent_Node, Make_Null_Statement (Loc));
- -- Do not declare a temporary to initialize an aggregate assigned to an
- -- identifier when in-place assignment is possible, preserving the
+ -- Do not declare a temporary to initialize an aggregate assigned to
+ -- a target when in-place assignment is possible, i.e. preserving the
-- by-copy semantic of aggregates. This avoids large stack usage and
-- generates more efficient code.
- elsif Nkind (Parent (N)) = N_Assignment_Statement
- and then Nkind (Name (Parent (N))) = N_Identifier
- and then In_Place_Assign_OK (N)
+ elsif Parent_Kind = N_Assignment_Statement
+ and then In_Place_Assign_OK (N, Get_Base_Object (Name (Parent_Node)))
then
- Target_Expr := New_Copy_Tree (Name (Parent (N)));
- Insert_Actions (Parent (N),
- Build_Record_Aggr_Code (N, Typ, Target_Expr));
- Rewrite (Parent (N), Make_Null_Statement (Loc));
+ declare
+ Lhs : constant Node_Id := Name (Parent_Node);
+ begin
+ -- Apply discriminant check if required
+
+ if Has_Discriminants (Etype (N)) then
+ Apply_Discriminant_Check (N, Etype (Lhs), Lhs);
+ end if;
+
+ -- The check just above may have replaced the aggregate with a CE
+
+ if Nkind (N) in N_Aggregate | N_Extension_Aggregate then
+ Target_Expr := New_Copy_Tree (Lhs);
+ Insert_Actions (Parent_Node,
+ Build_Record_Aggr_Code (N, Typ, Target_Expr));
+ Rewrite (Parent_Node, Make_Null_Statement (Loc));
+ end if;
+ end;
else
Temp := Make_Temporary (Loc, 'A', N);
@@ -4563,11 +4951,12 @@ package body Exp_Aggr is
---------------------------
procedure Convert_To_Positional
- (N : Node_Id;
- Max_Others_Replicate : Nat := 32;
- Handle_Bit_Packed : Boolean := False)
+ (N : Node_Id;
+ Handle_Bit_Packed : Boolean := False)
is
- Typ : constant Entity_Id := Etype (N);
+ Typ : constant Entity_Id := Etype (N);
+ Dims : constant Nat := Number_Dimensions (Typ);
+ Max_Others_Replicate : constant Nat := Max_Aggregate_Size (N);
Static_Components : Boolean := True;
@@ -4577,18 +4966,18 @@ package body Exp_Aggr is
-- expansion.
function Flatten
- (N : Node_Id;
- Ix : Node_Id;
- Ixb : Node_Id) return Boolean;
- -- Convert the aggregate into a purely positional form if possible. On
- -- entry the bounds of all dimensions are known to be static, and the
- -- total number of components is safe enough to expand.
-
- function Is_Flat (N : Node_Id; Dims : Int) return Boolean;
- -- Return True iff the array N is flat (which is not trivial in the case
- -- of multidimensional aggregates).
-
- function Is_Static_Element (N : Node_Id) return Boolean;
+ (N : Node_Id;
+ Dims : Nat;
+ Ix : Node_Id;
+ Ixb : Node_Id) return Boolean;
+ -- Convert the aggregate into a purely positional form if possible after
+ -- checking that the bounds of all dimensions are known to be static.
+
+ function Is_Flat (N : Node_Id; Dims : Nat) return Boolean;
+ -- Return True if the aggregate N is flat (which is not trivial in the
+ -- case of multidimensional aggregates).
+
+ function Is_Static_Element (N : Node_Id; Dims : Nat) return Boolean;
-- Return True if N, an element of a component association list, i.e.
-- N_Component_Association or N_Iterated_Component_Association, has a
-- compile-time known value and can be passed as is to the back-end
@@ -4632,7 +5021,7 @@ package body Exp_Aggr is
then
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
- if not Is_Static_Element (Assoc) then
+ if not Is_Static_Element (Assoc, Dims) then
Static_Components := False;
exit;
end if;
@@ -4647,18 +5036,39 @@ package body Exp_Aggr is
-------------
function Flatten
- (N : Node_Id;
- Ix : Node_Id;
- Ixb : Node_Id) return Boolean
+ (N : Node_Id;
+ Dims : Nat;
+ Ix : Node_Id;
+ Ixb : Node_Id) return Boolean
is
Loc : constant Source_Ptr := Sloc (N);
Blo : constant Node_Id := Type_Low_Bound (Etype (Ixb));
Lo : constant Node_Id := Type_Low_Bound (Etype (Ix));
Hi : constant Node_Id := Type_High_Bound (Etype (Ix));
- Lov : Uint;
- Hiv : Uint;
- Others_Present : Boolean := False;
+ function Cannot_Flatten_Next_Aggr (Expr : Node_Id) return Boolean;
+ -- Return true if Expr is an aggregate for the next dimension that
+ -- cannot be recursively flattened.
+
+ ------------------------------
+ -- Cannot_Flatten_Next_Aggr --
+ ------------------------------
+
+ function Cannot_Flatten_Next_Aggr (Expr : Node_Id) return Boolean is
+ begin
+ return Nkind (Expr) = N_Aggregate
+ and then Present (Next_Index (Ix))
+ and then not
+ Flatten (Expr, Dims - 1, Next_Index (Ix), Next_Index (Ixb));
+ end Cannot_Flatten_Next_Aggr;
+
+ -- Local variables
+
+ Lov : Uint;
+ Hiv : Uint;
+ Others_Present : Boolean;
+
+ -- Start of processing for Flatten
begin
if Nkind (Original_Node (N)) = N_String_Literal then
@@ -4676,6 +5086,8 @@ package body Exp_Aggr is
-- Check if there is an others choice
+ Others_Present := False;
+
if Present (Component_Associations (N)) then
declare
Assoc : Node_Id;
@@ -4736,6 +5148,7 @@ package body Exp_Aggr is
-- Used to validate Max_Others_Replicate limit
Elmt : Node_Id;
+ Expr : Node_Id;
Num : Int := UI_To_Int (Lov);
Choice_Index : Int;
Choice : Node_Id;
@@ -4745,11 +5158,10 @@ package body Exp_Aggr is
if Present (Expressions (N)) then
Elmt := First (Expressions (N));
while Present (Elmt) loop
- if Nkind (Elmt) = N_Aggregate
- and then Present (Next_Index (Ix))
- and then
- not Flatten (Elmt, Next_Index (Ix), Next_Index (Ixb))
- then
+ -- In the case of a multidimensional array, check that the
+ -- aggregate can be recursively flattened.
+
+ if Cannot_Flatten_Next_Aggr (Elmt) then
return False;
end if;
@@ -4768,17 +5180,16 @@ package body Exp_Aggr is
Elmt := First (Component_Associations (N));
- if Nkind (Expression (Elmt)) = N_Aggregate then
- if Present (Next_Index (Ix))
- and then
- not Flatten
- (Expression (Elmt), Next_Index (Ix), Next_Index (Ixb))
- then
+ Component_Loop : while Present (Elmt) loop
+ Expr := Expression (Elmt);
+
+ -- In the case of a multidimensional array, check that the
+ -- aggregate can be recursively flattened.
+
+ if Cannot_Flatten_Next_Aggr (Expr) then
return False;
end if;
- end if;
- Component_Loop : while Present (Elmt) loop
Choice := First (Choice_List (Elmt));
Choice_Loop : while Present (Choice) loop
@@ -4792,19 +5203,18 @@ package body Exp_Aggr is
-- a loop, we must generate individual assignments and
-- no flattening is possible.
- if Nkind (Expression (Elmt)) = N_Quantified_Expression
- then
+ if Nkind (Expr) = N_Quantified_Expression then
return False;
end if;
for J in Vals'Range loop
if No (Vals (J)) then
- Vals (J) := New_Copy_Tree (Expression (Elmt));
+ Vals (J) := New_Copy_Tree (Expr);
Rep_Count := Rep_Count + 1;
-- Check for maximum others replication. Note that
-- we skip this test if either of the restrictions
- -- No_Elaboration_Code or No_Implicit_Loops is
+ -- No_Implicit_Loops or No_Elaboration_Code is
-- active, if this is a preelaborable unit or
-- a predefined unit, or if the unit must be
-- placed in data memory. This also ensures that
@@ -4820,37 +5230,39 @@ package body Exp_Aggr is
-- Check if duplication is always OK and, if so,
-- continue processing.
- if Restriction_Active (No_Elaboration_Code)
- or else Restriction_Active (No_Implicit_Loops)
+ if Restriction_Active (No_Implicit_Loops) then
+ null;
+
+ -- If duplication is not always OK, continue
+ -- only if either the element is static or is
+ -- an aggregate (we already know it is OK).
+
+ elsif not Is_Static_Element (Elmt, Dims)
+ and then Nkind (Expr) /= N_Aggregate
+ then
+ return False;
+
+ -- Check if duplication is OK for elaboration
+ -- purposes and, if so, continue processing.
+
+ elsif Restriction_Active (No_Elaboration_Code)
or else
(Ekind (Current_Scope) = E_Package
- and then Static_Elaboration_Desired
- (Current_Scope))
+ and then
+ Static_Elaboration_Desired (Current_Scope))
or else Is_Preelaborated (P)
or else (Ekind (P) = E_Package_Body
and then
- Is_Preelaborated (Spec_Entity (P)))
+ Is_Preelaborated (Spec_Entity (P)))
or else
Is_Predefined_Unit (Get_Source_Unit (P))
then
null;
- -- If duplication is not always OK, continue
- -- only if either the element is static or is
- -- an aggregate which can itself be flattened,
- -- and the replication count is not too high.
-
- elsif (Is_Static_Element (Elmt)
- or else
- (Nkind (Expression (Elmt)) = N_Aggregate
- and then Present (Next_Index (Ix))))
- and then Rep_Count <= Max_Others_Replicate
- then
- null;
+ -- Otherwise, check that the replication count
+ -- is not too high.
- -- Return False in all the other cases
-
- else
+ elsif Rep_Count > Max_Others_Replicate then
return False;
end if;
end;
@@ -4895,8 +5307,7 @@ package body Exp_Aggr is
Choice_Index := UI_To_Int (Expr_Value (Choice));
if Choice_Index in Vals'Range then
- Vals (Choice_Index) :=
- New_Copy_Tree (Expression (Elmt));
+ Vals (Choice_Index) := New_Copy_Tree (Expr);
goto Continue;
-- Choice is statically out-of-range, will be
@@ -4920,7 +5331,7 @@ package body Exp_Aggr is
for J in UI_To_Int (Expr_Value (Lo)) ..
UI_To_Int (Expr_Value (Hi))
loop
- Vals (J) := New_Copy_Tree (Expression (Elmt));
+ Vals (J) := New_Copy_Tree (Expr);
end loop;
end if;
@@ -4948,7 +5359,7 @@ package body Exp_Aggr is
-- Is_Flat --
-------------
- function Is_Flat (N : Node_Id; Dims : Int) return Boolean is
+ function Is_Flat (N : Node_Id; Dims : Nat) return Boolean is
Elmt : Node_Id;
begin
@@ -4980,17 +5391,13 @@ package body Exp_Aggr is
-- Is_Static_Element --
-------------------------
- function Is_Static_Element (N : Node_Id) return Boolean is
+ function Is_Static_Element (N : Node_Id; Dims : Nat) return Boolean is
Expr : constant Node_Id := Expression (N);
begin
- if Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) then
- return True;
+ -- In most cases the interesting expressions are unambiguously static
- elsif Is_Entity_Name (Expr)
- and then Present (Entity (Expr))
- and then Ekind (Entity (Expr)) = E_Enumeration_Literal
- then
+ if Compile_Time_Known_Value (Expr) then
return True;
elsif Nkind (N) = N_Iterated_Component_Association then
@@ -5002,6 +5409,14 @@ package body Exp_Aggr is
then
return True;
+ -- However, one may write static expressions that are syntactically
+ -- ambiguous, so preanalyze the expression before checking it again,
+ -- but only at the innermost level for a multidimensional array.
+
+ elsif Dims = 1 then
+ Preanalyze_And_Resolve (Expr, Component_Type (Typ));
+ return Compile_Time_Known_Value (Expr);
+
else
return False;
end if;
@@ -5031,7 +5446,7 @@ package body Exp_Aggr is
-- elaboration code, so that the aggregate can be used as the
-- initial value of a thread-local variable.
- if Is_Flat (N, Number_Dimensions (Typ)) then
+ if Is_Flat (N, Dims) then
if Static_Array_Aggregate (N) then
Set_Compile_Time_Known_Aggregate (N);
end if;
@@ -5061,12 +5476,9 @@ package body Exp_Aggr is
-- compatible with the upper bound of the type, and therefore it is
-- worth flattening such aggregates as well.
- -- For now the back-end expands these aggregates into individual
- -- assignments to the target anyway, but it is conceivable that
- -- it will eventually be able to treat such aggregates statically???
-
- if Aggr_Size_OK (N, Typ)
- and then Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ)))
+ if Aggr_Size_OK (N)
+ and then
+ Flatten (N, Dims, First_Index (Typ), First_Index (Base_Type (Typ)))
then
if Static_Components then
Set_Compile_Time_Known_Aggregate (N);
@@ -5090,14 +5502,7 @@ package body Exp_Aggr is
if Nkind (N) = N_Aggregate and then Present (Expressions (N)) then
Expr := First (Expressions (N));
while Present (Expr) loop
- if Nkind_In (Expr, N_Integer_Literal, N_Real_Literal)
- or else
- (Is_Entity_Name (Expr)
- and then Ekind (Entity (Expr)) = E_Enumeration_Literal)
- then
- null;
-
- else
+ if not Compile_Time_Known_Value (Expr) then
Error_Msg_N
("non-static object requires elaboration code??", N);
exit;
@@ -5178,9 +5583,6 @@ package body Exp_Aggr is
-- If Others_Present (J) is True, then there is an others choice in one
-- of the subaggregates of N at dimension J.
- function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean;
- -- Returns true if an aggregate assignment can be done by the back end
-
procedure Build_Constrained_Type (Positional : Boolean);
-- If the subtype is not static or unconstrained, build a constrained
-- type using the computable sizes of the aggregate and its sub-
@@ -5212,212 +5614,6 @@ package body Exp_Aggr is
-- built directly into the target of the assignment it must be free
-- of side effects.
- ------------------------------------
- -- Aggr_Assignment_OK_For_Backend --
- ------------------------------------
-
- -- Backend processing by Gigi/gcc is possible only if all the following
- -- conditions are met:
-
- -- 1. N consists of a single OTHERS choice, possibly recursively
-
- -- 2. The array type has no null ranges (the purpose of this is to
- -- avoid a bogus warning for an out-of-range value).
-
- -- 3. The array type has no atomic components
-
- -- 4. The component type is elementary
-
- -- 5. The component size is a multiple of Storage_Unit
-
- -- 6. The component size is Storage_Unit or the value is of the form
- -- M * (1 + A**1 + A**2 + .. A**(K-1)) where A = 2**(Storage_Unit)
- -- and M in 1 .. A-1. This can also be viewed as K occurrences of
- -- the 8-bit value M, concatenated together.
-
- -- The ultimate goal is to generate a call to a fast memset routine
- -- specifically optimized for the target.
-
- function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean is
- Csiz : Uint;
- Ctyp : Entity_Id;
- Expr : Node_Id;
- High : Node_Id;
- Index : Entity_Id;
- Low : Node_Id;
- Nunits : Int;
- Remainder : Uint;
- Value : Uint;
-
- begin
- -- Back end doesn't know about <>
-
- if Has_Default_Init_Comps (N) then
- return False;
- end if;
-
- -- Recurse as far as possible to find the innermost component type
-
- Ctyp := Etype (N);
- Expr := N;
- while Is_Array_Type (Ctyp) loop
- if Nkind (Expr) /= N_Aggregate
- or else not Is_Others_Aggregate (Expr)
- then
- return False;
- end if;
-
- Index := First_Index (Ctyp);
- while Present (Index) loop
- Get_Index_Bounds (Index, Low, High);
-
- if Is_Null_Range (Low, High) then
- return False;
- end if;
-
- Next_Index (Index);
- end loop;
-
- Expr := Expression (First (Component_Associations (Expr)));
-
- for J in 1 .. Number_Dimensions (Ctyp) - 1 loop
- if Nkind (Expr) /= N_Aggregate
- or else not Is_Others_Aggregate (Expr)
- then
- return False;
- end if;
-
- Expr := Expression (First (Component_Associations (Expr)));
- end loop;
-
- if Has_Atomic_Components (Ctyp) then
- return False;
- end if;
-
- Csiz := Component_Size (Ctyp);
- Ctyp := Component_Type (Ctyp);
-
- if Is_Atomic_Or_VFA (Ctyp) then
- return False;
- end if;
- end loop;
-
- -- An Iterated_Component_Association involves a loop (in most cases)
- -- and is never static.
-
- if Nkind (Parent (Expr)) = N_Iterated_Component_Association then
- return False;
- end if;
-
- -- Access types need to be dealt with specially
-
- if Is_Access_Type (Ctyp) then
-
- -- Component_Size is not set by Layout_Type if the component
- -- type is an access type ???
-
- Csiz := Esize (Ctyp);
-
- -- Fat pointers are rejected as they are not really elementary
- -- for the backend.
-
- if Csiz /= System_Address_Size then
- return False;
- end if;
-
- -- The supported expressions are NULL and constants, others are
- -- rejected upfront to avoid being analyzed below, which can be
- -- problematic for some of them, for example allocators.
-
- if Nkind (Expr) /= N_Null and then not Is_Entity_Name (Expr) then
- return False;
- end if;
-
- -- Scalar types are OK if their size is a multiple of Storage_Unit
-
- elsif Is_Scalar_Type (Ctyp) then
- if Csiz mod System_Storage_Unit /= 0 then
- return False;
- end if;
-
- -- Composite types are rejected
-
- else
- return False;
- end if;
-
- -- If the expression has side effects (e.g. contains calls with
- -- potential side effects) reject as well. We only preanalyze the
- -- expression to prevent the removal of intended side effects.
-
- Preanalyze_And_Resolve (Expr, Ctyp);
-
- if not Side_Effect_Free (Expr) then
- return False;
- end if;
-
- -- The expression needs to be analyzed if True is returned
-
- Analyze_And_Resolve (Expr, Ctyp);
-
- -- Strip away any conversions from the expression as they simply
- -- qualify the real expression.
-
- while Nkind_In (Expr, N_Unchecked_Type_Conversion,
- N_Type_Conversion)
- loop
- Expr := Expression (Expr);
- end loop;
-
- Nunits := UI_To_Int (Csiz) / System_Storage_Unit;
-
- if Nunits = 1 then
- return True;
- end if;
-
- if not Compile_Time_Known_Value (Expr) then
- return False;
- end if;
-
- -- The only supported value for floating point is 0.0
-
- if Is_Floating_Point_Type (Ctyp) then
- return Expr_Value_R (Expr) = Ureal_0;
- end if;
-
- -- For other types, we can look into the value as an integer
-
- Value := Expr_Value (Expr);
-
- if Has_Biased_Representation (Ctyp) then
- Value := Value - Expr_Value (Type_Low_Bound (Ctyp));
- end if;
-
- -- Values 0 and -1 immediately satisfy the last check
-
- if Value = Uint_0 or else Value = Uint_Minus_1 then
- return True;
- end if;
-
- -- We need to work with an unsigned value
-
- if Value < 0 then
- Value := Value + 2**(System_Storage_Unit * Nunits);
- end if;
-
- Remainder := Value rem 2**System_Storage_Unit;
-
- for J in 1 .. Nunits - 1 loop
- Value := Value / 2**System_Storage_Unit;
-
- if Value rem 2**System_Storage_Unit /= Remainder then
- return False;
- end if;
- end loop;
-
- return True;
- end Aggr_Assignment_OK_For_Backend;
-
----------------------------
-- Build_Constrained_Type --
----------------------------
@@ -5848,26 +6044,51 @@ package body Exp_Aggr is
-- raise Constraint_Error;
-- end if;
+ -- in the general case, but the following simpler test:
+
+ -- [constraint_error when
+ -- Aggr_Lo + (Nb_Elements - 1) > Aggr_Hi];
+
+ -- instead if the index type is a signed integer.
+
elsif Nb_Elements > Uint_0 then
- Cond :=
- Make_Op_Gt (Loc,
- Left_Opnd =>
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ind_Typ, Loc),
- Attribute_Name => Name_Pos,
- Expressions =>
- New_List
- (Duplicate_Subexpr_Move_Checks (Aggr_Lo))),
- Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)),
+ if Nb_Elements = Uint_1 then
+ Cond :=
+ Make_Op_Gt (Loc,
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
+ Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi));
+
+ elsif Is_Signed_Integer_Type (Ind_Typ) then
+ Cond :=
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Nb_Elements - 1)),
+ Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi));
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ind_Typ, Loc),
- Attribute_Name => Name_Pos,
- Expressions => New_List (
- Duplicate_Subexpr_Move_Checks (Aggr_Hi))));
+ else
+ Cond :=
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ind_Typ, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions =>
+ New_List
+ (Duplicate_Subexpr_Move_Checks (Aggr_Lo))),
+ Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)),
+
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ind_Typ, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions => New_List (
+ Duplicate_Subexpr_Move_Checks (Aggr_Hi))));
+ end if;
-- If we are dealing with an aggregate containing an others choice
-- and discrete choices we generate the following test:
@@ -5968,7 +6189,7 @@ package body Exp_Aggr is
if Is_Entity_Name (N) then
return True;
- elsif Nkind_In (N, N_Explicit_Dereference, N_Selected_Component)
+ elsif Nkind (N) in N_Explicit_Dereference | N_Selected_Component
and then Safe_Left_Hand_Side (Prefix (N))
then
return True;
@@ -6153,13 +6374,7 @@ package body Exp_Aggr is
-- At this point we try to convert to positional form
- if Ekind (Current_Scope) = E_Package
- and then Static_Elaboration_Desired (Current_Scope)
- then
- Convert_To_Positional (N, Max_Others_Replicate => 100);
- else
- Convert_To_Positional (N);
- end if;
+ Convert_To_Positional (N);
-- if the result is no longer an aggregate (e.g. it may be a string
-- literal, or a temporary which has the needed value), then we are
@@ -6283,14 +6498,15 @@ package body Exp_Aggr is
then
Maybe_In_Place_OK := False;
- else
+ elsif Parent_Kind = N_Assignment_Statement then
Maybe_In_Place_OK :=
- (Nkind (Parent (N)) = N_Assignment_Statement
- and then In_Place_Assign_OK (N))
+ In_Place_Assign_OK (N, Get_Base_Object (Name (Parent_Node)));
+
+ elsif Parent_Kind = N_Allocator then
+ Maybe_In_Place_OK := In_Place_Assign_OK (N);
- or else
- (Nkind (Parent (Parent (N))) = N_Allocator
- and then In_Place_Assign_OK (N));
+ else
+ Maybe_In_Place_OK := False;
end if;
-- If this is an array of tasks, it will be expanded into build-in-place
@@ -6307,10 +6523,6 @@ package body Exp_Aggr is
-- object. (Note: we don't use a block statement because this would
-- cause generated freeze nodes to be elaborated in the wrong scope).
- -- Do not perform in-place expansion for SPARK 05 because aggregates are
- -- expected to appear in qualified form. In-place expansion eliminates
- -- the qualification and eventually violates this SPARK 05 restiction.
-
-- Arrays of limited components must be built in place. The code
-- previously excluded controlled components but this is an old
-- oversight: the rules in 7.6 (17) are clear.
@@ -6321,7 +6533,6 @@ package body Exp_Aggr is
and then not
Must_Slide (Etype (Defining_Identifier (Parent_Node)), Typ)
and then not Is_Bit_Packed_Array (Typ)
- and then not Restriction_Check_Required (SPARK_05)
then
In_Place_Assign_OK_For_Declaration := True;
Tmp := Defining_Identifier (Parent_Node);
@@ -6349,10 +6560,7 @@ package body Exp_Aggr is
Set_Etype (Tmp, Typ);
end if;
- elsif Maybe_In_Place_OK
- and then Nkind (Parent (N)) = N_Qualified_Expression
- and then Nkind (Parent (Parent (N))) = N_Allocator
- then
+ elsif Maybe_In_Place_OK and then Parent_Kind = N_Allocator then
Set_Expansion_Delayed (N);
return;
@@ -6360,7 +6568,7 @@ package body Exp_Aggr is
-- enclosing construct is expanded.
elsif Maybe_In_Place_OK
- and then Nkind (Parent (N)) = N_Simple_Return_Statement
+ and then Parent_Kind = N_Simple_Return_Statement
then
Set_Expansion_Delayed (N);
return;
@@ -6368,9 +6576,9 @@ package body Exp_Aggr is
-- In the remaining cases the aggregate is the RHS of an assignment
elsif Maybe_In_Place_OK
- and then Safe_Left_Hand_Side (Name (Parent (N)))
+ and then Safe_Left_Hand_Side (Name (Parent_Node))
then
- Tmp := Name (Parent (N));
+ Tmp := Name (Parent_Node);
if Etype (Tmp) /= Etype (N) then
Apply_Length_Check (N, Etype (Tmp));
@@ -6388,10 +6596,10 @@ package body Exp_Aggr is
-- by converting it into a loop over the discrete range of the slice.
elsif Maybe_In_Place_OK
- and then Nkind (Name (Parent (N))) = N_Slice
+ and then Nkind (Name (Parent_Node)) = N_Slice
and then Is_Others_Aggregate (N)
then
- Tmp := Name (Parent (N));
+ Tmp := Name (Parent_Node);
-- Set type of aggregate to be type of lhs in assignment, in order
-- to suppress redundant length checks.
@@ -6419,7 +6627,7 @@ package body Exp_Aggr is
-- around the aggregate for this purpose.
if Ekind (Current_Scope) = E_Loop
- and then Nkind (Parent (Parent (N))) = N_Allocator
+ and then Parent_Kind = N_Allocator
then
Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if;
@@ -6493,7 +6701,7 @@ package body Exp_Aggr is
if Needs_Finalization (Typ)
and then Is_Entity_Name (Target)
and then Present (Entity (Target))
- and then Ekind_In (Entity (Target), E_Constant, E_Variable)
+ and then Ekind (Entity (Target)) in E_Constant | E_Variable
then
Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code));
end if;
@@ -6529,13 +6737,13 @@ package body Exp_Aggr is
-- If the aggregate has been assigned in place, remove the original
-- assignment.
- if Nkind (Parent (N)) = N_Assignment_Statement
- and then Maybe_In_Place_OK
- then
- Rewrite (Parent (N), Make_Null_Statement (Loc));
+ if Parent_Kind = N_Assignment_Statement and then Maybe_In_Place_OK then
+ Rewrite (Parent_Node, Make_Null_Statement (Loc));
+
+ -- Or else, if a temporary was created, replace the aggregate with it
- elsif Nkind (Parent (N)) /= N_Object_Declaration
- or else Tmp /= Defining_Identifier (Parent (N))
+ elsif Parent_Kind /= N_Object_Declaration
+ or else Tmp /= Defining_Identifier (Parent_Node)
then
Rewrite (N, New_Occurrence_Of (Tmp, Loc));
Analyze_And_Resolve (N, Typ);
@@ -6553,6 +6761,9 @@ package body Exp_Aggr is
if Is_Record_Type (Etype (N)) then
Expand_Record_Aggregate (N);
+ elsif Has_Aspect (Etype (N), Aspect_Aggregate) then
+ Expand_Container_Aggregate (N);
+
-- Array aggregate case
else
@@ -6652,13 +6863,434 @@ package body Exp_Aggr is
return;
end Expand_N_Aggregate;
+ --------------------------------
+ -- Expand_Container_Aggregate --
+ --------------------------------
+
+ procedure Expand_Container_Aggregate (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate);
+
+ Empty_Subp : Node_Id := Empty;
+ Add_Named_Subp : Node_Id := Empty;
+ Add_Unnamed_Subp : Node_Id := Empty;
+ New_Indexed_Subp : Node_Id := Empty;
+ Assign_Indexed_Subp : Node_Id := Empty;
+
+ Aggr_Code : constant List_Id := New_List;
+ Temp : constant Entity_Id := Make_Temporary (Loc, 'C', N);
+
+ Comp : Node_Id;
+ Decl : Node_Id;
+ Init_Stat : Node_Id;
+
+ procedure Expand_Iterated_Component (Comp : Node_Id);
+ -- Handle iterated_component_association and iterated_Element
+ -- association by generating a loop over the specified range,
+ -- given either by a loop parameter specification or an iterator
+ -- specification.
+
+ -------------------------------
+ -- Expand_Iterated_Component --
+ -------------------------------
+
+ procedure Expand_Iterated_Component (Comp : Node_Id) is
+ Expr : constant Node_Id := Expression (Comp);
+ Loop_Id : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Chars (Defining_Identifier (Comp)));
+
+ L_Range : Node_Id;
+ L_Iteration_Scheme : Node_Id;
+ Loop_Stat : Node_Id;
+ Stats : List_Id;
+
+ begin
+ if Present (Iterator_Specification (Comp)) then
+ L_Iteration_Scheme :=
+ Make_Iteration_Scheme (Loc,
+ Iterator_Specification => Iterator_Specification (Comp));
+
+ else
+ L_Range := Relocate_Node (First (Discrete_Choices (Comp)));
+ L_Iteration_Scheme :=
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Loop_Id,
+ Discrete_Subtype_Definition => L_Range));
+ end if;
+
+ -- Build insertion statement. For a positional aggregate, only the
+ -- expression is needed. For a named aggregate, the loop variable,
+ -- whose type is that of the key, is an additional parameter for
+ -- the insertion operation.
+
+ if Present (Add_Unnamed_Subp) then
+ Stats := New_List
+ (Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Entity (Add_Unnamed_Subp), Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Copy_Tree (Expr))));
+ else
+ Stats := New_List
+ (Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Entity (Add_Named_Subp), Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Occurrence_Of (Loop_Id, Loc),
+ New_Copy_Tree (Expr))));
+ end if;
+
+ Loop_Stat := Make_Implicit_Loop_Statement
+ (Node => N,
+ Identifier => Empty,
+ Iteration_Scheme => L_Iteration_Scheme,
+ Statements => Stats);
+ Append (Loop_Stat, Aggr_Code);
+
+ end Expand_Iterated_Component;
+
+ begin
+ Parse_Aspect_Aggregate (Asp,
+ Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp,
+ New_Indexed_Subp, Assign_Indexed_Subp);
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition => New_Occurrence_Of (Typ, Loc));
+
+ Insert_Action (N, Decl);
+ if Ekind (Entity (Empty_Subp)) = E_Function then
+ Init_Stat := Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Temp, Loc),
+ Expression => Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Entity (Empty_Subp), Loc)));
+ else
+ Init_Stat := Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Temp, Loc),
+ Expression => New_Occurrence_Of (Entity (Empty_Subp), Loc));
+ end if;
+
+ Append (Init_Stat, Aggr_Code);
+
+ ---------------------------
+ -- Positional aggregate --
+ ---------------------------
+
+ if Present (Add_Unnamed_Subp)
+ and then No (Assign_Indexed_Subp)
+ then
+ if Present (Expressions (N)) then
+ declare
+ Insert : constant Entity_Id := Entity (Add_Unnamed_Subp);
+ Comp : Node_Id;
+ Stat : Node_Id;
+
+ begin
+ Comp := First (Expressions (N));
+ while Present (Comp) loop
+ Stat := Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Insert, Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Copy_Tree (Comp)));
+ Append (Stat, Aggr_Code);
+ Next (Comp);
+ end loop;
+ end;
+ end if;
+
+ -- Iterated component associations may also be present.
+
+ Comp := First (Component_Associations (N));
+ while Present (Comp) loop
+ Expand_Iterated_Component (Comp);
+ Next (Comp);
+ end loop;
+
+ ---------------------
+ -- Named_Aggregate --
+ ---------------------
+
+ elsif Present (Add_Named_Subp) then
+ declare
+ Insert : constant Entity_Id := Entity (Add_Named_Subp);
+ Stat : Node_Id;
+ Key : Node_Id;
+ begin
+ Comp := First (Component_Associations (N));
+
+ -- Each component association may contain several choices;
+ -- generate an insertion statement for each.
+
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Iterated_Component_Association then
+ Expand_Iterated_Component (Comp);
+ else
+ Key := First (Choices (Comp));
+
+ while Present (Key) loop
+ Stat := Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Insert, Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Copy_Tree (Key),
+ New_Copy_Tree (Expression (Comp))));
+ Append (Stat, Aggr_Code);
+
+ Next (Key);
+ end loop;
+ end if;
+
+ Next (Comp);
+ end loop;
+ end;
+
+ -----------------------
+ -- Indexed_Aggregate --
+ -----------------------
+
+ elsif Present (Assign_Indexed_Subp) then
+ declare
+ Insert : constant Entity_Id := Entity (Assign_Indexed_Subp);
+ Index_Type : constant Entity_Id :=
+ Etype (Next_Formal (First_Formal (Insert)));
+
+ function Aggregate_Size return Int;
+ -- Compute number of entries in aggregate, including choices
+ -- that cover a range, as well as iterated constructs.
+
+ function Expand_Range_Component
+ (Rng : Node_Id;
+ Expr : Node_Id) return Node_Id;
+ -- Transform a component assoication with a range into an
+ -- explicit loop. If the choice is a subtype name, it is
+ -- rewritten as a range with the corresponding bounds, which
+ -- are known to be static.
+
+ Comp : Node_Id;
+ Index : Node_Id;
+ Pos : Int := 0;
+ Stat : Node_Id;
+ Key : Node_Id;
+ Size : Int := 0;
+
+ -----------------------------
+ -- Expand_Raange_Component --
+ -----------------------------
+
+ function Expand_Range_Component
+ (Rng : Node_Id;
+ Expr : Node_Id) return Node_Id
+ is
+ Loop_Id : constant Entity_Id :=
+ Make_Temporary (Loc, 'T');
+
+ L_Iteration_Scheme : Node_Id;
+ Stats : List_Id;
+
+ begin
+ L_Iteration_Scheme :=
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Loop_Id,
+ Discrete_Subtype_Definition => New_Copy_Tree (Rng)));
+
+ Stats := New_List
+ (Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Entity (Assign_Indexed_Subp), Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Occurrence_Of (Loop_Id, Loc),
+ New_Copy_Tree (Expr))));
+
+ return Make_Implicit_Loop_Statement
+ (Node => N,
+ Identifier => Empty,
+ Iteration_Scheme => L_Iteration_Scheme,
+ Statements => Stats);
+ end Expand_Range_Component;
+
+ --------------------
+ -- Aggregate_Size --
+ --------------------
+
+ function Aggregate_Size return Int is
+ Comp : Node_Id;
+ Choice : Node_Id;
+ Lo, Hi : Node_Id;
+ Siz : Int := 0;
+
+ procedure Add_Range_Size;
+ -- Compute size of component association given by
+ -- range or subtype name.
+
+ procedure Add_Range_Size is
+ begin
+ if Nkind (Lo) = N_Integer_Literal then
+ Siz := Siz + UI_To_Int (Intval (Hi))
+ - UI_To_Int (Intval (Lo)) + 1;
+ end if;
+ end Add_Range_Size;
+
+ begin
+ if Present (Expressions (N)) then
+ Siz := List_Length (Expressions (N));
+ end if;
+
+ if Present (Component_Associations (N)) then
+ Comp := First (Component_Associations (N));
+ while Present (Comp) loop
+ Choice := First (Choices (Comp));
+
+ while Present (Choice) loop
+ Analyze (Choice);
+
+ if Nkind (Choice) = N_Range then
+ Lo := Low_Bound (Choice);
+ Hi := High_Bound (Choice);
+ Add_Range_Size;
+
+ elsif Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ then
+ Lo := Type_Low_Bound (Entity (Choice));
+ Hi := Type_High_Bound (Entity (Choice));
+ Add_Range_Size;
+ Rewrite (Choice,
+ Make_Range (Loc,
+ New_Copy_Tree (Lo),
+ New_Copy_Tree (Hi)));
+
+ else
+ Resolve (Choice, Index_Type);
+ Siz := Siz + 1;
+ end if;
+
+ Next (Choice);
+ end loop;
+ Next (Comp);
+ end loop;
+ end if;
+
+ return Siz;
+ end Aggregate_Size;
+
+ begin
+ Size := Aggregate_Size;
+ if Size > 0 then
+
+ -- Modify the call to the constructor to allocate the
+ -- required size for the aggregwte : call the provided
+ -- constructor rather than the Empty aggregate.
+
+ Index := Make_Op_Add (Loc,
+ Left_Opnd => New_Copy_Tree (Type_Low_Bound (Index_Type)),
+ Right_Opnd => Make_Integer_Literal (Loc, Size - 1));
+
+ Set_Expression (Init_Stat,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Entity (New_Indexed_Subp), Loc),
+ Parameter_Associations =>
+ New_List (
+ New_Copy_Tree (Type_Low_Bound (Index_Type)),
+ Index)));
+ end if;
+
+ if Present (Expressions (N)) then
+ Comp := First (Expressions (N));
+
+ while Present (Comp) loop
+
+ -- Compute index position for successive components
+ -- in the list of expressions, and use the indexed
+ -- assignment procedure for each.
+
+ Index := Make_Op_Add (Loc,
+ Left_Opnd => Type_Low_Bound (Index_Type),
+ Right_Opnd => Make_Integer_Literal (Loc, Pos));
+
+ Stat := Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Insert, Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ Index,
+ New_Copy_Tree (Comp)));
+
+ Pos := Pos + 1;
+
+ Append (Stat, Aggr_Code);
+ Next (Comp);
+ end loop;
+ end if;
+
+ if Present (Component_Associations (N)) then
+ Comp := First (Component_Associations (N));
+
+ -- The choice may be a static value, or a range with
+ -- static bounds.
+
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Component_Association then
+ Key := First (Choices (Comp));
+ while Present (Key) loop
+
+ -- If the expression is a box, the corresponding
+ -- component (s) is left uninitialized.
+
+ if Box_Present (Comp) then
+ goto Next_Key;
+
+ elsif Nkind (Key) = N_Range then
+
+ -- Create loop for tne specified range,
+ -- with copies of the expression.
+
+ Stat :=
+ Expand_Range_Component (Key, Expression (Comp));
+
+ else
+ Stat := Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of
+ (Entity (Assign_Indexed_Subp), Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Copy_Tree (Key),
+ New_Copy_Tree (Expression (Comp))));
+ end if;
+
+ Append (Stat, Aggr_Code);
+
+ <<Next_Key>>
+ Next (Key);
+ end loop;
+ else
+ Error_Msg_N ("iterated associations peding", N);
+ end if;
+ Next (Comp);
+ end loop;
+ end if;
+ end;
+ end if;
+
+ Insert_Actions (N, Aggr_Code);
+ Rewrite (N, New_Occurrence_Of (Temp, Loc));
+ Analyze_And_Resolve (N, Typ);
+ end Expand_Container_Aggregate;
+
------------------------------
-- Expand_N_Delta_Aggregate --
------------------------------
procedure Expand_N_Delta_Aggregate (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
+ Typ : constant Entity_Id := Etype (Expression (N));
Decl : Node_Id;
begin
@@ -7197,7 +7829,7 @@ package body Exp_Aggr is
Comp := First_Component (Typ);
while Chars (Comp) /= Name_uParent loop
- Comp := Next_Component (Comp);
+ Next_Component (Comp);
end loop;
Parent_Name := New_Occurrence_Of (Comp, Loc);
@@ -7334,7 +7966,7 @@ package body Exp_Aggr is
return False;
end if;
- Indx := Next_Index (Indx);
+ Next_Index (Indx);
end loop;
end if;
end;
@@ -7467,8 +8099,8 @@ package body Exp_Aggr is
begin
Aggr := N;
while Present (Parent (Aggr))
- and then Nkind_In (Parent (Aggr), N_Aggregate,
- N_Component_Association)
+ and then Nkind (Parent (Aggr)) in
+ N_Aggregate | N_Component_Association
loop
Aggr := Parent (Aggr);
end loop;
@@ -7514,8 +8146,8 @@ package body Exp_Aggr is
-- aggregates for C++ imported types must be expanded.
elsif Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then
- if not Nkind_In (Parent (N), N_Component_Association,
- N_Object_Declaration)
+ if Nkind (Parent (N)) not in
+ N_Component_Association | N_Object_Declaration
then
Convert_To_Assignments (N, Typ);
@@ -7615,6 +8247,28 @@ package body Exp_Aggr is
end if;
end Expand_Record_Aggregate;
+ ---------------------
+ -- Get_Base_Object --
+ ---------------------
+
+ function Get_Base_Object (N : Node_Id) return Entity_Id is
+ R : Node_Id;
+
+ begin
+ R := Get_Referenced_Object (N);
+
+ while Nkind (R) in N_Indexed_Component | N_Selected_Component | N_Slice
+ loop
+ R := Get_Referenced_Object (Prefix (R));
+ end loop;
+
+ if Is_Entity_Name (R) and then Is_Object (Entity (R)) then
+ return Entity (R);
+ else
+ return Empty;
+ end if;
+ end Get_Base_Object;
+
----------------------------
-- Has_Default_Init_Comps --
----------------------------
@@ -7625,7 +8279,7 @@ package body Exp_Aggr is
Expr : Node_Id;
begin
- pragma Assert (Nkind_In (N, N_Aggregate, N_Extension_Aggregate));
+ pragma Assert (Nkind (N) in N_Aggregate | N_Extension_Aggregate);
if No (Comps) then
return False;
@@ -7653,7 +8307,7 @@ package body Exp_Aggr is
Expr := Expression (C);
if Present (Expr)
- and then Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate)
+ and then Nkind (Expr) in N_Aggregate | N_Extension_Aggregate
and then Has_Default_Init_Comps (Expr)
then
return True;
@@ -7706,7 +8360,7 @@ package body Exp_Aggr is
Kind := Nkind (Node);
end if;
- if not Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate) then
+ if Kind not in N_Aggregate | N_Extension_Aggregate then
return False;
else
return Expansion_Delayed (Node);
@@ -7794,6 +8448,9 @@ package body Exp_Aggr is
or else
Typ = RTE (RE_Tag_Table)
or else
+ (RTE_Available (RE_Object_Specific_Data)
+ and then Typ = RTE (RE_Object_Specific_Data))
+ or else
(RTE_Available (RE_Interface_Data)
and then Typ = RTE (RE_Interface_Data))
or else
@@ -7826,17 +8483,40 @@ package body Exp_Aggr is
Target : Node_Id) return List_Id
is
Aggr_Code : List_Id;
+ New_Aggr : Node_Id;
begin
- if Is_Array_Type (Etype (N)) then
- Aggr_Code :=
- Build_Array_Aggr_Code
- (N => N,
- Ctype => Component_Type (Etype (N)),
- Index => First_Index (Typ),
- Into => Target,
- Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)),
- Indexes => No_List);
+ if Is_Array_Type (Typ) then
+ -- If the assignment can be done directly by the back end, then
+ -- reset Set_Expansion_Delayed and do not expand further.
+
+ if not CodePeer_Mode
+ and then not Modify_Tree_For_C
+ and then not Possible_Bit_Aligned_Component (Target)
+ and then not Is_Possibly_Unaligned_Slice (Target)
+ and then Aggr_Assignment_OK_For_Backend (N)
+ then
+ New_Aggr := New_Copy_Tree (N);
+ Set_Expansion_Delayed (New_Aggr, False);
+
+ Aggr_Code :=
+ New_List (
+ Make_OK_Assignment_Statement (Sloc (New_Aggr),
+ Name => Target,
+ Expression => New_Aggr));
+
+ -- Or else, generate component assignments to it
+
+ else
+ Aggr_Code :=
+ Build_Array_Aggr_Code
+ (N => N,
+ Ctype => Component_Type (Typ),
+ Index => First_Index (Typ),
+ Into => Target,
+ Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)),
+ Indexes => No_List);
+ end if;
-- Directly or indirectly (e.g. access protected procedure) a record
@@ -7852,7 +8532,7 @@ package body Exp_Aggr is
if Needs_Finalization (Typ)
and then Is_Entity_Name (Target)
and then Present (Entity (Target))
- and then Ekind_In (Entity (Target), E_Constant, E_Variable)
+ and then Ekind (Entity (Target)) in E_Constant | E_Variable
then
Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code));
end if;
@@ -7874,6 +8554,105 @@ package body Exp_Aggr is
return Make_Assignment_Statement (Sloc, Name, Expression);
end Make_OK_Assignment_Statement;
+ ------------------------
+ -- Max_Aggregate_Size --
+ ------------------------
+
+ function Max_Aggregate_Size
+ (N : Node_Id;
+ Default_Size : Nat := 5000) return Nat
+ is
+ Typ : constant Entity_Id := Etype (N);
+
+ function Use_Small_Size (N : Node_Id) return Boolean;
+ -- True if we should return a very small size, which means large
+ -- aggregates will be implemented as a loop when possible (potentially
+ -- transformed to memset calls).
+
+ function Aggr_Context (N : Node_Id) return Node_Id;
+ -- Return the context in which the aggregate appears, not counting
+ -- qualified expressions and similar.
+
+ function Aggr_Context (N : Node_Id) return Node_Id is
+ Result : Node_Id := Parent (N);
+ begin
+ if Nkind (Result) in N_Qualified_Expression
+ | N_Type_Conversion
+ | N_Unchecked_Type_Conversion
+ | N_If_Expression
+ | N_Case_Expression
+ | N_Component_Association
+ | N_Aggregate
+ then
+ Result := Aggr_Context (Result);
+ end if;
+
+ return Result;
+ end Aggr_Context;
+
+ function Use_Small_Size (N : Node_Id) return Boolean is
+ C : constant Node_Id := Aggr_Context (N);
+ -- The decision depends on the context in which the aggregate occurs,
+ -- and for variable declarations, whether we are nested inside a
+ -- subprogram.
+ begin
+ case Nkind (C) is
+ -- True for assignment statements and similar
+
+ when N_Assignment_Statement
+ | N_Simple_Return_Statement
+ | N_Allocator
+ | N_Attribute_Reference
+ =>
+ return True;
+
+ -- True for nested variable declarations. False for library level
+ -- variables, and for constants (whether or not nested).
+
+ when N_Object_Declaration =>
+ return not Constant_Present (C)
+ and then Ekind (Current_Scope) in Subprogram_Kind;
+
+ -- False for all other contexts
+
+ when others =>
+ return False;
+ end case;
+ end Use_Small_Size;
+
+ -- Start of processing for Max_Aggregate_Size
+
+ begin
+ -- We use a small limit in CodePeer mode where we favor loops
+ -- instead of thousands of single assignments (from large aggregates).
+
+ -- We also increase the limit to 2**24 (about 16 million) if
+ -- Restrictions (No_Elaboration_Code) or Restrictions
+ -- (No_Implicit_Loops) is specified, since in either case we are at risk
+ -- of declaring the program illegal because of this limit. We also
+ -- increase the limit when Static_Elaboration_Desired, given that this
+ -- means that objects are intended to be placed in data memory.
+
+ -- Same if the aggregate is for a packed two-dimensional array, because
+ -- if components are static it is much more efficient to construct a
+ -- one-dimensional equivalent array with static components.
+
+ if CodePeer_Mode then
+ return 100;
+ elsif Restriction_Active (No_Elaboration_Code)
+ or else Restriction_Active (No_Implicit_Loops)
+ or else Is_Two_Dim_Packed_Array (Typ)
+ or else (Ekind (Current_Scope) = E_Package
+ and then Static_Elaboration_Desired (Current_Scope))
+ then
+ return 2 ** 24;
+ elsif Use_Small_Size (N) then
+ return 64;
+ end if;
+
+ return Default_Size;
+ end Max_Aggregate_Size;
+
-----------------------
-- Number_Of_Choices --
-----------------------
@@ -8046,8 +8825,7 @@ package body Exp_Aggr is
-- have failed to create a packed value for it.
if Present (Component_Associations (N)) then
- Convert_To_Positional
- (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True);
+ Convert_To_Positional (N, Handle_Bit_Packed => True);
return Nkind (N) /= N_Aggregate;
end if;
@@ -8592,7 +9370,7 @@ package body Exp_Aggr is
function Is_Static_Component (Nod : Node_Id) return Boolean is
begin
- if Nkind_In (Nod, N_Integer_Literal, N_Real_Literal) then
+ if Nkind (Nod) in N_Integer_Literal | N_Real_Literal then
return True;
elsif Is_Entity_Name (Nod)
@@ -8676,7 +9454,7 @@ package body Exp_Aggr is
return False;
end if;
- if not Aggr_Size_OK (N, Typ) then
+ if not Aggr_Size_OK (N) then
return False;
end if;
@@ -8742,8 +9520,7 @@ package body Exp_Aggr is
return False;
end if;
- Convert_To_Positional
- (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True);
+ Convert_To_Positional (N, Handle_Bit_Packed => True);
-- Verify that all components are static
@@ -8858,12 +9635,12 @@ package body Exp_Aggr is
Comp_Val := Comp_Val mod Uint_2 ** Comp_Size;
Val := UI_To_Int (Val + Comp_Val * Uint_2 ** Shift);
Shift := Shift + Incr;
- One_Comp := Next (One_Comp);
+ Next (One_Comp);
Packed_Num := Packed_Num + 1;
end if;
end loop;
- One_Dim := Next (One_Dim);
+ Next (One_Dim);
end loop;
if Packed_Num > 0 then
diff --git a/gcc/ada/exp_aggr.ads b/gcc/ada/exp_aggr.ads
index 87bef239..f9ad193 100644
--- a/gcc/ada/exp_aggr.ads
+++ b/gcc/ada/exp_aggr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb
index db1833c..dc1d138 100644
--- a/gcc/ada/exp_atag.adb
+++ b/gcc/ada/exp_atag.adb
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,6 @@ with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Disp; use Exp_Disp;
-with Exp_Util; use Exp_Util;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -57,6 +56,9 @@ package body Exp_Atag is
-- To_Dispatch_Table_Ptr
-- (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position);
+ function Build_Range (Loc : Source_Ptr; Lo, Hi : Nat) return Node_Id;
+ -- Build an N_Range node for [Lo; Hi] with Standard.Natural type
+
function Build_TSD
(Loc : Source_Ptr;
Tag_Node_Addr : Node_Id) return Node_Id;
@@ -66,6 +68,9 @@ package body Exp_Atag is
-- Generate: To_Type_Specific_Data_Ptr
-- (To_Addr_Ptr (Tag_Node_Addr - Typeinfo_Offset).all);
+ function Build_Val (Loc : Source_Ptr; V : Uint) return Node_Id;
+ -- Build an N_Integer_Literal node for V with Standard.Natural type
+
------------------------------------------------
-- Build_Common_Dispatching_Select_Statements --
------------------------------------------------
@@ -153,112 +158,6 @@ package body Exp_Atag is
Make_Simple_Return_Statement (Loc))));
end Build_Common_Dispatching_Select_Statements;
- -------------------------
- -- Build_CW_Membership --
- -------------------------
-
- procedure Build_CW_Membership
- (Loc : Source_Ptr;
- Obj_Tag_Node : in out Node_Id;
- Typ_Tag_Node : Node_Id;
- Related_Nod : Node_Id;
- New_Node : out Node_Id)
- is
- Tag_Addr : constant Entity_Id := Make_Temporary (Loc, 'D', Obj_Tag_Node);
- Obj_TSD : constant Entity_Id := Make_Temporary (Loc, 'D');
- Typ_TSD : constant Entity_Id := Make_Temporary (Loc, 'D');
- Index : constant Entity_Id := Make_Temporary (Loc, 'D');
-
- begin
- -- Generate:
-
- -- Tag_Addr : constant Tag := Address!(Obj_Tag);
- -- Obj_TSD : constant Type_Specific_Data_Ptr
- -- := Build_TSD (Tag_Addr);
- -- Typ_TSD : constant Type_Specific_Data_Ptr
- -- := Build_TSD (Address!(Typ_Tag));
- -- Index : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth
- -- Index >= 0 and then Obj_TSD.Tags_Table (Index) = Typ'Tag
-
- Insert_Action (Related_Nod,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Tag_Addr,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc),
- Expression => Unchecked_Convert_To
- (RTE (RE_Address), Obj_Tag_Node)));
-
- -- Unchecked_Convert_To relocates Obj_Tag_Node and therefore we must
- -- update it.
-
- Obj_Tag_Node := Expression (Expression (Parent (Tag_Addr)));
-
- Insert_Action (Related_Nod,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Obj_TSD,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Type_Specific_Data_Ptr), Loc),
- Expression =>
- Build_TSD (Loc, New_Occurrence_Of (Tag_Addr, Loc))),
- Suppress => All_Checks);
-
- Insert_Action (Related_Nod,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Typ_TSD,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Type_Specific_Data_Ptr), Loc),
- Expression =>
- Build_TSD (Loc,
- Unchecked_Convert_To (RTE (RE_Address), Typ_Tag_Node))),
- Suppress => All_Checks);
-
- Insert_Action (Related_Nod,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Index,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
- Expression =>
- Make_Op_Subtract (Loc,
- Left_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Obj_TSD, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Idepth), Loc)),
-
- Right_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Typ_TSD, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Idepth), Loc)))),
- Suppress => All_Checks);
-
- New_Node :=
- Make_And_Then (Loc,
- Left_Opnd =>
- Make_Op_Ge (Loc,
- Left_Opnd => New_Occurrence_Of (Index, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
-
- Right_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- Make_Indexed_Component (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Obj_TSD, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Tags_Table), Loc)),
- Expressions =>
- New_List (New_Occurrence_Of (Index, Loc))),
-
- Right_Opnd => Typ_Tag_Node));
- end Build_CW_Membership;
-
--------------
-- Build_DT --
--------------
@@ -287,8 +186,9 @@ package body Exp_Atag is
return
Make_Selected_Component (Loc,
Prefix =>
- Build_TSD (Loc,
- Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
+ Make_Explicit_Dereference (Loc,
+ Build_TSD (Loc,
+ Unchecked_Convert_To (RTE (RE_Address), Tag_Node))),
Selector_Name =>
New_Occurrence_Of
(RTE_Record_Component (RE_Access_Level), Loc));
@@ -305,8 +205,10 @@ package body Exp_Atag is
begin
return
Make_Selected_Component (Loc,
- Prefix =>
- Build_TSD (Loc, Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
+ Prefix =>
+ Make_Explicit_Dereference (Loc,
+ Build_TSD (Loc,
+ Unchecked_Convert_To (RTE (RE_Address), Tag_Node))),
Selector_Name =>
New_Occurrence_Of (RTE_Record_Component (RE_Alignment), Loc));
end Build_Get_Alignment;
@@ -358,7 +260,7 @@ package body Exp_Atag is
New_Occurrence_Of
(RTE (RE_DT_Predef_Prims_Offset), Loc)))))),
Expressions =>
- New_List (Make_Integer_Literal (Loc, Position)));
+ New_List (Build_Val (Loc, Position)));
end Build_Get_Predefined_Prim_Op_Address;
-----------------------------
@@ -428,7 +330,7 @@ package body Exp_Atag is
(Node (Last_Elmt (Access_Disp_Table (Typ))),
New_Occurrence_Of (Typ_Tag, Loc))),
Expressions =>
- New_List (Make_Integer_Literal (Loc, Prim_Pos))),
+ New_List (Build_Val (Loc, UI_From_Int (Prim_Pos)))),
Expression =>
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
@@ -566,7 +468,7 @@ package body Exp_Atag is
New_Occurrence_Of (Typ_Tag, Loc))),
Expressions =>
New_List
- (Make_Integer_Literal (Loc, Prim_Pos))),
+ (Build_Val (Loc, UI_From_Int (Prim_Pos)))),
Expression =>
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
@@ -633,28 +535,26 @@ package body Exp_Atag is
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
- Build_DT (Loc, New_Tag_Node),
+ Make_Explicit_Dereference (Loc,
+ Build_DT (Loc, New_Tag_Node)),
Selector_Name =>
New_Occurrence_Of
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Discrete_Range =>
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
+ Build_Range (Loc, 1, Num_Prims)),
Expression =>
Make_Slice (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
- Build_DT (Loc, Old_Tag_Node),
+ Make_Explicit_Dereference (Loc,
+ Build_DT (Loc, Old_Tag_Node)),
Selector_Name =>
New_Occurrence_Of
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Discrete_Range =>
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
+ Build_Range (Loc, 1, Num_Prims)));
else
return
Make_Assignment_Statement (Loc,
@@ -665,9 +565,7 @@ package body Exp_Atag is
(Node (Last_Elmt (Access_Disp_Table (Typ))),
New_Tag_Node),
Discrete_Range =>
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
+ Build_Range (Loc, 1, Num_Prims)),
Expression =>
Make_Slice (Loc,
@@ -676,9 +574,7 @@ package body Exp_Atag is
(Node (Last_Elmt (Access_Disp_Table (Typ))),
Old_Tag_Node),
Discrete_Range =>
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
+ Build_Range (Loc, 1, Num_Prims)));
end if;
end Build_Inherit_Prims;
@@ -715,7 +611,7 @@ package body Exp_Atag is
New_Node :=
Make_Indexed_Component (Loc,
Prefix => New_Prefix,
- Expressions => New_List (Make_Integer_Literal (Loc, Position)));
+ Expressions => New_List (Build_Val (Loc, Position)));
end Build_Get_Prim_Op_Address;
-----------------------------
@@ -730,8 +626,9 @@ package body Exp_Atag is
return
Make_Selected_Component (Loc,
Prefix =>
- Build_TSD (Loc,
- Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
+ Make_Explicit_Dereference (Loc,
+ Build_TSD (Loc,
+ Unchecked_Convert_To (RTE (RE_Address), Tag_Node))),
Selector_Name =>
New_Occurrence_Of
(RTE_Record_Component (RE_Transportable), Loc));
@@ -745,7 +642,7 @@ package body Exp_Atag is
(Loc : Source_Ptr;
Old_Tag_Node : Node_Id;
New_Tag_Node : Node_Id;
- Num_Predef_Prims : Int) return Node_Id
+ Num_Predef_Prims : Nat) return Node_Id
is
begin
return
@@ -758,9 +655,8 @@ package body Exp_Atag is
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Addr_Ptr),
New_Tag_Node)))),
- Discrete_Range => Make_Range (Loc,
- Make_Integer_Literal (Loc, Uint_1),
- Make_Integer_Literal (Loc, Num_Predef_Prims))),
+ Discrete_Range =>
+ Build_Range (Loc, 1, Num_Predef_Prims)),
Expression =>
Make_Slice (Loc,
@@ -771,9 +667,7 @@ package body Exp_Atag is
Unchecked_Convert_To (RTE (RE_Addr_Ptr),
Old_Tag_Node)))),
Discrete_Range =>
- Make_Range (Loc,
- Make_Integer_Literal (Loc, 1),
- Make_Integer_Literal (Loc, Num_Predef_Prims))));
+ Build_Range (Loc, 1, Num_Predef_Prims)));
end Build_Inherit_Predefined_Prims;
-------------------------
@@ -808,6 +702,23 @@ package body Exp_Atag is
(RTE (RE_DT_Offset_To_Top_Offset), Loc)))));
end Build_Offset_To_Top;
+ -----------------
+ -- Build_Range --
+ -----------------
+
+ function Build_Range (Loc : Source_Ptr; Lo, Hi : Nat) return Node_Id is
+ Result : Node_Id;
+
+ begin
+ Result :=
+ Make_Range (Loc,
+ Low_Bound => Build_Val (Loc, UI_From_Int (Lo)),
+ High_Bound => Build_Val (Loc, UI_From_Int (Hi)));
+ Set_Etype (Result, Standard_Natural);
+ Set_Analyzed (Result);
+ return Result;
+ end Build_Range;
+
------------------------------------------
-- Build_Set_Predefined_Prim_Op_Address --
------------------------------------------
@@ -828,7 +739,7 @@ package body Exp_Atag is
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))),
Expressions =>
- New_List (Make_Integer_Literal (Loc, Position))),
+ New_List (Build_Val (Loc, Position))),
Expression => Address_Node);
end Build_Set_Predefined_Prim_Op_Address;
@@ -872,8 +783,9 @@ package body Exp_Atag is
Name =>
Make_Selected_Component (Loc,
Prefix =>
- Build_TSD (Loc,
- Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
+ Make_Explicit_Dereference (Loc,
+ Build_TSD (Loc,
+ Unchecked_Convert_To (RTE (RE_Address), Tag_Node))),
Selector_Name =>
New_Occurrence_Of
(RTE_Record_Component (RE_Size_Func), Loc)),
@@ -939,4 +851,19 @@ package body Exp_Atag is
(RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
end Build_TSD;
+ ---------------
+ -- Build_Val --
+ ---------------
+
+ function Build_Val (Loc : Source_Ptr; V : Uint) return Node_Id is
+ Result : Node_Id;
+
+ begin
+ Result := Make_Integer_Literal (Loc, V);
+ Set_Etype (Result, Standard_Natural);
+ Set_Is_Static_Expression (Result);
+ Set_Analyzed (Result);
+ return Result;
+ end Build_Val;
+
end Exp_Atag;
diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads
index e8d5e62..05e2f8e 100644
--- a/gcc/ada/exp_atag.ads
+++ b/gcc/ada/exp_atag.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -41,24 +41,6 @@ package Exp_Atag is
-- timed, asynchronous, and conditional select and append them to Stmts.
-- Typ is the tagged type used for dispatching calls.
- procedure Build_CW_Membership
- (Loc : Source_Ptr;
- Obj_Tag_Node : in out Node_Id;
- Typ_Tag_Node : Node_Id;
- Related_Nod : Node_Id;
- New_Node : out Node_Id);
- -- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each DT
- -- has a table of ancestors and its inheritance level (Idepth). Obj is in
- -- Typ'Class if Typ'Tag is found in the table of ancestors referenced by
- -- Obj'Tag. Knowing the level of inheritance of both types, this can be
- -- computed in constant time by the formula:
- --
- -- Index := TSD (Obj'Tag).Idepth - TSD (Typ'Tag).Idepth;
- -- Index >= 0 and then TSD (Obj'Tag).Tags_Table (Index) = Typ'Tag
- --
- -- Related_Nod is the node where the implicit declaration of variable Index
- -- is inserted. Obj_Tag_Node is relocated.
-
function Build_Get_Access_Level
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id;
@@ -112,7 +94,7 @@ package Exp_Atag is
(Loc : Source_Ptr;
Old_Tag_Node : Node_Id;
New_Tag_Node : Node_Id;
- Num_Predef_Prims : Int) return Node_Id;
+ Num_Predef_Prims : Nat) return Node_Id;
-- Build code that inherits the predefined primitives of the parent.
--
-- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) :=
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 4057a36..855aa29 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -37,6 +37,7 @@ with Exp_Dist; use Exp_Dist;
with Exp_Imgv; use Exp_Imgv;
with Exp_Pakd; use Exp_Pakd;
with Exp_Strm; use Exp_Strm;
+with Exp_Put_Image;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Expander; use Expander;
@@ -78,8 +79,7 @@ package body Exp_Attr is
function Build_Array_VS_Func
(Attr : Node_Id;
Formal_Typ : Entity_Id;
- Array_Typ : Entity_Id;
- Comp_Typ : Entity_Id) return Entity_Id;
+ Array_Typ : Entity_Id) return Entity_Id;
-- Validate the components of an array type by means of a function. Return
-- the entity of the validation function. The parameters are as follows:
--
@@ -90,8 +90,6 @@ package body Exp_Attr is
-- parameter.
--
-- * Array_Typ - the array type whose components are to be validated
- --
- -- * Comp_Typ - the component type of the array
function Build_Disp_Get_Task_Id_Call (Actual : Node_Id) return Node_Id;
-- Build a call to Disp_Get_Task_Id, passing Actual as actual parameter
@@ -191,10 +189,6 @@ package body Exp_Attr is
procedure Expand_Update_Attribute (N : Node_Id);
-- Handle the expansion of attribute Update
- function Get_Index_Subtype (N : Node_Id) return Entity_Id;
- -- Used for Last, Last, and Length, when the prefix is an array type.
- -- Obtains the corresponding index subtype.
-
procedure Find_Fat_Info
(T : Entity_Id;
Fat_Type : out Entity_Id;
@@ -240,10 +234,11 @@ package body Exp_Attr is
function Build_Array_VS_Func
(Attr : Node_Id;
Formal_Typ : Entity_Id;
- Array_Typ : Entity_Id;
- Comp_Typ : Entity_Id) return Entity_Id
+ Array_Typ : Entity_Id) return Entity_Id
is
- Loc : constant Source_Ptr := Sloc (Attr);
+ Loc : constant Source_Ptr := Sloc (Attr);
+ Comp_Typ : constant Entity_Id :=
+ Validated_View (Component_Type (Array_Typ));
function Validate_Component
(Obj_Id : Entity_Id;
@@ -538,10 +533,7 @@ package body Exp_Attr is
-- Comes_From_Source is not correct because this will eliminate the
-- components within the corresponding record of a protected type.
- if Nam_In (Field_Nam, Name_uObject,
- Name_uParent,
- Name_uTag)
- then
+ if Field_Nam in Name_uObject | Name_uParent | Name_uTag then
null;
-- Do not process fields without any scalar components
@@ -740,7 +732,7 @@ package body Exp_Attr is
-- Use the root type when dealing with a class-wide type
if Is_Class_Wide_Type (Typ) then
- Typ := Root_Type (Typ);
+ Typ := Validated_View (Root_Type (Typ));
end if;
Typ_Decl := Declaration_Node (Typ);
@@ -946,12 +938,35 @@ package body Exp_Attr is
is
-- The value of the attribute_reference is a record containing two
-- fields: an access to the protected object, and an access to the
- -- subprogram itself. The prefix is a selected component.
+ -- subprogram itself. The prefix is an identifier or a selected
+ -- component.
+
+ function Has_By_Protected_Procedure_Prefixed_View return Boolean;
+ -- Determine whether Pref denotes the prefixed class-wide interface
+ -- view of a procedure with synchronization kind By_Protected_Procedure.
+
+ ----------------------------------------------
+ -- Has_By_Protected_Procedure_Prefixed_View --
+ ----------------------------------------------
+
+ function Has_By_Protected_Procedure_Prefixed_View return Boolean is
+ begin
+ return Nkind (Pref) = N_Selected_Component
+ and then Nkind (Prefix (Pref)) in N_Has_Entity
+ and then Present (Entity (Prefix (Pref)))
+ and then Is_Class_Wide_Type (Etype (Entity (Prefix (Pref))))
+ and then (Is_Synchronized_Interface (Etype (Entity (Prefix (Pref))))
+ or else
+ Is_Protected_Interface (Etype (Entity (Prefix (Pref)))))
+ and then Is_By_Protected_Procedure (Entity (Selector_Name (Pref)));
+ end Has_By_Protected_Procedure_Prefixed_View;
+
+ -- Local variables
Loc : constant Source_Ptr := Sloc (N);
Agg : Node_Id;
Btyp : constant Entity_Id := Base_Type (Typ);
- Sub : Entity_Id;
+ Sub : Entity_Id := Empty;
Sub_Ref : Node_Id;
E_T : constant Entity_Id := Equivalent_Type (Btyp);
Acc : constant Entity_Id :=
@@ -1020,6 +1035,23 @@ package body Exp_Attr is
Attribute_Name => Name_Address);
end if;
+ elsif Has_By_Protected_Procedure_Prefixed_View then
+ Obj_Ref :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Prefix (Pref)),
+ Attribute_Name => Name_Address);
+
+ -- Analyze the object address with expansion disabled. Required
+ -- because its expansion would displace the pointer to the object,
+ -- which is not correct at this stage since the object type is a
+ -- class-wide interface type and we are dispatching a call to a
+ -- thunk (which would erroneously displace the pointer again).
+
+ Expander_Mode_Save_And_Set (False);
+ Analyze (Obj_Ref);
+ Set_Analyzed (Obj_Ref);
+ Expander_Mode_Restore;
+
-- Case where the prefix is not an entity name. Find the
-- version of the protected operation to be called from
-- outside the protected object.
@@ -1036,26 +1068,64 @@ package body Exp_Attr is
Attribute_Name => Name_Address);
end if;
- Sub_Ref :=
- Make_Attribute_Reference (Loc,
- Prefix => Sub,
- Attribute_Name => Name_Access);
+ if Has_By_Protected_Procedure_Prefixed_View then
+ declare
+ Ctrl_Tag : Node_Id := Duplicate_Subexpr (Prefix (Pref));
+ Prim_Addr : Node_Id;
+ Subp : constant Entity_Id := Entity (Selector_Name (Pref));
+ Typ : constant Entity_Id :=
+ Etype (Etype (Entity (Prefix (Pref))));
+ begin
+ -- The target subprogram is a thunk; retrieve its address from
+ -- its secondary dispatch table slot.
+
+ Build_Get_Prim_Op_Address (Loc,
+ Typ => Typ,
+ Tag_Node => Ctrl_Tag,
+ Position => DT_Position (Subp),
+ New_Node => Prim_Addr);
+
+ -- Mark the access to the target subprogram as an access to the
+ -- dispatch table and perform an unchecked type conversion to such
+ -- access type. This is required to allow the backend to properly
+ -- identify and handle the access to the dispatch table slot on
+ -- targets where the dispatch table contains descriptors (instead
+ -- of pointers).
+
+ Set_Is_Dispatch_Table_Entity (Acc);
+ Sub_Ref := Unchecked_Convert_To (Acc, Prim_Addr);
+ Analyze (Sub_Ref);
+
+ Agg :=
+ Make_Aggregate (Loc,
+ Expressions => New_List (Obj_Ref, Sub_Ref));
+ end;
+
+ -- Common case
+
+ else
+ Sub_Ref :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Sub,
+ Attribute_Name => Name_Access);
- -- We set the type of the access reference to the already generated
- -- access_to_subprogram type, and declare the reference analyzed, to
- -- prevent further expansion when the enclosing aggregate is analyzed.
+ -- We set the type of the access reference to the already generated
+ -- access_to_subprogram type, and declare the reference analyzed,
+ -- to prevent further expansion when the enclosing aggregate is
+ -- analyzed.
- Set_Etype (Sub_Ref, Acc);
- Set_Analyzed (Sub_Ref);
+ Set_Etype (Sub_Ref, Acc);
+ Set_Analyzed (Sub_Ref);
- Agg :=
- Make_Aggregate (Loc,
- Expressions => New_List (Obj_Ref, Sub_Ref));
+ Agg :=
+ Make_Aggregate (Loc,
+ Expressions => New_List (Obj_Ref, Sub_Ref));
- -- Sub_Ref has been marked as analyzed, but we still need to make sure
- -- Sub is correctly frozen.
+ -- Sub_Ref has been marked as analyzed, but we still need to make
+ -- sure Sub is correctly frozen.
- Freeze_Before (N, Entity (Sub));
+ Freeze_Before (N, Entity (Sub));
+ end if;
Rewrite (N, Agg);
Analyze_And_Resolve (N, E_T);
@@ -1096,12 +1166,10 @@ package body Exp_Attr is
Selector_Name => Make_Identifier (Loc, Nam));
-- The generated call is given the provided set of parameters, and then
- -- wrapped in a conversion which converts the result to the target type
- -- We use the base type as the target because a range check may be
- -- required.
+ -- wrapped in a conversion which converts the result to the target type.
Rewrite (N,
- Unchecked_Convert_To (Base_Type (Etype (N)),
+ Convert_To (Typ,
Make_Function_Call (Loc,
Name => Fnm,
Parameter_Associations => Args)));
@@ -1436,22 +1504,36 @@ package body Exp_Attr is
Insert_Action (Loop_Stmt, Func_Decl);
Pop_Scope;
- -- The analysis of the condition may have generated itypes
- -- that are now used within the function: Adjust their
- -- scopes accordingly so that their use appears in their
- -- scope of definition.
+ -- The analysis of the condition may have generated entities
+ -- (such as itypes) that are now used within the function.
+ -- Adjust their scopes accordingly so that their use appears
+ -- in their scope of definition.
declare
- Ityp : Entity_Id;
+ Ent : Entity_Id;
begin
- Ityp := First_Entity (Loop_Id);
-
- while Present (Ityp) loop
- if Is_Itype (Ityp) then
- Set_Scope (Ityp, Func_Id);
+ Ent := First_Entity (Loop_Id);
+
+ while Present (Ent) loop
+ -- Various entities that now occur within the function
+ -- need to have their scope reset, but not all entities
+ -- associated with Loop_Id are now inside the function.
+ -- The function entity itself and loop parameters can
+ -- be outside the function, and there may be others.
+ -- It's not clear how the determination of what entity
+ -- scopes need to be adjusted can be made accurately.
+ -- Perhaps it will be necessary to traverse the function
+ -- body to find the exact entities whose scopes need to
+ -- be reset to the function's Entity_Id. ???
+
+ if Ekind (Ent) /= E_Loop_Parameter
+ and then Ent /= Func_Id
+ then
+ Set_Scope (Ent, Func_Id);
end if;
- Next_Entity (Ityp);
+
+ Next_Entity (Ent);
end loop;
end;
@@ -1725,22 +1807,51 @@ package body Exp_Attr is
procedure Expand_N_Attribute_Reference (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
- Btyp : constant Entity_Id := Base_Type (Typ);
Pref : constant Node_Id := Prefix (N);
- Ptyp : constant Entity_Id := Etype (Pref);
Exprs : constant List_Id := Expressions (N);
- Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
- procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
- -- Rewrites a stream attribute for Read, Write or Output with the
- -- procedure call. Pname is the entity for the procedure to call.
+ function Get_Integer_Type (Typ : Entity_Id) return Entity_Id;
+ -- Return a small integer type appropriate for the enumeration type
- ------------------------------
- -- Rewrite_Stream_Proc_Call --
- ------------------------------
+ procedure Rewrite_Attribute_Proc_Call (Pname : Entity_Id);
+ -- Rewrites an attribute for Read, Write, Output, or Put_Image with a
+ -- call to the appropriate TSS procedure. Pname is the entity for the
+ -- procedure to call.
- procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
+ ----------------------
+ -- Get_Integer_Type --
+ ----------------------
+
+ function Get_Integer_Type (Typ : Entity_Id) return Entity_Id is
+ Siz : constant Uint := Esize (Base_Type (Typ));
+ Int_Typ : Entity_Id;
+
+ begin
+ -- We need to accommodate invalid values of the base type since we
+ -- accept them for Enum_Rep and Pos, so we reason on the Esize. And
+ -- we use an unsigned type since the enumeration type is unsigned.
+
+ if Siz <= Esize (Standard_Short_Short_Unsigned) then
+ Int_Typ := Standard_Short_Short_Unsigned;
+
+ elsif Siz <= Esize (Standard_Short_Unsigned) then
+ Int_Typ := Standard_Short_Unsigned;
+
+ elsif Siz <= Esize (Standard_Unsigned) then
+ Int_Typ := Standard_Unsigned;
+
+ else
+ Int_Typ := Standard_Long_Long_Unsigned;
+ end if;
+
+ return Int_Typ;
+ end Get_Integer_Type;
+
+ ---------------------------------
+ -- Rewrite_Attribute_Proc_Call --
+ ---------------------------------
+
+ procedure Rewrite_Attribute_Proc_Call (Pname : Entity_Id) is
Item : constant Node_Id := Next (First (Exprs));
Item_Typ : constant Entity_Id := Etype (Item);
Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
@@ -1835,8 +1946,8 @@ package body Exp_Attr is
end if;
end if;
- -- The stream operation to call may be a renaming created by an
- -- attribute definition clause, and may not be frozen yet. Ensure
+ -- The stream operation to call might be a renaming created by an
+ -- attribute definition clause, and might not be frozen yet. Ensure
-- that it has the necessary extra formals.
if not Is_Frozen (Pname) then
@@ -1851,7 +1962,12 @@ package body Exp_Attr is
Parameter_Associations => Exprs));
Analyze (N);
- end Rewrite_Stream_Proc_Call;
+ end Rewrite_Attribute_Proc_Call;
+
+ Typ : constant Entity_Id := Etype (N);
+ Btyp : constant Entity_Id := Base_Type (Typ);
+ Ptyp : constant Entity_Id := Etype (Pref);
+ Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
-- Start of processing for Expand_N_Attribute_Reference
@@ -1911,8 +2027,8 @@ package body Exp_Attr is
if Is_Protected_Self_Reference (Pref)
and then not
- (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint,
- N_Discriminant_Association)
+ (Nkind (Parent (N)) in N_Index_Or_Discriminant_Constraint
+ | N_Discriminant_Association
and then Nkind (Parent (Parent (Parent (Parent (N))))) =
N_Component_Definition)
@@ -1981,9 +2097,9 @@ package body Exp_Attr is
begin
Obj_Name := N;
- while Nkind_In (Obj_Name, N_Selected_Component,
- N_Indexed_Component,
- N_Slice)
+ while Nkind (Obj_Name) in N_Selected_Component
+ | N_Indexed_Component
+ | N_Slice
loop
Obj_Name := Prefix (Obj_Name);
end loop;
@@ -2151,7 +2267,7 @@ package body Exp_Attr is
begin
Subp := Current_Scope;
- while Ekind_In (Subp, E_Loop, E_Block) loop
+ while Ekind (Subp) in E_Loop | E_Block loop
Subp := Scope (Subp);
end loop;
@@ -2459,12 +2575,20 @@ package body Exp_Attr is
New_Node := Build_Get_Alignment (Loc, New_Node);
+ -- Case where the context is an unchecked conversion to a specific
+ -- integer type. We directly convert from the alignment's type.
+
+ if Nkind (Parent (N)) = N_Unchecked_Type_Conversion then
+ Rewrite (N, New_Node);
+ Analyze_And_Resolve (N);
+ return;
+
-- Case where the context is a specific integer type with which
- -- the original attribute was compatible. The function has a
- -- specific type as well, so to preserve the compatibility we
- -- must convert explicitly.
+ -- the original attribute was compatible. But the alignment has a
+ -- specific type in a-tags.ads (Standard.Natural) so, in order to
+ -- preserve type compatibility, we must convert explicitly.
- if Typ /= Standard_Integer then
+ elsif Typ /= Standard_Natural then
New_Node := Convert_To (Typ, New_Node);
end if;
@@ -2480,6 +2604,19 @@ package body Exp_Attr is
end if;
end Alignment;
+ ---------------------------
+ -- Asm_Input, Asm_Output --
+ ---------------------------
+
+ -- The Asm_Input and Asm_Output attributes are not expanded at this
+ -- stage, but will be eliminated in the expansion of the Asm call,
+ -- see Exp_Intr for details. So the back end will never see them.
+
+ when Attribute_Asm_Input
+ | Attribute_Asm_Output
+ =>
+ null;
+
---------
-- Bit --
---------
@@ -2498,34 +2635,11 @@ package body Exp_Attr is
-- Bit_Position --
------------------
- -- We compute this if a component clause was present, otherwise we leave
- -- the computation up to the back end, since we don't know what layout
- -- will be chosen.
-
- -- Note that the attribute can apply to a naked record component
- -- in generated code (i.e. the prefix is an identifier that
- -- references the component or discriminant entity).
-
- when Attribute_Bit_Position => Bit_Position : declare
- CE : Entity_Id;
-
- begin
- if Nkind (Pref) = N_Identifier then
- CE := Entity (Pref);
- else
- CE := Entity (Selector_Name (Pref));
- end if;
-
- if Known_Static_Component_Bit_Offset (CE) then
- Rewrite (N,
- Make_Integer_Literal (Loc,
- Intval => Component_Bit_Offset (CE)));
- Analyze_And_Resolve (N, Typ);
+ -- We leave the computation up to the back end, since we don't know what
+ -- layout will be chosen if no component clause was specified.
- else
- Apply_Universal_Integer_Attribute_Checks (N);
- end if;
- end Bit_Position;
+ when Attribute_Bit_Position =>
+ Apply_Universal_Integer_Attribute_Checks (N);
------------------
-- Body_Version --
@@ -2768,6 +2882,15 @@ package body Exp_Attr is
Analyze_And_Resolve (N, Id_Kind);
end Caller;
+ --------------------
+ -- Component_Size --
+ --------------------
+
+ -- Component_Size is handled by the back end
+
+ when Attribute_Component_Size =>
+ Apply_Universal_Integer_Attribute_Checks (N);
+
-------------
-- Compose --
-------------
@@ -2811,7 +2934,7 @@ package body Exp_Attr is
-- If the prefix is an access to object, the attribute applies to
-- the designated object, so rewrite with an explicit dereference.
- elsif Is_Access_Type (Etype (Pref))
+ elsif Is_Access_Type (Ptyp)
and then
(not Is_Entity_Name (Pref) or else Is_Object (Entity (Pref)))
then
@@ -2971,24 +3094,10 @@ package body Exp_Attr is
-- Descriptor_Size --
---------------------
- when Attribute_Descriptor_Size =>
-
- -- Attribute Descriptor_Size is handled by the back end when applied
- -- to an unconstrained array type.
-
- if Is_Array_Type (Ptyp)
- and then not Is_Constrained (Ptyp)
- then
- Apply_Universal_Integer_Attribute_Checks (N);
-
- -- For any other type, the descriptor size is 0 because there is no
- -- actual descriptor, but the result is not formally static.
+ -- Descriptor_Size is handled by the back end
- else
- Rewrite (N, Make_Integer_Literal (Loc, 0));
- Analyze (N);
- Set_Is_Static_Expression (N, False);
- end if;
+ when Attribute_Descriptor_Size =>
+ Apply_Universal_Integer_Attribute_Checks (N);
---------------
-- Elab_Body --
@@ -3138,32 +3247,8 @@ package body Exp_Attr is
Expr := Pref;
end if;
- -- If the expression is an enumeration literal, it is replaced by the
- -- literal value.
-
- if Nkind (Expr) in N_Has_Entity
- and then Ekind (Entity (Expr)) = E_Enumeration_Literal
- then
- Rewrite (N,
- Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Expr))));
-
- -- If this is a renaming of a literal, recover the representation
- -- of the original. If it renames an expression there is nothing to
- -- fold.
-
- elsif Nkind (Expr) in N_Has_Entity
- and then Ekind (Entity (Expr)) = E_Constant
- and then Present (Renamed_Object (Entity (Expr)))
- and then Is_Entity_Name (Renamed_Object (Entity (Expr)))
- and then Ekind (Entity (Renamed_Object (Entity (Expr)))) =
- E_Enumeration_Literal
- then
- Rewrite (N,
- Make_Integer_Literal (Loc,
- Enumeration_Rep (Entity (Renamed_Object (Entity (Expr))))));
-
- -- If not constant-folded above, Enum_Type'Enum_Rep (X) or
- -- X'Enum_Rep expands to
+ -- If not constant-folded, Enum_Type'Enum_Rep (X) or X'Enum_Rep
+ -- expands to
-- target-type (X)
@@ -3174,11 +3259,19 @@ package body Exp_Attr is
-- make sure that the analyzer does not complain about what otherwise
-- might be an illegal conversion.
+ -- However the target type is universal integer in most cases, which
+ -- is a very large type, so in the case of an enumeration type, we
+ -- first convert to a small signed integer type in order not to lose
+ -- the size information.
+
+ if Is_Enumeration_Type (Ptyp) then
+ Rewrite (N, OK_Convert_To (Get_Integer_Type (Ptyp), Expr));
+ Convert_To_And_Rewrite (Typ, N);
+
else
- Rewrite (N, OK_Convert_To (Typ, Relocate_Node (Expr)));
+ Rewrite (N, OK_Convert_To (Typ, Expr));
end if;
- Set_Etype (N, Typ);
Analyze_And_Resolve (N, Typ);
end Enum_Rep;
@@ -3269,11 +3362,10 @@ package body Exp_Attr is
function Calculate_Header_Size return Node_Id is
begin
-- Generate:
- -- Universal_Integer
- -- (Header_Size_With_Padding (Pref'Alignment))
+ -- Typ (Header_Size_With_Padding (Pref'Alignment))
return
- Convert_To (Universal_Integer,
+ Convert_To (Typ,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Header_Size_With_Padding), Loc),
@@ -3301,9 +3393,7 @@ package body Exp_Attr is
-- Size : Integer := 0;
--
-- if Needs_Finalization (Pref'Tag) then
- -- Size :=
- -- Universal_Integer
- -- (Header_Size_With_Padding (Pref'Alignment));
+ -- Size := Integer (Header_Size_With_Padding (Pref'Alignment));
-- end if;
--
-- and the attribute reference is replaced with a reference to Size.
@@ -3325,8 +3415,7 @@ package body Exp_Attr is
-- Generate:
-- if Needs_Finalization (Pref'Tag) then
-- Size :=
- -- Universal_Integer
- -- (Header_Size_With_Padding (Pref'Alignment));
+ -- Integer (Header_Size_With_Padding (Pref'Alignment));
-- end if;
Make_If_Statement (Loc,
@@ -3343,7 +3432,9 @@ package body Exp_Attr is
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Size, Loc),
- Expression => Calculate_Header_Size)))));
+ Expression =>
+ Convert_To
+ (Standard_Integer, Calculate_Header_Size))))));
Rewrite (N, New_Occurrence_Of (Size, Loc));
@@ -3367,42 +3458,80 @@ package body Exp_Attr is
Analyze_And_Resolve (N, Typ);
end Finalization_Size;
- -----------
- -- First --
- -----------
-
- when Attribute_First =>
+ -----------------
+ -- First, Last --
+ -----------------
+ when Attribute_First
+ | Attribute_Last
+ =>
-- If the prefix type is a constrained packed array type which
-- already has a Packed_Array_Impl_Type representation defined, then
- -- replace this attribute with a direct reference to 'First of the
- -- appropriate index subtype (since otherwise the back end will try
- -- to give us the value of 'First for this implementation type).
+ -- replace this attribute with a direct reference to the attribute of
+ -- the appropriate index subtype (since otherwise the back end will
+ -- try to give us the value of 'First for this implementation type).
if Is_Constrained_Packed_Array (Ptyp) then
Rewrite (N,
Make_Attribute_Reference (Loc,
- Attribute_Name => Name_First,
+ Attribute_Name => Attribute_Name (N),
Prefix =>
New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
Analyze_And_Resolve (N, Typ);
+ -- For a constrained array type, if the bound is a reference to an
+ -- entity which is not a discriminant, just replace with a direct
+ -- reference. Note that this must be in keeping with what is done
+ -- for scalar types in order for range checks to be elided in loops.
+
+ -- However, avoid doing it if the array type is public because, in
+ -- this case, we effectively rely on the back end to create public
+ -- symbols with consistent names across units for the array bounds.
+
+ elsif Is_Array_Type (Ptyp)
+ and then Is_Constrained (Ptyp)
+ and then not Is_Public (Ptyp)
+ then
+ declare
+ Bnd : Node_Id;
+
+ begin
+ if Id = Attribute_First then
+ Bnd := Type_Low_Bound (Get_Index_Subtype (N));
+ else
+ Bnd := Type_High_Bound (Get_Index_Subtype (N));
+ end if;
+
+ if Is_Entity_Name (Bnd)
+ and then Ekind (Entity (Bnd)) /= E_Discriminant
+ then
+ Rewrite (N, New_Occurrence_Of (Entity (Bnd), Loc));
+ end if;
+ end;
+
-- For access type, apply access check as needed
elsif Is_Access_Type (Ptyp) then
Apply_Access_Check (N);
- -- For scalar type, if low bound is a reference to an entity, just
+ -- For scalar type, if the bound is a reference to an entity, just
-- replace with a direct reference. Note that we can only have a
-- reference to a constant entity at this stage, anything else would
-- have already been rewritten.
elsif Is_Scalar_Type (Ptyp) then
declare
- Lo : constant Node_Id := Type_Low_Bound (Ptyp);
+ Bnd : Node_Id;
+
begin
- if Is_Entity_Name (Lo) then
- Rewrite (N, New_Occurrence_Of (Entity (Lo), Loc));
+ if Id = Attribute_First then
+ Bnd := Type_Low_Bound (Ptyp);
+ else
+ Bnd := Type_High_Bound (Ptyp);
+ end if;
+
+ if Is_Entity_Name (Bnd) then
+ Rewrite (N, New_Occurrence_Of (Entity (Bnd), Loc));
end if;
end;
end if;
@@ -3411,42 +3540,11 @@ package body Exp_Attr is
-- First_Bit --
---------------
- -- Compute this if component clause was present, otherwise we leave the
- -- computation to be completed in the back-end, since we don't know what
- -- layout will be chosen.
-
- when Attribute_First_Bit => First_Bit_Attr : declare
- CE : constant Entity_Id := Entity (Selector_Name (Pref));
-
- begin
- -- In Ada 2005 (or later) if we have the non-default bit order, then
- -- we return the original value as given in the component clause
- -- (RM 2005 13.5.2(3/2)).
-
- if Present (Component_Clause (CE))
- and then Ada_Version >= Ada_2005
- and then Reverse_Bit_Order (Scope (CE))
- then
- Rewrite (N,
- Make_Integer_Literal (Loc,
- Intval => Expr_Value (First_Bit (Component_Clause (CE)))));
- Analyze_And_Resolve (N, Typ);
-
- -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
- -- rewrite with normalized value if we know it statically.
-
- elsif Known_Static_Component_Bit_Offset (CE) then
- Rewrite (N,
- Make_Integer_Literal (Loc,
- Component_Bit_Offset (CE) mod System_Storage_Unit));
- Analyze_And_Resolve (N, Typ);
-
- -- Otherwise left to back end, just do universal integer checks
+ -- We leave the computation up to the back end, since we don't know what
+ -- layout will be chosen if no component clause was specified.
- else
- Apply_Universal_Integer_Attribute_Checks (N);
- end if;
- end First_Bit_Attr;
+ when Attribute_First_Bit =>
+ Apply_Universal_Integer_Attribute_Checks (N);
--------------------------------
-- Fixed_Value, Integer_Value --
@@ -3550,16 +3648,15 @@ package body Exp_Attr is
--------------
when Attribute_From_Any => From_Any : declare
- P_Type : constant Entity_Id := Etype (Pref);
Decls : constant List_Id := New_List;
begin
Rewrite (N,
- Build_From_Any_Call (P_Type,
+ Build_From_Any_Call (Ptyp,
Relocate_Node (First (Exprs)),
Decls));
Insert_Actions (N, Decls);
- Analyze_And_Resolve (N, P_Type);
+ Analyze_And_Resolve (N, Ptyp);
end From_Any;
----------------------
@@ -3586,6 +3683,7 @@ package body Exp_Attr is
-- (X'address = Y'address)
-- and then (X'Size = Y'Size)
+ -- and then (X'Size /= 0) (AI12-0077)
-- If both arguments have the same Etype the second conjunct can be
-- omitted.
@@ -3605,27 +3703,39 @@ package body Exp_Attr is
Attribute_Name => Name_Size,
Prefix => New_Copy_Tree (X));
- Y_Size :=
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Size,
- Prefix => New_Copy_Tree (Y));
-
if Etype (X) = Etype (Y) then
Rewrite (N,
- Make_Op_Eq (Loc,
- Left_Opnd => X_Addr,
- Right_Opnd => Y_Addr));
+ Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => X_Addr,
+ Right_Opnd => Y_Addr),
+ Right_Opnd =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => X_Size,
+ Right_Opnd => Make_Integer_Literal (Loc, 0))));
else
+ Y_Size :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Size,
+ Prefix => New_Copy_Tree (Y));
+
Rewrite (N,
- Make_Op_And (Loc,
+ Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd => X_Addr,
Right_Opnd => Y_Addr),
Right_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd => X_Size,
- Right_Opnd => Y_Size)));
+ Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => X_Size,
+ Right_Opnd => Y_Size),
+ Right_Opnd =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => New_Copy_Tree (X_Size),
+ Right_Opnd => Make_Integer_Literal (Loc, 0)))));
end if;
Analyze_And_Resolve (N, Standard_Boolean);
@@ -3687,8 +3797,6 @@ package body Exp_Attr is
-- Image --
-----------
- -- Image attribute is handled in separate unit Exp_Imgv
-
when Attribute_Image =>
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
@@ -3698,7 +3806,7 @@ package body Exp_Attr is
return;
end if;
- Expand_Image_Attribute (N);
+ Exp_Imgv.Expand_Image_Attribute (N);
---------
-- Img --
@@ -3707,7 +3815,26 @@ package body Exp_Attr is
-- X'Img is expanded to typ'Image (X), where typ is the type of X
when Attribute_Img =>
- Expand_Image_Attribute (N);
+ Exp_Imgv.Expand_Image_Attribute (N);
+
+ -----------------
+ -- Initialized --
+ -----------------
+
+ -- For execution, we could either implement an approximation of this
+ -- aspect, or use Valid_Scalars as a first approximation. For now we do
+ -- the latter.
+
+ when Attribute_Initialized =>
+ Rewrite
+ (N,
+ Make_Attribute_Reference
+ (Sloc => Loc,
+ Prefix => Pref,
+ Attribute_Name => Name_Valid_Scalars,
+ Expressions => Exprs));
+
+ Analyze_And_Resolve (N);
-----------
-- Input --
@@ -3837,26 +3964,18 @@ package body Exp_Attr is
-- A special case arises if we have a defined _Read routine,
-- since in this case we are required to call this routine.
- declare
- Typ : Entity_Id := P_Type;
- begin
- if Present (Full_View (Typ)) then
- Typ := Full_View (Typ);
- end if;
-
- if Present (TSS (Base_Type (Typ), TSS_Stream_Read)) then
- Build_Record_Or_Elementary_Input_Function
- (Loc, Typ, Decl, Fname, Use_Underlying => False);
- Insert_Action (N, Decl);
+ if Present (Find_Inherited_TSS (P_Type, TSS_Stream_Read)) then
+ Build_Record_Or_Elementary_Input_Function
+ (Loc, P_Type, Decl, Fname);
+ Insert_Action (N, Decl);
- -- For normal cases, we call the I_xxx routine directly
+ -- For normal cases, we call the I_xxx routine directly
- else
- Rewrite (N, Build_Elementary_Input_Call (N));
- Analyze_And_Resolve (N, P_Type);
- return;
- end if;
- end;
+ else
+ Rewrite (N, Build_Elementary_Input_Call (N));
+ Analyze_And_Resolve (N, P_Type);
+ return;
+ end if;
-- Array type case
@@ -4051,88 +4170,15 @@ package body Exp_Attr is
Analyze_And_Resolve (N);
- ----------
- -- Last --
- ----------
-
- when Attribute_Last =>
-
- -- If the prefix type is a constrained packed array type which
- -- already has a Packed_Array_Impl_Type representation defined, then
- -- replace this attribute with a direct reference to 'Last of the
- -- appropriate index subtype (since otherwise the back end will try
- -- to give us the value of 'Last for this implementation type).
-
- if Is_Constrained_Packed_Array (Ptyp) then
- Rewrite (N,
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Last,
- Prefix => New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
- Analyze_And_Resolve (N, Typ);
-
- -- For access type, apply access check as needed
-
- elsif Is_Access_Type (Ptyp) then
- Apply_Access_Check (N);
-
- -- For scalar type, if low bound is a reference to an entity, just
- -- replace with a direct reference. Note that we can only have a
- -- reference to a constant entity at this stage, anything else would
- -- have already been rewritten.
-
- elsif Is_Scalar_Type (Ptyp) then
- declare
- Hi : constant Node_Id := Type_High_Bound (Ptyp);
- begin
- if Is_Entity_Name (Hi) then
- Rewrite (N, New_Occurrence_Of (Entity (Hi), Loc));
- end if;
- end;
- end if;
-
--------------
-- Last_Bit --
--------------
- -- We compute this if a component clause was present, otherwise we leave
- -- the computation up to the back end, since we don't know what layout
- -- will be chosen.
-
- when Attribute_Last_Bit => Last_Bit_Attr : declare
- CE : constant Entity_Id := Entity (Selector_Name (Pref));
-
- begin
- -- In Ada 2005 (or later) if we have the non-default bit order, then
- -- we return the original value as given in the component clause
- -- (RM 2005 13.5.2(3/2)).
-
- if Present (Component_Clause (CE))
- and then Ada_Version >= Ada_2005
- and then Reverse_Bit_Order (Scope (CE))
- then
- Rewrite (N,
- Make_Integer_Literal (Loc,
- Intval => Expr_Value (Last_Bit (Component_Clause (CE)))));
- Analyze_And_Resolve (N, Typ);
-
- -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
- -- rewrite with normalized value if we know it statically.
-
- elsif Known_Static_Component_Bit_Offset (CE)
- and then Known_Static_Esize (CE)
- then
- Rewrite (N,
- Make_Integer_Literal (Loc,
- Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
- + Esize (CE) - 1));
- Analyze_And_Resolve (N, Typ);
+ -- We leave the computation up to the back end, since we don't know what
+ -- layout will be chosen if no component clause was specified.
- -- Otherwise leave to back end, just apply universal integer checks
-
- else
- Apply_Universal_Integer_Attribute_Checks (N);
- end if;
- end Last_Bit_Attr;
+ when Attribute_Last_Bit =>
+ Apply_Universal_Integer_Attribute_Checks (N);
------------------
-- Leading_Part --
@@ -4411,6 +4457,7 @@ package body Exp_Attr is
when Attribute_Max_Size_In_Storage_Elements => declare
Typ : constant Entity_Id := Etype (N);
Attr : Node_Id;
+ Atyp : Entity_Id;
Conversion_Added : Boolean := False;
-- A flag which tracks whether the original attribute has been
@@ -4451,16 +4498,17 @@ package body Exp_Attr is
then
Set_Header_Size_Added (Attr);
+ Atyp := Etype (Attr);
+
-- Generate:
-- P'Max_Size_In_Storage_Elements +
- -- Universal_Integer
- -- (Header_Size_With_Padding (Ptyp'Alignment))
+ -- Atyp (Header_Size_With_Padding (Ptyp'Alignment))
Rewrite (Attr,
Make_Op_Add (Loc,
Left_Opnd => Relocate_Node (Attr),
Right_Opnd =>
- Convert_To (Universal_Integer,
+ Convert_To (Atyp,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of
@@ -4472,16 +4520,14 @@ package body Exp_Attr is
New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Alignment))))));
+ Analyze_And_Resolve (Attr, Atyp);
+
-- Add a conversion to the target type
if not Conversion_Added then
- Rewrite (Attr,
- Make_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Typ, Loc),
- Expression => Relocate_Node (Attr)));
+ Convert_To_And_Rewrite (Typ, Attr);
end if;
- Analyze (Attr);
return;
end if;
end;
@@ -4616,6 +4662,7 @@ package body Exp_Attr is
Typ : constant Entity_Id := Etype (N);
CW_Temp : Entity_Id;
CW_Typ : Entity_Id;
+ Decl : Node_Id;
Ins_Nod : Node_Id;
Subp : Node_Id;
Temp : Entity_Id;
@@ -4714,13 +4761,15 @@ package body Exp_Attr is
CW_Temp := Make_Temporary (Loc, 'T');
CW_Typ := Class_Wide_Type (Typ);
- Insert_Before_And_Analyze (Ins_Nod,
+ Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => CW_Temp,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
Expression =>
- Convert_To (CW_Typ, Relocate_Node (Pref))));
+ Convert_To (CW_Typ, Relocate_Node (Pref)));
+
+ Insert_Before_And_Analyze (Ins_Nod, Decl);
-- Generate:
-- Temp : Typ renames Typ (CW_Temp);
@@ -4732,18 +4781,23 @@ package body Exp_Attr is
Name =>
Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))));
+ Set_Stores_Attribute_Old_Prefix (CW_Temp);
+
-- Non-tagged case
else
-- Generate:
-- Temp : constant Typ := Pref;
- Insert_Before_And_Analyze (Ins_Nod,
+ Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Typ, Loc),
- Expression => Relocate_Node (Pref)));
+ Expression => Relocate_Node (Pref));
+
+ Insert_Before_And_Analyze (Ins_Nod, Decl);
+
end if;
if Present (Subp) then
@@ -4755,7 +4809,7 @@ package body Exp_Attr is
-- to reflect the new placement of the prefix.
if Validity_Checks_On and then Validity_Check_Operands then
- Ensure_Valid (Pref);
+ Ensure_Valid (Expression (Decl));
end if;
Rewrite (N, New_Occurrence_Of (Temp, Loc));
@@ -4767,27 +4821,31 @@ package body Exp_Attr is
when Attribute_Overlaps_Storage => Overlaps_Storage : declare
Loc : constant Source_Ptr := Sloc (N);
+ X : constant Node_Id := Prefix (N);
+ Y : constant Node_Id := First (Expressions (N));
- X : constant Node_Id := Prefix (N);
- Y : constant Node_Id := First (Expressions (N));
-- The arguments
X_Addr, Y_Addr : Node_Id;
- -- the expressions for their integer addresses
+
+ -- The expressions for their integer addresses
X_Size, Y_Size : Node_Id;
- -- the expressions for their sizes
+
+ -- The expressions for their sizes
Cond : Node_Id;
begin
-- Attribute expands into:
- -- if X'Address < Y'address then
- -- (X'address + X'Size - 1) >= Y'address
- -- else
- -- (Y'address + Y'size - 1) >= X'Address
- -- end if;
+ -- (if X'Size = 0 or else Y'Size = 0 then
+ -- False
+ -- else
+ -- (if X'Address <= Y'Address then
+ -- (X'Address + X'Size - 1) >= Y'Address
+ -- else
+ -- (Y'Address + Y'Size - 1) >= X'Address))
-- with the proper address operations. We convert addresses to
-- integer addresses to use predefined arithmetic. The size is
@@ -4830,29 +4888,62 @@ package body Exp_Attr is
Left_Opnd => X_Addr,
Right_Opnd => Y_Addr);
+ -- Perform the rewriting
+
Rewrite (N,
Make_If_Expression (Loc, New_List (
- Cond,
- Make_Op_Ge (Loc,
- Left_Opnd =>
- Make_Op_Add (Loc,
- Left_Opnd => New_Copy_Tree (X_Addr),
- Right_Opnd =>
- Make_Op_Subtract (Loc,
- Left_Opnd => X_Size,
- Right_Opnd => Make_Integer_Literal (Loc, 1))),
- Right_Opnd => Y_Addr),
+ -- Generate a check for zero-sized things like a null record with
+ -- size zero or an array with zero length since they have no
+ -- opportunity of overlapping.
+
+ -- Without this check, a zero-sized object can trigger a false
+ -- runtime result if it's compared against another object in
+ -- its declarative region, due to the zero-sized object having
+ -- the same address.
- Make_Op_Ge (Loc,
+ Make_Or_Else (Loc,
Left_Opnd =>
- Make_Op_Add (Loc,
- Left_Opnd => New_Copy_Tree (Y_Addr),
- Right_Opnd =>
- Make_Op_Subtract (Loc,
- Left_Opnd => Y_Size,
- Right_Opnd => Make_Integer_Literal (Loc, 1))),
- Right_Opnd => X_Addr))));
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Size,
+ Prefix => New_Copy_Tree (X)),
+ Right_Opnd => Make_Integer_Literal (Loc, 0)),
+ Right_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Size,
+ Prefix => New_Copy_Tree (Y)),
+ Right_Opnd => Make_Integer_Literal (Loc, 0))),
+
+ New_Occurrence_Of (Standard_False, Loc),
+
+ -- Non-zero-size overlap check
+
+ Make_If_Expression (Loc, New_List (
+ Cond,
+
+ Make_Op_Ge (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Copy_Tree (X_Addr),
+ Right_Opnd =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd => X_Size,
+ Right_Opnd => Make_Integer_Literal (Loc, 1))),
+ Right_Opnd => Y_Addr),
+
+ Make_Op_Ge (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Copy_Tree (Y_Addr),
+ Right_Opnd =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd => Y_Size,
+ Right_Opnd => Make_Integer_Literal (Loc, 1))),
+ Right_Opnd => X_Addr))))));
Analyze_And_Resolve (N, Standard_Boolean);
end Overlaps_Storage;
@@ -4943,26 +5034,18 @@ package body Exp_Attr is
-- A special case arises if we have a defined _Write routine,
-- since in this case we are required to call this routine.
- declare
- Typ : Entity_Id := P_Type;
- begin
- if Present (Full_View (Typ)) then
- Typ := Full_View (Typ);
- end if;
+ if Present (Find_Inherited_TSS (P_Type, TSS_Stream_Write)) then
+ Build_Record_Or_Elementary_Output_Procedure
+ (Loc, P_Type, Decl, Pname);
+ Insert_Action (N, Decl);
- if Present (TSS (Base_Type (Typ), TSS_Stream_Write)) then
- Build_Record_Or_Elementary_Output_Procedure
- (Loc, Typ, Decl, Pname);
- Insert_Action (N, Decl);
+ -- For normal cases, we call the W_xxx routine directly
- -- For normal cases, we call the W_xxx routine directly
-
- else
- Rewrite (N, Build_Elementary_Write_Call (N));
- Analyze (N);
- return;
- end if;
- end;
+ else
+ Rewrite (N, Build_Elementary_Write_Call (N));
+ Analyze (N);
+ return;
+ end if;
-- Array type case
@@ -5084,19 +5167,16 @@ package body Exp_Attr is
-- If we fall through, Pname is the name of the procedure to call
- Rewrite_Stream_Proc_Call (Pname);
+ Rewrite_Attribute_Proc_Call (Pname);
end Output;
---------
-- Pos --
---------
- -- For enumeration types with a standard representation, Pos is
- -- handled by the back end.
-
-- For enumeration types, with a non-standard representation we generate
-- a call to the _Rep_To_Pos function created when the type was frozen.
- -- The call has the form
+ -- The call has the form:
-- _rep_to_pos (expr, flag)
@@ -5104,17 +5184,21 @@ package body Exp_Attr is
-- Program_Error to be raised if the expression has an invalid
-- representation, and False if range checks are suppressed.
- -- For integer types, Pos is equivalent to a simple integer
- -- conversion and we rewrite it as such
+ -- For enumeration types with a standard representation, Pos can be
+ -- rewritten as a simple conversion with Conversion_OK set.
+
+ -- For integer types, Pos is equivalent to a simple integer conversion
+ -- and we rewrite it as such.
when Attribute_Pos => Pos : declare
- Etyp : Entity_Id := Base_Type (Entity (Pref));
+ Expr : constant Node_Id := First (Exprs);
+ Etyp : Entity_Id := Base_Type (Ptyp);
begin
-- Deal with zero/non-zero boolean values
if Is_Boolean_Type (Etyp) then
- Adjust_Condition (First (Exprs));
+ Adjust_Condition (Expr);
Etyp := Standard_Boolean;
Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc));
end if;
@@ -5134,65 +5218,43 @@ package body Exp_Attr is
New_Occurrence_Of (TSS (Etyp, TSS_Rep_To_Pos), Loc),
Parameter_Associations => Exprs)));
- Analyze_And_Resolve (N, Typ);
+ -- Standard enumeration type (replace by conversion)
+
+ -- This is simply a direct conversion from the enumeration type to
+ -- the target integer type, which is treated by the back end as a
+ -- normal integer conversion, treating the enumeration type as an
+ -- integer, which is exactly what we want. We set Conversion_OK to
+ -- make sure that the analyzer does not complain about what might
+ -- be an illegal conversion.
- -- Standard enumeration type (do universal integer check)
+ -- However the target type is universal integer in most cases,
+ -- which is a very large type, so we first convert to a small
+ -- signed integer type in order not to lose the size information.
else
- Apply_Universal_Integer_Attribute_Checks (N);
+ Rewrite (N, OK_Convert_To (Get_Integer_Type (Ptyp), Expr));
+ Convert_To_And_Rewrite (Typ, N);
+
end if;
-- Deal with integer types (replace by conversion)
elsif Is_Integer_Type (Etyp) then
- Rewrite (N, Convert_To (Typ, First (Exprs)));
- Analyze_And_Resolve (N, Typ);
+ Rewrite (N, Convert_To (Typ, Expr));
end if;
+ Analyze_And_Resolve (N, Typ);
end Pos;
--------------
-- Position --
--------------
- -- We compute this if a component clause was present, otherwise we leave
- -- the computation up to the back end, since we don't know what layout
- -- will be chosen.
-
- when Attribute_Position => Position_Attr : declare
- CE : constant Entity_Id := Entity (Selector_Name (Pref));
-
- begin
- if Present (Component_Clause (CE)) then
-
- -- In Ada 2005 (or later) if we have the non-default bit order,
- -- then we return the original value as given in the component
- -- clause (RM 2005 13.5.2(2/2)).
-
- if Ada_Version >= Ada_2005
- and then Reverse_Bit_Order (Scope (CE))
- then
- Rewrite (N,
- Make_Integer_Literal (Loc,
- Intval => Expr_Value (Position (Component_Clause (CE)))));
-
- -- Otherwise (Ada 83 or 95, or default bit order specified in
- -- later Ada version), return the normalized value.
-
- else
- Rewrite (N,
- Make_Integer_Literal (Loc,
- Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
- end if;
-
- Analyze_And_Resolve (N, Typ);
-
- -- If back end is doing things, just apply universal integer checks
+ -- We leave the computation up to the back end, since we don't know what
+ -- layout will be chosen if no component clause was specified.
- else
- Apply_Universal_Integer_Attribute_Checks (N);
- end if;
- end Position_Attr;
+ when Attribute_Position =>
+ Apply_Universal_Integer_Attribute_Checks (N);
----------
-- Pred --
@@ -5204,46 +5266,48 @@ package body Exp_Attr is
when Attribute_Pred => Pred : declare
Etyp : constant Entity_Id := Base_Type (Ptyp);
+ Ityp : Entity_Id;
begin
-
-- For enumeration types with non-standard representations, we
- -- expand typ'Pred (x) into
+ -- expand typ'Pred (x) into:
-- Pos_To_Rep (Rep_To_Pos (x) - 1)
- -- If the representation is contiguous, we compute instead
- -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
- -- The conversion function Enum_Pos_To_Rep is defined on the
- -- base type, not the subtype, so we have to use the base type
- -- explicitly for this and other enumeration attributes.
+ -- if the representation is non-contiguous, and just x - 1 if it is
+ -- after having dealt with constraint checking.
- if Is_Enumeration_Type (Ptyp)
+ if Is_Enumeration_Type (Etyp)
and then Present (Enum_Pos_To_Rep (Etyp))
then
if Has_Contiguous_Rep (Etyp) then
- Rewrite (N,
- Unchecked_Convert_To (Ptyp,
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Integer_Literal (Loc,
- Enumeration_Rep (First_Literal (Ptyp))),
- Right_Opnd =>
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of
- (TSS (Etyp, TSS_Rep_To_Pos), Loc),
+ if not Range_Checks_Suppressed (Ptyp) then
+ Set_Do_Range_Check (First (Exprs), False);
+ Expand_Pred_Succ_Attribute (N);
+ end if;
+
+ if Is_Unsigned_Type (Etyp) then
+ if Esize (Typ) <= Standard_Integer_Size then
+ Ityp := RTE (RE_Unsigned);
+ else
+ Ityp := RTE (RE_Long_Long_Unsigned);
+ end if;
+
+ else
+ if Esize (Etyp) <= Standard_Integer_Size then
+ Ityp := Standard_Integer;
+ else
+ Ityp := Standard_Long_Long_Integer;
+ end if;
+ end if;
- Parameter_Associations =>
- New_List (
- Unchecked_Convert_To (Ptyp,
- Make_Op_Subtract (Loc,
- Left_Opnd =>
- Unchecked_Convert_To (Standard_Integer,
- Relocate_Node (First (Exprs))),
- Right_Opnd =>
- Make_Integer_Literal (Loc, 1))),
- Rep_To_Pos_Flag (Ptyp, Loc))))));
+ Rewrite (N,
+ Unchecked_Convert_To (Etyp,
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To (Ityp, First (Exprs)),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, 1))));
else
-- Add Boolean parameter True, to request program error if
@@ -5267,7 +5331,9 @@ package body Exp_Attr is
Right_Opnd => Make_Integer_Literal (Loc, 1)))));
end if;
- Analyze_And_Resolve (N, Typ);
+ -- Suppress checks since they have all been done above
+
+ Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
-- For floating-point, we transform 'Pred into a call to the Pred
-- floating-point attribute function in Fat_xxx (xxx is root type).
@@ -5405,6 +5471,104 @@ package body Exp_Attr is
Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
end Priority;
+ ---------------
+ -- Put_Image --
+ ---------------
+
+ when Attribute_Put_Image => Put_Image : declare
+ use Exp_Put_Image;
+ U_Type : constant Entity_Id := Underlying_Type (Entity (Pref));
+ Pname : Entity_Id;
+ Decl : Node_Id;
+
+ begin
+ -- If no underlying type, we have an error that will be diagnosed
+ -- elsewhere, so here we just completely ignore the expansion.
+
+ if No (U_Type) then
+ return;
+ end if;
+
+ -- If there is a TSS for Put_Image, just call it. This is true for
+ -- tagged types (if enabled) and if there is a user-specified
+ -- Put_Image.
+
+ Pname := TSS (U_Type, TSS_Put_Image);
+ if No (Pname) then
+ if Is_Tagged_Type (U_Type) and then Is_Derived_Type (U_Type) then
+ Pname := Find_Optional_Prim_Op (U_Type, TSS_Put_Image);
+ else
+ Pname := Find_Inherited_TSS (U_Type, TSS_Put_Image);
+ end if;
+ end if;
+
+ if No (Pname) then
+ -- If Put_Image is disabled, call the "unknown" version
+
+ if not Enable_Put_Image (U_Type) then
+ Rewrite (N, Build_Unknown_Put_Image_Call (N));
+ Analyze (N);
+ return;
+
+ -- For elementary types, we call the routine in System.Put_Images
+ -- directly.
+
+ elsif Is_Elementary_Type (U_Type) then
+ Rewrite (N, Build_Elementary_Put_Image_Call (N));
+ Analyze (N);
+ return;
+
+ elsif Is_Standard_String_Type (U_Type) then
+ Rewrite (N, Build_String_Put_Image_Call (N));
+ Analyze (N);
+ return;
+
+ elsif Is_Array_Type (U_Type) then
+ Build_Array_Put_Image_Procedure (N, U_Type, Decl, Pname);
+ Insert_Action (N, Decl);
+
+ -- Tagged type case, use the primitive Put_Image function. Note
+ -- that this will dispatch in the class-wide case which is what we
+ -- want.
+
+ elsif Is_Tagged_Type (U_Type) then
+ Pname := Find_Optional_Prim_Op (U_Type, TSS_Put_Image);
+
+ -- ????Need Find_Optional_Prim_Op instead of Find_Prim_Op,
+ -- because we might be deriving from a predefined type, which
+ -- currently has Enable_Put_Image False.
+
+ if No (Pname) then
+ Rewrite (N, Build_Unknown_Put_Image_Call (N));
+ Analyze (N);
+ return;
+ end if;
+
+ elsif Is_Protected_Type (U_Type) then
+ Rewrite (N, Build_Protected_Put_Image_Call (N));
+ Analyze (N);
+ return;
+
+ elsif Is_Task_Type (U_Type) then
+ Rewrite (N, Build_Task_Put_Image_Call (N));
+ Analyze (N);
+ return;
+
+ -- All other record type cases
+
+ else
+ pragma Assert (Is_Record_Type (U_Type));
+ Build_Record_Put_Image_Procedure
+ (Loc, Full_Base (U_Type), Decl, Pname);
+ Insert_Action (N, Decl);
+ end if;
+ end if;
+
+ -- If we fall through, Pname is the procedure to be called
+
+ Rewrite_Attribute_Proc_Call (Pname);
+ end Put_Image;
+
------------------
-- Range_Length --
------------------
@@ -5476,18 +5640,18 @@ package body Exp_Attr is
Typ : constant Entity_Id := Etype (N);
New_Loop : Node_Id;
- -- If the prefix is an aggregwte, its unique component is sn
- -- Iterated_Element, and we create a loop out of its itertor.
+ -- If the prefix is an aggregate, its unique component is an
+ -- Iterated_Element, and we create a loop out of its iterator.
begin
if Nkind (Prefix (N)) = N_Aggregate then
declare
Stream : constant Node_Id :=
- First (Component_Associations (Prefix (N)));
+ First (Component_Associations (Prefix (N)));
Id : constant Node_Id := Defining_Identifier (Stream);
Expr : constant Node_Id := Expression (Stream);
Ch : constant Node_Id :=
- First (Discrete_Choices (Stream));
+ First (Discrete_Choices (Stream));
begin
New_Loop := Make_Loop_Statement (Loc,
Iteration_Scheme =>
@@ -5509,9 +5673,9 @@ package body Exp_Attr is
Relocate_Node (Expr))))));
end;
else
- -- If the prefix is a name we construct an element iterwtor
- -- over it. Its expansion will verify that it is an array
- -- or a container with the proper aspects.
+ -- If the prefix is a name, we construct an element iterator
+ -- over it. Its expansion will verify that it is an array or
+ -- a container with the proper aspects.
declare
Iter : Node_Id;
@@ -5735,7 +5899,7 @@ package body Exp_Attr is
end if;
end if;
- Rewrite_Stream_Proc_Call (Pname);
+ Rewrite_Attribute_Proc_Call (Pname);
end Read;
---------
@@ -6003,12 +6167,13 @@ package body Exp_Attr is
if Is_Access_Type (Ptyp) then
if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
Rewrite (N,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
- Attribute_Name => Name_Max,
- Expressions => New_List (
- Make_Integer_Literal (Loc, 0),
- Convert_To (Typ,
+ Convert_To (Typ,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of
+ (Etype (Storage_Size_Variable (Root_Type (Ptyp))), Loc),
+ Attribute_Name => Name_Max,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, 0),
New_Occurrence_Of
(Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
@@ -6061,7 +6226,7 @@ package body Exp_Attr is
else
Rewrite (N,
- OK_Convert_To (Typ,
+ Convert_To (Typ,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (Alloc_Op, Loc),
@@ -6179,42 +6344,49 @@ package body Exp_Attr is
when Attribute_Succ => Succ : declare
Etyp : constant Entity_Id := Base_Type (Ptyp);
+ Ityp : Entity_Id;
begin
-- For enumeration types with non-standard representations, we
- -- expand typ'Succ (x) into
+ -- expand typ'Pred (x) into:
-- Pos_To_Rep (Rep_To_Pos (x) + 1)
- -- If the representation is contiguous, we compute instead
- -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
+ -- if the representation is non-contiguous, and just x + 1 if it is
+ -- after having dealt with constraint checking.
- if Is_Enumeration_Type (Ptyp)
+ if Is_Enumeration_Type (Etyp)
and then Present (Enum_Pos_To_Rep (Etyp))
then
if Has_Contiguous_Rep (Etyp) then
+ if not Range_Checks_Suppressed (Ptyp) then
+ Set_Do_Range_Check (First (Exprs), False);
+ Expand_Pred_Succ_Attribute (N);
+ end if;
+
+ if Is_Unsigned_Type (Etyp) then
+ if Esize (Typ) <= Standard_Integer_Size then
+ Ityp := RTE (RE_Unsigned);
+ else
+ Ityp := RTE (RE_Long_Long_Unsigned);
+ end if;
+
+ else
+ if Esize (Etyp) <= Standard_Integer_Size then
+ Ityp := Standard_Integer;
+ else
+ Ityp := Standard_Long_Long_Integer;
+ end if;
+ end if;
+
Rewrite (N,
- Unchecked_Convert_To (Ptyp,
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Integer_Literal (Loc,
- Enumeration_Rep (First_Literal (Ptyp))),
- Right_Opnd =>
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of
- (TSS (Etyp, TSS_Rep_To_Pos), Loc),
+ Unchecked_Convert_To (Etyp,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To (Ityp, First (Exprs)),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, 1))));
- Parameter_Associations =>
- New_List (
- Unchecked_Convert_To (Ptyp,
- Make_Op_Add (Loc,
- Left_Opnd =>
- Unchecked_Convert_To (Standard_Integer,
- Relocate_Node (First (Exprs))),
- Right_Opnd =>
- Make_Integer_Literal (Loc, 1))),
- Rep_To_Pos_Flag (Ptyp, Loc))))));
else
-- Add Boolean parameter True, to request program error if
-- we have a bad representation on our hands. Add False if
@@ -6237,7 +6409,9 @@ package body Exp_Attr is
Right_Opnd => Make_Integer_Literal (Loc, 1)))));
end if;
- Analyze_And_Resolve (N, Typ);
+ -- Suppress checks since they have all been done above
+
+ Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
-- For floating-point, we transform 'Succ into a call to the Succ
-- floating-point attribute function in Fat_xxx (xxx is root type)
@@ -6413,13 +6587,12 @@ package body Exp_Attr is
------------
when Attribute_To_Any => To_Any : declare
- P_Type : constant Entity_Id := Etype (Pref);
Decls : constant List_Id := New_List;
begin
Rewrite (N,
Build_To_Any_Call
(Loc,
- Convert_To (P_Type,
+ Convert_To (Ptyp,
Relocate_Node (First (Exprs))), Decls));
Insert_Actions (N, Decls);
Analyze_And_Resolve (N, RTE (RE_Any));
@@ -6443,10 +6616,9 @@ package body Exp_Attr is
--------------
when Attribute_TypeCode => TypeCode : declare
- P_Type : constant Entity_Id := Etype (Pref);
Decls : constant List_Id := New_List;
begin
- Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls));
+ Rewrite (N, Build_TypeCode_Call (Loc, Ptyp, Decls));
Insert_Actions (N, Decls);
Analyze_And_Resolve (N, RTE (RE_TypeCode));
end TypeCode;
@@ -6482,63 +6654,112 @@ package body Exp_Attr is
-- Val --
---------
- -- For enumeration types with a standard representation, and for all
- -- other types, Val is handled by the back end. For enumeration types
- -- with a non-standard representation we use the _Pos_To_Rep array that
- -- was created when the type was frozen.
+ -- For enumeration types with a non-standard representation we use the
+ -- _Pos_To_Rep array that was created when the type was frozen, unless
+ -- the representation is contiguous in which case we use an addition.
+
+ -- For enumeration types with a standard representation, Val can be
+ -- rewritten as a simple conversion with Conversion_OK set.
+
+ -- For integer types, Val is equivalent to a simple integer conversion
+ -- and we rewrite it as such.
when Attribute_Val => Val : declare
- Etyp : constant Entity_Id := Base_Type (Entity (Pref));
+ Etyp : constant Entity_Id := Base_Type (Ptyp);
+ Expr : constant Node_Id := First (Exprs);
+ Ityp : Entity_Id;
+ Rtyp : Entity_Id;
begin
- if Is_Enumeration_Type (Etyp)
- and then Present (Enum_Pos_To_Rep (Etyp))
- then
- if Has_Contiguous_Rep (Etyp) then
- declare
- Rep_Node : constant Node_Id :=
- Unchecked_Convert_To (Etyp,
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Integer_Literal (Loc,
- Enumeration_Rep (First_Literal (Etyp))),
- Right_Opnd =>
- (Convert_To (Standard_Integer,
- Relocate_Node (First (Exprs))))));
+ -- Case of enumeration type
- begin
- Rewrite (N,
- Unchecked_Convert_To (Etyp,
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Integer_Literal (Loc,
- Enumeration_Rep (First_Literal (Etyp))),
- Right_Opnd =>
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of
- (TSS (Etyp, TSS_Rep_To_Pos), Loc),
- Parameter_Associations => New_List (
- Rep_Node,
- Rep_To_Pos_Flag (Etyp, Loc))))));
- end;
+ if Is_Enumeration_Type (Etyp) then
- else
+ -- Non-contiguous non-standard enumeration type
+
+ if Present (Enum_Pos_To_Rep (Etyp))
+ and then not Has_Contiguous_Rep (Etyp)
+ then
Rewrite (N,
Make_Indexed_Component (Loc,
- Prefix => New_Occurrence_Of (Enum_Pos_To_Rep (Etyp), Loc),
+ Prefix =>
+ New_Occurrence_Of (Enum_Pos_To_Rep (Etyp), Loc),
Expressions => New_List (
- Convert_To (Standard_Integer,
- Relocate_Node (First (Exprs))))));
- end if;
+ Convert_To (Standard_Integer, Expr))));
- Analyze_And_Resolve (N, Typ);
+ Analyze_And_Resolve (N, Typ);
+
+ -- Standard or contiguous non-standard enumeration type
+
+ else
+ -- If the argument is marked as requiring a range check then
+ -- generate it here, after looking through a conversion to
+ -- universal integer, if any.
+
+ if Do_Range_Check (Expr) then
+ if Present (Enum_Pos_To_Rep (Etyp)) then
+ Rtyp := Enum_Pos_To_Rep (Etyp);
+ else
+ Rtyp := Etyp;
+ end if;
+
+ if Nkind (Expr) = N_Type_Conversion
+ and then Entity (Subtype_Mark (Expr)) = Universal_Integer
+ then
+ Generate_Range_Check
+ (Expression (Expr), Rtyp, CE_Range_Check_Failed);
+
+ else
+ Generate_Range_Check (Expr, Rtyp, CE_Range_Check_Failed);
+ end if;
+
+ Set_Do_Range_Check (Expr, False);
+ end if;
+
+ -- Contiguous non-standard enumeration type
+
+ if Present (Enum_Pos_To_Rep (Etyp)) then
+ if Is_Unsigned_Type (Etyp) then
+ if Esize (Typ) <= Standard_Integer_Size then
+ Ityp := RTE (RE_Unsigned);
+ else
+ Ityp := RTE (RE_Long_Long_Unsigned);
+ end if;
+
+ else
+ if Esize (Etyp) <= Standard_Integer_Size then
+ Ityp := Standard_Integer;
+ else
+ Ityp := Standard_Long_Long_Integer;
+ end if;
+ end if;
+
+ Rewrite (N,
+ Unchecked_Convert_To (Etyp,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Integer_Literal (Loc,
+ Enumeration_Rep (First_Literal (Etyp))),
+ Right_Opnd =>
+ Convert_To (Ityp, Expr))));
+
+ -- Standard enumeration type
+
+ else
+ Rewrite (N, OK_Convert_To (Typ, Expr));
+ end if;
- -- If the argument is marked as requiring a range check then generate
- -- it here.
+ -- Suppress checks since the range check was done above
+ -- and it guarantees that the addition cannot overflow.
- elsif Do_Range_Check (First (Exprs)) then
- Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed);
+ Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
+ end if;
+
+ -- Deal with integer types
+
+ elsif Is_Integer_Type (Etyp) then
+ Rewrite (N, Convert_To (Typ, Expr));
+ Analyze_And_Resolve (N, Typ);
end if;
end Val;
@@ -6917,7 +7138,7 @@ package body Exp_Attr is
if Esize (Ptyp) <= Esize (Standard_Integer) then
PBtyp := Standard_Integer;
else
- PBtyp := Universal_Integer;
+ PBtyp := Standard_Long_Long_Integer;
end if;
Rewrite (N, Make_Range_Test);
@@ -6948,16 +7169,16 @@ package body Exp_Attr is
-------------------
when Attribute_Valid_Scalars => Valid_Scalars : declare
- Val_Typ : constant Entity_Id := Validated_View (Ptyp);
- Comp_Typ : Entity_Id;
- Expr : Node_Id;
+ Val_Typ : constant Entity_Id := Validated_View (Ptyp);
+ Expr : Node_Id;
begin
-- Assume that the prefix does not need validation
Expr := Empty;
- -- Attribute 'Valid_Scalars is not supported on private tagged types
+ -- Attribute 'Valid_Scalars is not supported on private tagged types;
+ -- see a detailed explanation where this attribute is analyzed.
if Is_Private_Type (Ptyp) and then Is_Tagged_Type (Ptyp) then
null;
@@ -6980,25 +7201,26 @@ package body Exp_Attr is
Unchecked_Convert_To (Val_Typ, New_Copy_Tree (Pref)),
Attribute_Name => Name_Valid);
+ -- Required by LLVM although the sizes are the same???
+
+ if Nkind (Prefix (Expr)) = N_Unchecked_Type_Conversion then
+ Set_No_Truncation (Prefix (Expr));
+ end if;
+
-- Validate the scalar components of an array by iterating over all
-- dimensions of the array while checking individual components.
elsif Is_Array_Type (Val_Typ) then
- Comp_Typ := Validated_View (Component_Type (Val_Typ));
-
- if Scalar_Part_Present (Comp_Typ) then
- Expr :=
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of
- (Build_Array_VS_Func
- (Attr => N,
- Formal_Typ => Ptyp,
- Array_Typ => Val_Typ,
- Comp_Typ => Comp_Typ),
- Loc),
- Parameter_Associations => New_List (Pref));
- end if;
+ Expr :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Build_Array_VS_Func
+ (Attr => N,
+ Formal_Typ => Ptyp,
+ Array_Typ => Val_Typ),
+ Loc),
+ Parameter_Associations => New_List (Pref));
-- Validate the scalar components, discriminants of a record type by
-- examining the structure of a record type.
@@ -7032,8 +7254,6 @@ package body Exp_Attr is
-- Value --
-----------
- -- Value attribute is handled in separate unit Exp_Imgv
-
when Attribute_Value =>
Exp_Imgv.Expand_Value_Attribute (N);
@@ -7053,8 +7273,6 @@ package body Exp_Attr is
-- Wide_Image --
----------------
- -- Wide_Image attribute is handled in separate unit Exp_Imgv
-
when Attribute_Wide_Image =>
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
-- back-end knows how to handle this attribute directly.
@@ -7069,8 +7287,6 @@ package body Exp_Attr is
-- Wide_Wide_Image --
---------------------
- -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
-
when Attribute_Wide_Wide_Image =>
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
-- back-end knows how to handle this attribute directly.
@@ -7163,8 +7379,6 @@ package body Exp_Attr is
-- Wide_Wide_Width --
---------------------
- -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
-
when Attribute_Wide_Wide_Width =>
Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide);
@@ -7172,8 +7386,6 @@ package body Exp_Attr is
-- Wide_Width --
----------------
- -- Wide_Width attribute is handled in separate unit Exp_Imgv
-
when Attribute_Wide_Width =>
Exp_Imgv.Expand_Width_Attribute (N, Wide);
@@ -7181,8 +7393,6 @@ package body Exp_Attr is
-- Width --
-----------
- -- Width attribute is handled in separate unit Exp_Imgv
-
when Attribute_Width =>
Exp_Imgv.Expand_Width_Attribute (N, Normal);
@@ -7329,56 +7539,36 @@ package body Exp_Attr is
-- If we fall through, Pname is the procedure to be called
- Rewrite_Stream_Proc_Call (Pname);
+ Rewrite_Attribute_Proc_Call (Pname);
end Write;
- -- Component_Size is handled by the back end, unless the component size
- -- is known at compile time, which is always true in the packed array
- -- case. It is important that the packed array case is handled in the
- -- front end (see Eval_Attribute) since the back end would otherwise get
- -- confused by the equivalent packed array type.
-
- when Attribute_Component_Size =>
- null;
-
-- The following attributes are handled by the back end (except that
-- static cases have already been evaluated during semantic processing,
-- but in any case the back end should not count on this).
- -- The back end also handles the non-class-wide cases of Size
-
- when Attribute_Bit_Order
- | Attribute_Code_Address
- | Attribute_Definite
+ when Attribute_Code_Address
| Attribute_Deref
| Attribute_Null_Parameter
| Attribute_Passed_By_Reference
| Attribute_Pool_Address
- | Attribute_Scalar_Storage_Order
=>
null;
- -- The following attributes are also handled by the back end, but return
- -- a universal integer result, so may need a conversion for checking
- -- that the result is in range.
-
- when Attribute_Aft
- | Attribute_Max_Alignment_For_Allocation
- =>
- Apply_Universal_Integer_Attribute_Checks (N);
-
-- The following attributes should not appear at this stage, since they
-- have already been handled by the analyzer (and properly rewritten
-- with corresponding values or entities to represent the right values)
when Attribute_Abort_Signal
| Attribute_Address_Size
+ | Attribute_Aft
| Attribute_Atomic_Always_Lock_Free
| Attribute_Base
+ | Attribute_Bit_Order
| Attribute_Class
| Attribute_Compiler_Version
| Attribute_Default_Bit_Order
| Attribute_Default_Scalar_Storage_Order
+ | Attribute_Definite
| Attribute_Delta
| Attribute_Denorm
| Attribute_Digits
@@ -7400,6 +7590,7 @@ package body Exp_Attr is
| Attribute_Machine_Overflows
| Attribute_Machine_Radix
| Attribute_Machine_Rounds
+ | Attribute_Max_Alignment_For_Allocation
| Attribute_Maximum_Alignment
| Attribute_Model_Emin
| Attribute_Model_Epsilon
@@ -7414,6 +7605,7 @@ package body Exp_Attr is
| Attribute_Safe_Large
| Attribute_Safe_Last
| Attribute_Safe_Small
+ | Attribute_Scalar_Storage_Order
| Attribute_Scale
| Attribute_Signed_Zeros
| Attribute_Small
@@ -7429,15 +7621,6 @@ package body Exp_Attr is
| Attribute_Word_Size
=>
raise Program_Error;
-
- -- The Asm_Input and Asm_Output attributes are not expanded at this
- -- stage, but will be eliminated in the expansion of the Asm call, see
- -- Exp_Intr for details. So the back end will never see these either.
-
- when Attribute_Asm_Input
- | Attribute_Asm_Output
- =>
- null;
end case;
-- Note: as mentioned earlier, individual sections of the above case
@@ -7480,7 +7663,7 @@ package body Exp_Attr is
Cnam := Name_Last;
end if;
- if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration)
+ if Nkind (P) not in N_Assignment_Statement | N_Object_Declaration
or else not Suppress_Assignment_Checks (P)
then
Insert_Action (N,
@@ -8321,35 +8504,6 @@ package body Exp_Attr is
return BT;
end Full_Base;
- -----------------------
- -- Get_Index_Subtype --
- -----------------------
-
- function Get_Index_Subtype (N : Node_Id) return Node_Id is
- P_Type : Entity_Id := Etype (Prefix (N));
- Indx : Node_Id;
- J : Int;
-
- begin
- if Is_Access_Type (P_Type) then
- P_Type := Designated_Type (P_Type);
- end if;
-
- if No (Expressions (N)) then
- J := 1;
- else
- J := UI_To_Int (Expr_Value (First (Expressions (N))));
- end if;
-
- Indx := First_Index (P_Type);
- while J > 1 loop
- Next_Index (Indx);
- J := J - 1;
- end loop;
-
- return Etype (Indx);
- end Get_Index_Subtype;
-
-------------------------------
-- Get_Stream_Convert_Pragma --
-------------------------------
diff --git a/gcc/ada/exp_attr.ads b/gcc/ada/exp_attr.ads
index 8ca9b10..6181977 100644
--- a/gcc/ada/exp_attr.ads
+++ b/gcc/ada/exp_attr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_cg.adb b/gcc/ada/exp_cg.adb
index 5c06bb4..122a40f 100644
--- a/gcc/ada/exp_cg.adb
+++ b/gcc/ada/exp_cg.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -81,7 +81,7 @@ package body Exp_CG is
-- Determines if E is a predefined primitive operation.
-- Note: This routine should replace the routine with the same name that is
-- currently available in exp_disp because it extends its functionality to
- -- handle fully qualified names ???
+ -- handle fully qualified names. It's actually in Sem_Util. ???
function Slot_Number (Prim : Entity_Id) return Uint;
-- Returns the slot number associated with Prim. For predefined primitives
@@ -261,13 +261,14 @@ package body Exp_CG is
or else TSS_Name = TSS_Stream_Write
or else TSS_Name = TSS_Stream_Input
or else TSS_Name = TSS_Stream_Output
+ or else TSS_Name = TSS_Put_Image
or else TSS_Name = TSS_Deep_Adjust
or else TSS_Name = TSS_Deep_Finalize
then
return True;
elsif not Has_Fully_Qualified_Name (E) then
- if Nam_In (Chars (E), Name_uSize, Name_uAlignment, Name_uAssign)
+ if Chars (E) in Name_uSize | Name_uAlignment | Name_uAssign
or else
(Chars (E) = Name_Op_Eq
and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
diff --git a/gcc/ada/exp_cg.ads b/gcc/ada/exp_cg.ads
index 841b248..f32e73c 100644
--- a/gcc/ada/exp_cg.ads
+++ b/gcc/ada/exp_cg.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_ch10.ads b/gcc/ada/exp_ch10.ads
index 17a0802..3b6dcc4 100644
--- a/gcc/ada/exp_ch10.ads
+++ b/gcc/ada/exp_ch10.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb
index d45cb45..abc91a2 100644
--- a/gcc/ada/exp_ch11.adb
+++ b/gcc/ada/exp_ch11.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1426,9 +1426,9 @@ package body Exp_Ch11 is
-- objects of controlled types, for example. We do not want to clean up
-- the return object.
- if not Nkind_In (Parent (N), N_Accept_Statement,
- N_Extended_Return_Statement,
- N_Package_Body)
+ if Nkind (Parent (N)) not in N_Accept_Statement
+ | N_Extended_Return_Statement
+ | N_Package_Body
and then not Delay_Cleanups (Current_Scope)
and then not Is_Thunk (Current_Scope)
then
@@ -1505,7 +1505,7 @@ package body Exp_Ch11 is
Actions => New_List (
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc))),
- Expression => RCE));
+ Expression => RCE));
else
Rewrite (N,
@@ -1514,7 +1514,7 @@ package body Exp_Ch11 is
Make_Raise_Statement (Loc,
Name => Name (N),
Expression => Expression (N))),
- Expression => RCE));
+ Expression => RCE));
end if;
Analyze_And_Resolve (N, Typ);
diff --git a/gcc/ada/exp_ch11.ads b/gcc/ada/exp_ch11.ads
index afc9a40..e6f7ff6 100644
--- a/gcc/ada/exp_ch11.ads
+++ b/gcc/ada/exp_ch11.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_ch12.adb b/gcc/ada/exp_ch12.adb
index 1b665d9..2c5ac8a 100644
--- a/gcc/ada/exp_ch12.adb
+++ b/gcc/ada/exp_ch12.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_ch12.ads b/gcc/ada/exp_ch12.ads
index 95352d2..c258d75 100644
--- a/gcc/ada/exp_ch12.ads
+++ b/gcc/ada/exp_ch12.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb
index f3da4ee..30f101d 100644
--- a/gcc/ada/exp_ch13.adb
+++ b/gcc/ada/exp_ch13.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_ch13.ads b/gcc/ada/exp_ch13.ads
index c6e591f..843dd4f 100644
--- a/gcc/ada/exp_ch13.ads
+++ b/gcc/ada/exp_ch13.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb
index 2985ada..ff1029c 100644
--- a/gcc/ada/exp_ch2.adb
+++ b/gcc/ada/exp_ch2.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -122,8 +122,6 @@ package body Exp_Ch2 is
Val : Node_Id;
Op : Node_Kind;
- -- Start of processing for Expand_Current_Value
-
begin
if True
@@ -162,11 +160,9 @@ package body Exp_Ch2 is
and then not (Nkind (Parent (N)) = N_Attribute_Reference
and then
- (Nam_In (Attribute_Name (Parent (N)),
- Name_Asm_Input,
- Name_Asm_Output)
+ (Attribute_Name (Parent (N)) in Name_Asm_Input
+ | Name_Asm_Output
or else Prefix (Parent (N)) = N))
-
then
-- Case of Current_Value is a compile time known value
@@ -408,7 +404,7 @@ package body Exp_Ch2 is
-- Set Atomic_Sync_Required if necessary for atomic variable. Note that
-- this processing does NOT apply to Volatile_Full_Access variables.
- if Nkind_In (N, N_Identifier, N_Expanded_Name)
+ if Nkind (N) in N_Identifier | N_Expanded_Name
and then Ekind (E) = E_Variable
and then (Is_Atomic (E) or else Is_Atomic (Etype (E)))
then
@@ -514,8 +510,8 @@ package body Exp_Ch2 is
-- ??? passing a formal as actual for a mode IN formal is
-- considered as an assignment?
- if Nkind_In (Parent (N), N_Procedure_Call_Statement,
- N_Entry_Call_Statement)
+ if Nkind (Parent (N)) in
+ N_Procedure_Call_Statement | N_Entry_Call_Statement
or else (Nkind (Parent (N)) = N_Assignment_Statement
and then N = Name (Parent (N)))
then
@@ -531,9 +527,8 @@ package body Exp_Ch2 is
-- which case there is an implicit dereference, and the formal itself
-- is not being assigned to).
- elsif Nkind_In (Parent (N), N_Selected_Component,
- N_Indexed_Component,
- N_Slice)
+ elsif Nkind (Parent (N)) in
+ N_Selected_Component | N_Indexed_Component | N_Slice
and then N = Prefix (Parent (N))
and then not Is_Access_Type (Etype (N))
and then In_Assignment_Context (Parent (N))
@@ -750,7 +745,7 @@ package body Exp_Ch2 is
begin
-- Simple reference case
- if Nkind_In (N, N_Identifier, N_Expanded_Name) then
+ if Nkind (N) in N_Identifier | N_Expanded_Name then
if Is_Formal (Entity (N)) then
return Entity (N);
diff --git a/gcc/ada/exp_ch2.ads b/gcc/ada/exp_ch2.ads
index db562c9..04487d4 100644
--- a/gcc/ada/exp_ch2.ads
+++ b/gcc/ada/exp_ch2.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 82a58b7..0b601c5 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -37,6 +37,7 @@ with Exp_Ch9; use Exp_Ch9;
with Exp_Dbug; use Exp_Dbug;
with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
+with Exp_Put_Image;
with Exp_Smem; use Exp_Smem;
with Exp_Strm; use Exp_Strm;
with Exp_Tss; use Exp_Tss;
@@ -183,11 +184,11 @@ package body Exp_Ch3 is
-- E is a type, it has components that have no static initialization.
-- if E is an entity, its initial expression is not compile-time known.
- function Init_Formals (Typ : Entity_Id) return List_Id;
+ function Init_Formals (Typ : Entity_Id; Proc_Id : Entity_Id) return List_Id;
-- This function builds the list of formals for an initialization routine.
-- The first formal is always _Init with the given type. For task value
-- record types and types containing tasks, three additional formals are
- -- added:
+ -- added and Proc_Id is decorated with attribute Has_Master_Entity:
--
-- _Master : Master_Id
-- _Chain : in out Activation_Chain
@@ -265,6 +266,7 @@ package body Exp_Ch3 is
-- typSW provides result of 'Write attribute
-- typSI provides result of 'Input attribute
-- typSO provides result of 'Output attribute
+ -- typPI provides result of 'Put_Image attribute
--
-- The following entries are additionally present for non-limited tagged
-- types, and implement additional dispatching operations for predefined
@@ -513,6 +515,76 @@ package body Exp_Ch3 is
end loop;
end Adjust_Discriminants;
+ ------------------------------------------
+ -- Build_Access_Subprogram_Wrapper_Body --
+ ------------------------------------------
+
+ procedure Build_Access_Subprogram_Wrapper_Body
+ (Decl : Node_Id;
+ New_Decl : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Actuals : constant List_Id := New_List;
+ Type_Def : constant Node_Id := Type_Definition (Decl);
+ Type_Id : constant Entity_Id := Defining_Identifier (Decl);
+ Spec_Node : constant Node_Id :=
+ Copy_Subprogram_Spec (Specification (New_Decl));
+ -- This copy creates new identifiers for formals and subprogram.
+
+ Act : Node_Id;
+ Body_Node : Node_Id;
+ Call_Stmt : Node_Id;
+ Ptr : Entity_Id;
+
+ begin
+ if not Expander_Active then
+ return;
+ end if;
+
+ -- Create List of actuals for indirect call. The last parameter of the
+ -- subprogram declaration is the access value for the indirect call.
+
+ Act := First (Parameter_Specifications (Spec_Node));
+
+ while Present (Act) loop
+ exit when Act = Last (Parameter_Specifications (Spec_Node));
+ Append_To (Actuals,
+ Make_Identifier (Loc, Chars (Defining_Identifier (Act))));
+ Next (Act);
+ end loop;
+
+ Ptr :=
+ Defining_Identifier
+ (Last (Parameter_Specifications (Specification (New_Decl))));
+
+ if Nkind (Type_Def) = N_Access_Procedure_Definition then
+ Call_Stmt := Make_Procedure_Call_Statement (Loc,
+ Name =>
+ Make_Explicit_Dereference
+ (Loc, New_Occurrence_Of (Ptr, Loc)),
+ Parameter_Associations => Actuals);
+ else
+ Call_Stmt := Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => Make_Explicit_Dereference
+ (Loc, New_Occurrence_Of (Ptr, Loc)),
+ Parameter_Associations => Actuals));
+ end if;
+
+ Body_Node := Make_Subprogram_Body (Loc,
+ Specification => Spec_Node,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Call_Stmt)));
+
+ -- Place body in list of freeze actions for the type.
+
+ Ensure_Freeze_Node (Type_Id);
+ Append_Freeze_Actions (Type_Id, New_List (Body_Node));
+ end Build_Access_Subprogram_Wrapper_Body;
+
---------------------------
-- Build_Array_Init_Proc --
---------------------------
@@ -728,7 +800,7 @@ package body Exp_Ch3 is
end if;
Body_Stmts := Init_One_Dimension (1);
- Parameters := Init_Formals (A_Type);
+ Parameters := Init_Formals (A_Type, Proc_Id);
Discard_Node (
Make_Subprogram_Body (Loc,
@@ -1209,6 +1281,17 @@ package body Exp_Ch3 is
then
Initialization_Warning (T);
return Empty;
+
+ -- We need to return empty if the type has predicates because
+ -- this would otherwise duplicate calls to the predicate
+ -- function. If the type hasn't been frozen before being
+ -- referenced in the current record, the extraneous call to
+ -- the predicate function would be inserted somewhere before
+ -- the predicate function is elaborated, which would result in
+ -- an invalid tree.
+
+ elsif Has_Predicates (Etype (Comp)) then
+ return Empty;
end if;
elsif Is_Scalar_Type (Etype (Comp)) then
@@ -1893,8 +1976,8 @@ package body Exp_Ch3 is
-- traversing the expression. ???
if Kind = N_Attribute_Reference
- and then Nam_In (Attribute_Name (Default), Name_Unchecked_Access,
- Name_Unrestricted_Access)
+ and then Attribute_Name (Default) in Name_Unchecked_Access
+ | Name_Unrestricted_Access
and then Is_Entity_Name (Prefix (Default))
and then Is_Type (Entity (Prefix (Default)))
and then Entity (Prefix (Default)) = Rec_Type
@@ -1957,7 +2040,7 @@ package body Exp_Ch3 is
end if;
if Needs_Finalization (Typ)
- and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
+ and then Kind not in N_Aggregate | N_Extension_Aggregate
and then not Is_Build_In_Place_Function_Call (Exp)
then
Adj_Call :=
@@ -1978,9 +2061,7 @@ package body Exp_Ch3 is
-- which provides for a better error message.
if Comes_From_Source (Exp)
- and then Has_Predicates (Typ)
- and then not Predicate_Checks_Suppressed (Empty)
- and then not Predicates_Ignored (Typ)
+ and then Predicate_Enabled (Typ)
then
Append (Make_Predicate_Check (Typ, Exp), Res);
end if;
@@ -2230,8 +2311,9 @@ package body Exp_Ch3 is
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
- Unchecked_Convert_To (Acc_Type,
- Make_Identifier (Loc, Name_uO)),
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (Acc_Type,
+ Make_Identifier (Loc, Name_uO))),
Selector_Name =>
New_Occurrence_Of (Iface_Comp, Loc)),
Attribute_Name => Name_Position))))));
@@ -2410,7 +2492,7 @@ package body Exp_Ch3 is
Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
- Parameters := Init_Formals (Rec_Type);
+ Parameters := Init_Formals (Rec_Type, Proc_Id);
Append_List_To (Parameters,
Build_Discriminant_Formals (Rec_Type, True));
@@ -2824,16 +2906,16 @@ package body Exp_Ch3 is
---------------------------
function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
- Checks : constant List_Id := New_List;
- Actions : List_Id := No_List;
- Counter_Id : Entity_Id := Empty;
- Comp_Loc : Source_Ptr;
- Decl : Node_Id;
- Has_POC : Boolean;
- Id : Entity_Id;
- Parent_Stmts : List_Id;
- Stmts : List_Id;
- Typ : Entity_Id;
+ Checks : constant List_Id := New_List;
+ Actions : List_Id := No_List;
+ Counter_Id : Entity_Id := Empty;
+ Comp_Loc : Source_Ptr;
+ Decl : Node_Id;
+ Has_Late_Init_Comp : Boolean;
+ Id : Entity_Id;
+ Parent_Stmts : List_Id;
+ Stmts : List_Id;
+ Typ : Entity_Id;
procedure Increment_Counter (Loc : Source_Ptr);
-- Generate an "increment by one" statement for the current counter
@@ -2844,6 +2926,12 @@ package body Exp_Ch3 is
-- creates a new defining Id, adds an object declaration and sets
-- the Id generator for the next variant.
+ function Requires_Late_Initialization
+ (Decl : Node_Id;
+ Rec_Type : Entity_Id) return Boolean;
+ -- Return whether the given Decl requires late initialization, as
+ -- defined by 3.3.1 (8.1/5).
+
-----------------------
-- Increment_Counter --
-----------------------
@@ -2890,6 +2978,158 @@ package body Exp_Ch3 is
Make_Integer_Literal (Loc, 0)));
end Make_Counter;
+ ----------------------------------
+ -- Requires_Late_Initialization --
+ ----------------------------------
+
+ function Requires_Late_Initialization
+ (Decl : Node_Id;
+ Rec_Type : Entity_Id) return Boolean
+ is
+ References_Current_Instance : Boolean := False;
+ Has_Access_Discriminant : Boolean := False;
+ Has_Internal_Call : Boolean := False;
+
+ function Find_Access_Discriminant
+ (N : Node_Id) return Traverse_Result;
+ -- Look for a name denoting an access discriminant
+
+ function Find_Current_Instance
+ (N : Node_Id) return Traverse_Result;
+ -- Look for a reference to the current instance of the type
+
+ function Find_Internal_Call
+ (N : Node_Id) return Traverse_Result;
+ -- Look for an internal protected function call
+
+ ------------------------------
+ -- Find_Access_Discriminant --
+ ------------------------------
+
+ function Find_Access_Discriminant
+ (N : Node_Id) return Traverse_Result is
+ begin
+ if Is_Entity_Name (N)
+ and then Denotes_Discriminant (N)
+ and then Is_Access_Type (Etype (N))
+ then
+ Has_Access_Discriminant := True;
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Find_Access_Discriminant;
+
+ ---------------------------
+ -- Find_Current_Instance --
+ ---------------------------
+
+ function Find_Current_Instance
+ (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Attribute_Reference
+ and then Is_Access_Type (Etype (N))
+ and then Is_Entity_Name (Prefix (N))
+ and then Is_Type (Entity (Prefix (N)))
+ then
+ References_Current_Instance := True;
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Find_Current_Instance;
+
+ ------------------------
+ -- Find_Internal_Call --
+ ------------------------
+
+ function Find_Internal_Call (N : Node_Id) return Traverse_Result is
+
+ function Call_Scope (N : Node_Id) return Entity_Id;
+ -- Return the scope enclosing a given call node N
+
+ ----------------
+ -- Call_Scope --
+ ----------------
+
+ function Call_Scope (N : Node_Id) return Entity_Id is
+ Nam : constant Node_Id := Name (N);
+ begin
+ if Nkind (Nam) = N_Selected_Component then
+ return Scope (Entity (Prefix (Nam)));
+ else
+ return Scope (Entity (Nam));
+ end if;
+ end Call_Scope;
+
+ begin
+ if Nkind (N) = N_Function_Call
+ and then Call_Scope (N)
+ = Corresponding_Concurrent_Type (Rec_Type)
+ then
+ Has_Internal_Call := True;
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Find_Internal_Call;
+
+ procedure Search_Access_Discriminant is new
+ Traverse_Proc (Find_Access_Discriminant);
+
+ procedure Search_Current_Instance is new
+ Traverse_Proc (Find_Current_Instance);
+
+ procedure Search_Internal_Call is new
+ Traverse_Proc (Find_Internal_Call);
+
+ begin
+ -- A component of an object is said to require late initialization
+ -- if:
+
+ -- it has an access discriminant value constrained by a per-object
+ -- expression;
+
+ if Has_Access_Constraint (Defining_Identifier (Decl))
+ and then No (Expression (Decl))
+ then
+ return True;
+
+ elsif Present (Expression (Decl)) then
+
+ -- it has an initialization expression that includes a name
+ -- denoting an access discriminant;
+
+ Search_Access_Discriminant (Expression (Decl));
+
+ if Has_Access_Discriminant then
+ return True;
+ end if;
+
+ -- or it has an initialization expression that includes a
+ -- reference to the current instance of the type either by
+ -- name...
+
+ Search_Current_Instance (Expression (Decl));
+
+ if References_Current_Instance then
+ return True;
+ end if;
+
+ -- ...or implicitly as the target object of a call.
+
+ if Is_Protected_Record_Type (Rec_Type) then
+ Search_Internal_Call (Expression (Decl));
+
+ if Has_Internal_Call then
+ return True;
+ end if;
+ end if;
+ end if;
+
+ return False;
+ end Requires_Late_Initialization;
+
-- Start of processing for Build_Init_Statements
begin
@@ -2943,10 +3183,9 @@ package body Exp_Ch3 is
-- Loop through components, skipping pragmas, in 2 steps. The first
-- step deals with regular components. The second step deals with
- -- components that have per object constraints and no explicit
- -- initialization.
+ -- components that require late initialization.
- Has_POC := False;
+ Has_Late_Init_Comp := False;
-- First pass : regular components
@@ -2959,11 +3198,11 @@ package body Exp_Ch3 is
Id := Defining_Identifier (Decl);
Typ := Etype (Id);
- -- Leave any processing of per-object constrained component for
- -- the second pass.
+ -- Leave any processing of component requiring late initialization
+ -- for the second pass.
- if Has_Access_Constraint (Id) and then No (Expression (Decl)) then
- Has_POC := True;
+ if Requires_Late_Initialization (Decl, Rec_Type) then
+ Has_Late_Init_Comp := True;
-- Regular component cases
@@ -3004,10 +3243,10 @@ package body Exp_Ch3 is
elsif Ekind (Scope (Id)) = E_Record_Type
and then Present (Corresponding_Concurrent_Type (Scope (Id)))
- and then Nam_In (Chars (Id), Name_uCPU,
- Name_uDispatching_Domain,
- Name_uPriority,
- Name_uSecondary_Stack_Size)
+ and then Chars (Id) in Name_uCPU
+ | Name_uDispatching_Domain
+ | Name_uPriority
+ | Name_uSecondary_Stack_Size
then
declare
Exp : Node_Id;
@@ -3265,19 +3504,21 @@ package body Exp_Ch3 is
Make_Initialize_Protection (Rec_Type));
end if;
- -- Second pass: components with per-object constraints
+ -- Second pass: components that require late initialization
- if Has_POC then
+ if Has_Late_Init_Comp then
Decl := First_Non_Pragma (Component_Items (Comp_List));
while Present (Decl) loop
Comp_Loc := Sloc (Decl);
Id := Defining_Identifier (Decl);
Typ := Etype (Id);
- if Has_Access_Constraint (Id)
- and then No (Expression (Decl))
- then
- if Has_Non_Null_Base_Init_Proc (Typ) then
+ if Requires_Late_Initialization (Decl, Rec_Type) then
+ if Present (Expression (Decl)) then
+ Append_List_To (Stmts,
+ Build_Assignment (Id, Expression (Decl)));
+
+ elsif Has_Non_Null_Base_Init_Proc (Typ) then
Append_List_To (Stmts,
Build_Initialization_Call (Comp_Loc,
Make_Selected_Component (Comp_Loc,
@@ -3300,7 +3541,6 @@ package body Exp_Ch3 is
Increment_Counter (Comp_Loc);
end if;
-
elsif Component_Needs_Simple_Initialization (Typ) then
Append_List_To (Stmts,
Build_Assignment
@@ -4454,6 +4694,8 @@ package body Exp_Ch3 is
procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is
begin
+ -- Move this check to sem???
+
if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then
Error_Msg_Name_1 := Nam;
Error_Msg_N
@@ -4503,6 +4745,47 @@ package body Exp_Ch3 is
end if;
end Clean_Task_Names;
+ ----------------------------------------
+ -- Ensure_Activation_Chain_And_Master --
+ ----------------------------------------
+
+ procedure Ensure_Activation_Chain_And_Master (Obj_Decl : Node_Id) is
+ Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
+ Expr : constant Node_Id := Expression (Obj_Decl);
+ Expr_Q : Node_Id;
+ Typ : constant Entity_Id := Etype (Def_Id);
+
+ begin
+ pragma Assert (Nkind (Obj_Decl) = N_Object_Declaration);
+
+ if Has_Task (Typ) or else Might_Have_Tasks (Typ) then
+ Build_Activation_Chain_Entity (Obj_Decl);
+
+ if Has_Task (Typ) then
+ Build_Master_Entity (Def_Id);
+
+ -- Handle objects initialized with BIP function calls
+
+ elsif Present (Expr) then
+ if Nkind (Expr) = N_Qualified_Expression then
+ Expr_Q := Expression (Expr);
+ else
+ Expr_Q := Expr;
+ end if;
+
+ if Is_Build_In_Place_Function_Call (Expr_Q)
+ or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
+ or else
+ (Nkind (Expr_Q) = N_Reference
+ and then
+ Is_Build_In_Place_Function_Call (Prefix (Expr_Q)))
+ then
+ Build_Master_Entity (Def_Id);
+ end if;
+ end if;
+ end if;
+ end Ensure_Activation_Chain_And_Master;
+
------------------------------
-- Expand_Freeze_Array_Type --
------------------------------
@@ -4670,6 +4953,7 @@ package body Exp_Ch3 is
Ent : Entity_Id;
Fent : Entity_Id;
Is_Contiguous : Boolean;
+ Index_Typ : Entity_Id;
Ityp : Entity_Id;
Last_Repval : Uint;
Lst : List_Id;
@@ -4686,81 +4970,99 @@ package body Exp_Ch3 is
Ent := First_Literal (Typ);
Last_Repval := Enumeration_Rep (Ent);
-
+ Num := 1;
Next_Literal (Ent);
+
while Present (Ent) loop
if Enumeration_Rep (Ent) - Last_Repval /= 1 then
Is_Contiguous := False;
- exit;
else
Last_Repval := Enumeration_Rep (Ent);
end if;
+ Num := Num + 1;
Next_Literal (Ent);
end loop;
if Is_Contiguous then
Set_Has_Contiguous_Rep (Typ);
- Ent := First_Literal (Typ);
- Num := 1;
- Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent)));
+
+ -- Now build a subtype declaration
+
+ -- subtype typI is new Natural range 0 .. num - 1
+
+ Index_Typ :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), 'I'));
+
+ Append_Freeze_Action (Typ,
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Index_Typ,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Standard_Natural, Loc),
+ Constraint =>
+ Make_Range_Constraint (Loc,
+ Range_Expression =>
+ Make_Range (Loc,
+ Low_Bound =>
+ Make_Integer_Literal (Loc, 0),
+ High_Bound =>
+ Make_Integer_Literal (Loc, Num - 1))))));
+
+ Set_Enum_Pos_To_Rep (Typ, Index_Typ);
else
-- Build list of literal references
Lst := New_List;
- Num := 0;
-
Ent := First_Literal (Typ);
while Present (Ent) loop
Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent)));
- Num := Num + 1;
Next_Literal (Ent);
end loop;
- end if;
-
- -- Now build an array declaration
- -- typA : array (Natural range 0 .. num - 1) of ctype :=
- -- (v, v, v, v, v, ....)
+ -- Now build an array declaration
- -- where ctype is the corresponding integer type. If the representation
- -- is contiguous, we only keep the first literal, which provides the
- -- offset for Pos_To_Rep computations.
+ -- typA : constant array (Natural range 0 .. num - 1) of typ :=
+ -- (v, v, v, v, v, ....)
- Arr :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), 'A'));
+ Arr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), 'A'));
- Append_Freeze_Action (Typ,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Arr,
- Constant_Present => True,
-
- Object_Definition =>
- Make_Constrained_Array_Definition (Loc,
- Discrete_Subtype_Definitions => New_List (
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
- Constraint =>
- Make_Range_Constraint (Loc,
- Range_Expression =>
- Make_Range (Loc,
- Low_Bound =>
- Make_Integer_Literal (Loc, 0),
- High_Bound =>
- Make_Integer_Literal (Loc, Num - 1))))),
-
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication => New_Occurrence_Of (Typ, Loc))),
+ Append_Freeze_Action (Typ,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Arr,
+ Constant_Present => True,
+
+ Object_Definition =>
+ Make_Constrained_Array_Definition (Loc,
+ Discrete_Subtype_Definitions => New_List (
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Standard_Natural, Loc),
+ Constraint =>
+ Make_Range_Constraint (Loc,
+ Range_Expression =>
+ Make_Range (Loc,
+ Low_Bound =>
+ Make_Integer_Literal (Loc, 0),
+ High_Bound =>
+ Make_Integer_Literal (Loc, Num - 1))))),
+
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Occurrence_Of (Typ, Loc))),
- Expression =>
- Make_Aggregate (Loc,
- Expressions => Lst)));
+ Expression =>
+ Make_Aggregate (Loc,
+ Expressions => Lst)));
- Set_Enum_Pos_To_Rep (Typ, Arr);
+ Set_Enum_Pos_To_Rep (Typ, Arr);
+ end if;
-- Now we build the function that converts representation values to
-- position values. This function has the form:
@@ -4806,7 +5108,7 @@ package body Exp_Ch3 is
if Esize (Typ) <= Standard_Integer_Size then
Ityp := Standard_Integer;
else
- Ityp := Universal_Integer;
+ Ityp := Standard_Long_Long_Integer;
end if;
-- Representations are unsigned
@@ -5503,7 +5805,7 @@ package body Exp_Ch3 is
-- limited-with'ed package, we need to use the nonlimited view in
-- case it has tasks.
- if Ekind (Desig_Typ) in Incomplete_Kind
+ if Is_Incomplete_Type (Desig_Typ)
and then Present (Non_Limited_View (Desig_Typ))
then
Desig_Typ := Non_Limited_View (Desig_Typ);
@@ -5513,7 +5815,7 @@ package body Exp_Ch3 is
-- record parameter for an entry declaration. No master is created
-- for such a type.
- if Comes_From_Source (N) and then Has_Task (Desig_Typ) then
+ if Has_Task (Desig_Typ) then
Build_Master_Entity (Ptr_Typ);
Build_Master_Renaming (Ptr_Typ);
@@ -5527,12 +5829,11 @@ package body Exp_Ch3 is
-- Suppress the master creation for access types created for entry
-- formal parameters (parameter block component types). Seems like
-- suppression should be more general for compiler-generated types,
- -- but testing Comes_From_Source, like the code above does, may be
- -- too general in this case (affects some test output)???
+ -- but testing Comes_From_Source may be too general in this case
+ -- (affects some test output)???
elsif not Is_Param_Block_Component_Type (Ptr_Typ)
and then Is_Limited_Class_Wide_Type (Desig_Typ)
- and then Tasking_Allowed
then
Build_Class_Wide_Master (Ptr_Typ);
end if;
@@ -5579,7 +5880,7 @@ package body Exp_Ch3 is
declare
Comp : Entity_Id;
First : Boolean;
- M_Id : Entity_Id;
+ M_Id : Entity_Id := Empty;
Typ : Entity_Id;
begin
@@ -5597,7 +5898,10 @@ package body Exp_Ch3 is
Typ := Etype (Comp);
if Ekind (Typ) = E_Anonymous_Access_Type
- and then Has_Task (Available_View (Designated_Type (Typ)))
+ and then
+ (Has_Task (Available_View (Designated_Type (Typ)))
+ or else
+ Might_Have_Tasks (Available_View (Designated_Type (Typ))))
and then No (Master_Id (Typ))
then
-- Ensure that the record or array type have a _master
@@ -5612,6 +5916,7 @@ package body Exp_Ch3 is
-- Reuse the same master to service any additional types
else
+ pragma Assert (Present (M_Id));
Set_Master_Id (Typ, M_Id);
end if;
end if;
@@ -6431,9 +6736,9 @@ package body Exp_Ch3 is
and then Building_Static_Dispatch_Tables
and then Is_Library_Level_Entity (Def_Id)
and then Is_Library_Level_Tagged_Type (Base_Typ)
- and then Ekind_In (Base_Typ, E_Record_Type,
- E_Protected_Type,
- E_Task_Type)
+ and then Ekind (Base_Typ) in E_Record_Type
+ | E_Protected_Type
+ | E_Task_Type
and then not Has_Dispatch_Table (Base_Typ)
then
declare
@@ -6458,15 +6763,12 @@ package body Exp_Ch3 is
Init_After := Make_Shared_Var_Procs (N);
end if;
- -- If tasks being declared, make sure we have an activation chain
+ -- If tasks are being declared, make sure we have an activation chain
-- defined for the tasks (has no effect if we already have one), and
- -- also that a Master variable is established and that the appropriate
- -- enclosing construct is established as a task master.
+ -- also that a Master variable is established (and that the appropriate
+ -- enclosing construct is established as a task master).
- if Has_Task (Typ) then
- Build_Activation_Chain_Entity (N);
- Build_Master_Entity (Def_Id);
- end if;
+ Ensure_Activation_Chain_And_Master (N);
-- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations
-- restrictions are active then default-sized secondary stacks are
@@ -6483,11 +6785,11 @@ package body Exp_Ch3 is
-- of the stacks in this scenario, the stacks of the first array are
-- not counted.
- if Has_Task (Typ)
+ if (Has_Task (Typ) or else Might_Have_Tasks (Typ))
and then not Restriction_Active (No_Secondary_Stack)
and then (Restriction_Active (No_Implicit_Heap_Allocations)
or else Restriction_Active (No_Implicit_Task_Allocations))
- and then not (Ekind_In (Ekind (Typ), E_Array_Type, E_Array_Subtype)
+ and then not (Ekind (Typ) in E_Array_Type | E_Array_Subtype
and then (Has_Init_Expression (N)))
then
declare
@@ -6609,9 +6911,13 @@ package body Exp_Ch3 is
-- An aggregate that must be built in place is not resolved and
-- expanded until the enclosing construct is expanded. This will
-- happen when the aggregate is limited and the declared object
- -- has a following address clause.
+ -- has a following address clause; it happens also when generating
+ -- C code for an aggregate that has an alignment or address clause
+ -- (see Analyze_Object_Declaration).
- if Is_Limited_Type (Typ) and then not Analyzed (Expr) then
+ if (Is_Limited_Type (Typ) or else Modify_Tree_For_C)
+ and then not Analyzed (Expr)
+ then
Resolve (Expr, Typ);
end if;
@@ -7150,21 +7456,32 @@ package body Exp_Ch3 is
Chars =>
New_External_Name (Chars (Def_Id), Suffix => "L"));
- Level_Expr : Node_Id;
Level_Decl : Node_Id;
+ Level_Expr : Node_Id;
begin
Set_Ekind (Level, Ekind (Def_Id));
Set_Etype (Level, Standard_Natural);
Set_Scope (Level, Scope (Def_Id));
- if No (Expr) then
-
- -- Set accessibility level of null
+ -- Set accessibility level of null
+ if No (Expr) then
Level_Expr :=
Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard));
+ -- When the expression of the object is a function which returns
+ -- an anonymous access type the master of the call is the object
+ -- being initialized instead of the type.
+
+ elsif Nkind (Expr) = N_Function_Call
+ and then Ekind (Etype (Name (Expr))) = E_Anonymous_Access_Type
+ then
+ Level_Expr := Make_Integer_Literal (Loc,
+ Object_Access_Level (Def_Id));
+
+ -- General case
+
else
Level_Expr := Dynamic_Accessibility_Level (Expr);
end if;
@@ -7196,6 +7513,7 @@ package body Exp_Ch3 is
and then Has_DIC (Typ)
and then Present (DIC_Procedure (Typ))
and then not Has_Init_Expression (N)
+ and then not Is_Imported (Def_Id)
then
declare
DIC_Call : constant Node_Id := Build_DIC_Call (Loc, Def_Id, Typ);
@@ -7241,9 +7559,7 @@ package body Exp_Ch3 is
-- debug information, even though it is defined by a generated
-- renaming that does not come from source.
- if Comes_From_Source (Defining_Identifier (N)) then
- Set_Debug_Info_Needed (Defining_Identifier (N));
- end if;
+ Set_Debug_Info_Defining_Id (N);
-- Now call the routine to generate debug info for the renaming
@@ -7268,10 +7584,7 @@ package body Exp_Ch3 is
-- Expand_N_Subtype_Indication --
---------------------------------
- -- Add a check on the range of the subtype. The static case is partially
- -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
- -- to check here for the static case in order to avoid generating
- -- extraneous expanded code. Also deal with validity checking.
+ -- Add a check on the range of the subtype and deal with validity checking
procedure Expand_N_Subtype_Indication (N : Node_Id) is
Ran : constant Node_Id := Range_Expression (Constraint (N));
@@ -7282,7 +7595,12 @@ package body Exp_Ch3 is
Validity_Check_Range (Range_Expression (Constraint (N)));
end if;
- if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then
+ -- Do not duplicate the work of Process_Range_Expr_In_Decl in Sem_Ch3
+
+ if Nkind (Parent (N)) in N_Constrained_Array_Definition | N_Slice
+ and then Nkind (Parent (Parent (N))) not in
+ N_Full_Type_Declaration | N_Object_Declaration
+ then
Apply_Range_Check (Ran, Typ);
end if;
end Expand_N_Subtype_Indication;
@@ -7714,7 +8032,7 @@ package body Exp_Ch3 is
-- See GNAT Pool packages in the Run-Time for more details
- elsif Ekind_In (Def_Id, E_Access_Type, E_General_Access_Type) then
+ elsif Ekind (Def_Id) in E_Access_Type | E_General_Access_Type then
declare
Loc : constant Source_Ptr := Sloc (N);
Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
@@ -7833,61 +8151,44 @@ package body Exp_Ch3 is
elsif Ada_Version >= Ada_2012
and then Present (Associated_Storage_Pool (Def_Id))
-
- -- Omit this check for the case of a configurable run-time that
- -- does not provide package System.Storage_Pools.Subpools.
-
- and then RTE_Available (RE_Root_Storage_Pool_With_Subpools)
+ and then RTU_Loaded (System_Storage_Pools_Subpools)
then
declare
Loc : constant Source_Ptr := Sloc (Def_Id);
Pool : constant Entity_Id :=
Associated_Storage_Pool (Def_Id);
- RSPWS : constant Entity_Id :=
- RTE (RE_Root_Storage_Pool_With_Subpools);
begin
-- It is known that the accessibility level of the access
-- type is deeper than that of the pool.
if Type_Access_Level (Def_Id) > Object_Access_Level (Pool)
+ and then Is_Class_Wide_Type (Etype (Pool))
and then not Accessibility_Checks_Suppressed (Def_Id)
and then not Accessibility_Checks_Suppressed (Pool)
then
- -- Static case: the pool is known to be a descendant of
- -- Root_Storage_Pool_With_Subpools.
-
- if Is_Ancestor (RSPWS, Etype (Pool)) then
- Error_Msg_N
- ("??subpool access type has deeper accessibility "
- & "level than pool", Def_Id);
-
- Append_Freeze_Action (Def_Id,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Accessibility_Check_Failed));
-
- -- Dynamic case: when the pool is of a class-wide type,
- -- it may or may not support subpools depending on the
- -- path of derivation. Generate:
+ -- When the pool is of a class-wide type, it may or may
+ -- not support subpools depending on the path of
+ -- derivation. Generate:
-- if Def_Id in RSPWS'Class then
-- raise Program_Error;
-- end if;
- elsif Is_Class_Wide_Type (Etype (Pool)) then
- Append_Freeze_Action (Def_Id,
- Make_If_Statement (Loc,
- Condition =>
- Make_In (Loc,
- Left_Opnd => New_Occurrence_Of (Pool, Loc),
- Right_Opnd =>
- New_Occurrence_Of
- (Class_Wide_Type (RSPWS), Loc)),
-
- Then_Statements => New_List (
- Make_Raise_Program_Error (Loc,
- Reason => PE_Accessibility_Check_Failed))));
- end if;
+ Append_Freeze_Action (Def_Id,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_In (Loc,
+ Left_Opnd => New_Occurrence_Of (Pool, Loc),
+ Right_Opnd =>
+ New_Occurrence_Of
+ (Class_Wide_Type
+ (RTE
+ (RE_Root_Storage_Pool_With_Subpools)),
+ Loc)),
+ Then_Statements => New_List (
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Accessibility_Check_Failed))));
end if;
end;
end if;
@@ -8019,7 +8320,7 @@ package body Exp_Ch3 is
-- subtypes to which these checks do not apply.
elsif Has_Invariants (Def_Id) then
- if Within_Internal_Subprogram
+ if not Predicate_Check_In_Scope (Def_Id)
or else (Ekind (Current_Scope) = E_Function
and then Is_Predicate_Function (Current_Scope))
then
@@ -8397,7 +8698,7 @@ package body Exp_Ch3 is
-- If the initial value is null or an aggregate, qualify it with the
-- underlying type in order to provide a proper context.
- if Nkind_In (Expr, N_Aggregate, N_Null) then
+ if Nkind (Expr) in N_Aggregate | N_Null then
Expr :=
Make_Qualified_Expression (Loc,
Subtype_Mark => New_Occurrence_Of (Under_Typ, Loc),
@@ -8639,7 +8940,8 @@ package body Exp_Ch3 is
-- Init_Formals --
------------------
- function Init_Formals (Typ : Entity_Id) return List_Id is
+ function Init_Formals (Typ : Entity_Id; Proc_Id : Entity_Id) return List_Id
+ is
Loc : constant Source_Ptr := Sloc (Typ);
Unc_Arr : constant Boolean :=
Is_Array_Type (Typ) and then not Is_Constrained (Typ);
@@ -8648,9 +8950,11 @@ package body Exp_Ch3 is
or else (Is_Record_Type (Typ)
and then Is_Protected_Record_Type (Typ));
With_Task : constant Boolean :=
- Has_Task (Typ)
- or else (Is_Record_Type (Typ)
- and then Is_Task_Record_Type (Typ));
+ not Global_No_Tasking
+ and then
+ (Has_Task (Typ)
+ or else (Is_Record_Type (Typ)
+ and then Is_Task_Record_Type (Typ)));
Formals : List_Id;
begin
@@ -8679,6 +8983,8 @@ package body Exp_Ch3 is
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Master_Id), Loc)));
+ Set_Has_Master_Entity (Proc_Id);
+
-- Add _Chain (not done for sequential elaboration policy, see
-- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
@@ -9013,6 +9319,8 @@ package body Exp_Ch3 is
end loop;
pragma Assert (Present (Comp));
+
+ -- Move this check to sem???
Error_Msg_Node_2 := Comp;
Error_Msg_NE
("parent type & with dynamic component & cannot be parent"
@@ -9559,10 +9867,9 @@ package body Exp_Ch3 is
begin
-- Build equality code with a user-defined operator, if
-- available, and with the predefined "=" otherwise. For
- -- compatibility with older Ada versions, and preserve the
- -- workings of some ASIS tools, we also use the predefined
- -- operation if the component-type equality is abstract,
- -- rather than raising Program_Error.
+ -- compatibility with older Ada versions, we also use the
+ -- predefined operation if the component-type equality is
+ -- abstract, rather than raising Program_Error.
if Ada_Version < Ada_2012 then
Next_Test := Make_Op_Ne (Loc, Lhs, Rhs);
@@ -9901,6 +10208,8 @@ package body Exp_Ch3 is
-- Set to True if Tag_Typ has a primitive that renames the predefined
-- equality operator. Used to implement (RM 8-5-4(8)).
+ use Exp_Put_Image;
+
-- Start of processing for Make_Predefined_Primitive_Specs
begin
@@ -9918,6 +10227,17 @@ package body Exp_Ch3 is
Ret_Type => Standard_Long_Long_Integer));
+ -- Spec of Put_Image
+
+ if Enable_Put_Image (Tag_Typ)
+ and then No (TSS (Tag_Typ, TSS_Put_Image))
+ then
+ Append_To (Res, Predef_Spec_Or_Body (Loc,
+ Tag_Typ => Tag_Typ,
+ Name => Make_TSS_Name (Tag_Typ, TSS_Put_Image),
+ Profile => Build_Put_Image_Profile (Loc, Tag_Typ)));
+ end if;
+
-- Specs for dispatching stream attributes
declare
@@ -10216,15 +10536,13 @@ package body Exp_Ch3 is
New_Ref : Node_Id;
begin
- -- This expansion activity is called during analysis, but cannot
- -- be applied in ASIS mode when other expansion is disabled.
+ -- This expansion activity is called during analysis.
if Is_Tagged_Type (Typ)
and then not Is_Class_Wide_Type (Typ)
and then not Is_CPP_Class (Typ)
and then Tagged_Type_Expansion
and then Nkind (Expr) /= N_Aggregate
- and then not ASIS_Mode
and then (Nkind (Expr) /= N_Qualified_Expression
or else Nkind (Expression (Expr)) /= N_Aggregate)
then
@@ -10429,6 +10747,8 @@ package body Exp_Ch3 is
pragma Warnings (Off, Ent);
+ use Exp_Put_Image;
+
begin
pragma Assert (not Is_Interface (Tag_Typ));
@@ -10511,6 +10831,15 @@ package body Exp_Ch3 is
Append_To (Res, Decl);
+ -- Body of Put_Image
+
+ if Enable_Put_Image (Tag_Typ)
+ and then No (TSS (Tag_Typ, TSS_Put_Image))
+ then
+ Build_Record_Put_Image_Procedure (Loc, Tag_Typ, Decl, Ent);
+ Append_To (Res, Decl);
+ end if;
+
-- Bodies for Dispatching stream IO routines. We need these only for
-- non-limited types (in the limited case there is no dispatching).
-- We also skip them if dispatching or finalization are not available
diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads
index 197c053..954b5a2 100644
--- a/gcc/ada/exp_ch3.ads
+++ b/gcc/ada/exp_ch3.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -46,6 +46,16 @@ package Exp_Ch3 is
procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id);
-- Add a field _parent in the extension part of the record
+ procedure Build_Access_Subprogram_Wrapper_Body
+ (Decl : Node_Id;
+ New_Decl : Node_Id);
+ -- Build the wrapper body, which holds the indirect call through an access-
+ -- to-subprogram, and whose expansion incorporates the contracts of the
+ -- access type declaration. Called from Build_Access_Subprogram_Wrapper.
+ -- Building the wrapper is done during analysis to perform proper semantic
+ -- checks on the relevant aspects. The wrapper body could be simplified to
+ -- a null body when expansion is disabled ???
+
procedure Build_Discr_Checking_Funcs (N : Node_Id);
-- Builds function which checks whether the component name is consistent
-- with the current discriminants. N is the full type declaration node,
@@ -91,6 +101,13 @@ package Exp_Ch3 is
-- Build the body of the equality function Body_Id for the untagged variant
-- record Typ with the given parameters specification list.
+ procedure Ensure_Activation_Chain_And_Master (Obj_Decl : Node_Id);
+ -- If tasks are being declared (or might be declared) by the given object
+ -- declaration then ensure to have an activation chain defined for the
+ -- tasks (has no effect if we already have one), and also that a Master
+ -- variable is established (and that the appropriate enclosing construct
+ -- is established as a task master).
+
function Freeze_Type (N : Node_Id) return Boolean;
-- This function executes the freezing actions associated with the given
-- freeze type node N and returns True if the node is to be deleted. We
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 28d48ab..30824c6 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -99,7 +99,7 @@ package body Exp_Ch4 is
procedure Expand_Allocator_Expression (N : Node_Id);
-- Subsidiary to Expand_N_Allocator, for the case when the expression
- -- is a qualified expression or an aggregate.
+ -- is a qualified expression.
procedure Expand_Array_Comparison (N : Node_Id);
-- This routine handles expansion of the comparison operators (N_Op_Lt,
@@ -224,11 +224,17 @@ package body Exp_Ch4 is
-- skipped if the operation is done in Bignum mode but that's fine, since
-- the Bignum call takes care of everything.
+ procedure Narrow_Large_Operation (N : Node_Id);
+ -- Try to compute the result of a large operation in a narrower type than
+ -- its nominal type. This is mainly aimed at getting rid of operations done
+ -- in Universal_Integer that can be generated for attributes.
+
procedure Optimize_Length_Comparison (N : Node_Id);
-- Given an expression, if it is of the form X'Length op N (or the other
- -- way round), where N is known at compile time to be 0 or 1, and X is a
- -- simple entity, and op is a comparison operator, optimizes it into a
- -- comparison of First and Last.
+ -- way round), where N is known at compile time to be 0 or 1, or something
+ -- else where the value is known to be nonnegative and in the 32-bit range,
+ -- and X is a simple entity, and op is a comparison operator, optimizes it
+ -- into a comparison of X'First and X'Last.
procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id);
-- Inspect and process statement list Stmt of if or case expression N for
@@ -780,10 +786,10 @@ package body Exp_Ch4 is
-- Local variables
- Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
Indic : constant Node_Id := Subtype_Mark (Expression (N));
T : constant Entity_Id := Entity (Indic);
Adj_Call : Node_Id;
+ Aggr_In_Place : Boolean;
Node : Node_Id;
Tag_Assign : Node_Id;
Temp : Entity_Id;
@@ -807,6 +813,44 @@ package body Exp_Ch4 is
return;
end if;
+ -- If we have:
+ -- type A is access T1;
+ -- X : A := new T2'(...);
+ -- T1 and T2 can be different subtypes, and we might need to check
+ -- both constraints. First check against the type of the qualified
+ -- expression.
+
+ Apply_Constraint_Check (Exp, T, No_Sliding => True);
+
+ Apply_Predicate_Check (Exp, T);
+
+ if Do_Range_Check (Exp) then
+ Generate_Range_Check (Exp, T, CE_Range_Check_Failed);
+ end if;
+
+ -- A check is also needed in cases where the designated subtype is
+ -- constrained and differs from the subtype given in the qualified
+ -- expression. Note that the check on the qualified expression does
+ -- not allow sliding, but this check does (a relaxation from Ada 83).
+
+ if Is_Constrained (DesigT)
+ and then not Subtypes_Statically_Match (T, DesigT)
+ then
+ Apply_Constraint_Check (Exp, DesigT, No_Sliding => False);
+
+ Apply_Predicate_Check (Exp, DesigT);
+
+ if Do_Range_Check (Exp) then
+ Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
+ end if;
+ end if;
+
+ if Nkind (Exp) = N_Raise_Constraint_Error then
+ Rewrite (N, New_Copy (Exp));
+ Set_Etype (N, PtrT);
+ return;
+ end if;
+
-- In the case of an Ada 2012 allocator whose initial value comes from a
-- function call, pass "the accessibility level determined by the point
-- of call" (AI05-0234) to the function. Conceptually, this belongs in
@@ -836,6 +880,8 @@ package body Exp_Ch4 is
end;
end if;
+ Aggr_In_Place := Is_Delayed_Aggregate (Exp);
+
-- Case of tagged type or type requiring finalization
if Is_Tagged_Type (T) or else Needs_Finalization (T) then
@@ -936,8 +982,8 @@ package body Exp_Ch4 is
-- the original allocator node. This is for proper handling of
-- restriction No_Implicit_Heap_Allocations.
- Set_Comes_From_Source
- (Expression (Temp_Decl), Comes_From_Source (N));
+ Preserve_Comes_From_Source
+ (Expression (Temp_Decl), N);
Set_No_Initialization (Expression (Temp_Decl));
Insert_Action (N, Temp_Decl);
@@ -1073,7 +1119,9 @@ package body Exp_Ch4 is
elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then
TagT := T;
- TagR := New_Occurrence_Of (Temp, Loc);
+ TagR :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Temp, Loc));
elsif Is_Private_Type (T)
and then Is_Tagged_Type (Underlying_Type (T))
@@ -1215,35 +1263,6 @@ package body Exp_Ch4 is
else
Build_Allocate_Deallocate_Proc (N, True);
- -- If we have:
- -- type A is access T1;
- -- X : A := new T2'(...);
- -- T1 and T2 can be different subtypes, and we might need to check
- -- both constraints. First check against the type of the qualified
- -- expression.
-
- Apply_Constraint_Check (Exp, T, No_Sliding => True);
-
- if Do_Range_Check (Exp) then
- Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
- end if;
-
- -- A check is also needed in cases where the designated subtype is
- -- constrained and differs from the subtype given in the qualified
- -- expression. Note that the check on the qualified expression does
- -- not allow sliding, but this check does (a relaxation from Ada 83).
-
- if Is_Constrained (DesigT)
- and then not Subtypes_Statically_Match (T, DesigT)
- then
- Apply_Constraint_Check
- (Exp, DesigT, No_Sliding => False);
-
- if Do_Range_Check (Exp) then
- Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
- end if;
- end if;
-
-- For an access to unconstrained packed array, GIGI needs to see an
-- expression with a constrained subtype in order to compute the
-- proper size for the allocator.
@@ -1359,9 +1378,7 @@ package body Exp_Ch4 is
-- except that we avoid this for targets for which are not addressable
-- by bytes.
- if not Is_Bit_Packed_Array (Typ1)
- and then Byte_Addressable
- then
+ if not Is_Bit_Packed_Array (Typ1) and then Byte_Addressable then
-- The call we generate is:
-- Compare_Array_xn[_Unaligned]
@@ -2006,34 +2023,33 @@ package body Exp_Ch4 is
Ctyp : constant Entity_Id := Component_Type (Ltyp);
L, R : Node_Id;
TestL, TestH : Node_Id;
- Index_List : List_Id;
begin
- Index_List := New_List (New_Copy_Tree (Low_Bound (First_Idx)));
-
L :=
Make_Indexed_Component (Loc,
Prefix => New_Copy_Tree (New_Lhs),
- Expressions => Index_List);
+ Expressions =>
+ New_List (New_Copy_Tree (Low_Bound (First_Idx))));
R :=
Make_Indexed_Component (Loc,
Prefix => New_Copy_Tree (New_Rhs),
- Expressions => Index_List);
+ Expressions =>
+ New_List (New_Copy_Tree (Low_Bound (First_Idx))));
TestL := Expand_Composite_Equality (Nod, Ctyp, L, R, Bodies);
- Index_List := New_List (New_Copy_Tree (High_Bound (First_Idx)));
-
L :=
Make_Indexed_Component (Loc,
Prefix => New_Lhs,
- Expressions => Index_List);
+ Expressions =>
+ New_List (New_Copy_Tree (High_Bound (First_Idx))));
R :=
Make_Indexed_Component (Loc,
Prefix => New_Rhs,
- Expressions => Index_List);
+ Expressions =>
+ New_List (New_Copy_Tree (High_Bound (First_Idx))));
TestH := Expand_Composite_Equality (Nod, Ctyp, L, R, Bodies);
@@ -2814,7 +2830,7 @@ package body Exp_Ch4 is
-- to just do a Copy_Node to get an appropriate copy. The extra zeroth
-- entry always is set to zero. The length is of type Artyp.
- Low_Bound : Node_Id;
+ Low_Bound : Node_Id := Empty;
-- A tree node representing the low bound of the result (of type Ityp).
-- This is either an integer literal node, or an identifier reference to
-- a constant entity initialized to the appropriate value.
@@ -2834,7 +2850,7 @@ package body Exp_Ch4 is
High_Bound : Node_Id := Empty;
-- A tree node representing the high bound of the result (of type Ityp)
- Result : Node_Id;
+ Result : Node_Id := Empty;
-- Result of the concatenation (of type Ityp)
Actions : constant List_Id := New_List;
@@ -2990,23 +3006,23 @@ package body Exp_Ch4 is
-- For modular types, we use a 32-bit modular type for types whose size
-- is in the range 1-31 bits. For 32-bit unsigned types, we use the
- -- identity type, and for larger unsigned types we use 64-bits.
+ -- identity type, and for larger unsigned types we use a 64-bit type.
elsif Is_Modular_Integer_Type (Ityp) then
- if RM_Size (Ityp) < RM_Size (Standard_Unsigned) then
+ if RM_Size (Ityp) < Standard_Integer_Size then
Artyp := Standard_Unsigned;
- elsif RM_Size (Ityp) = RM_Size (Standard_Unsigned) then
+ elsif RM_Size (Ityp) = Standard_Integer_Size then
Artyp := Ityp;
else
- Artyp := RTE (RE_Long_Long_Unsigned);
+ Artyp := Standard_Long_Long_Unsigned;
end if;
-- Similar treatment for signed types
else
- if RM_Size (Ityp) < RM_Size (Standard_Integer) then
+ if RM_Size (Ityp) < Standard_Integer_Size then
Artyp := Standard_Integer;
- elsif RM_Size (Ityp) = RM_Size (Standard_Integer) then
+ elsif RM_Size (Ityp) = Standard_Integer_Size then
Artyp := Ityp;
else
Artyp := Standard_Long_Long_Integer;
@@ -3365,6 +3381,8 @@ package body Exp_Ch4 is
end;
end if;
+ pragma Assert (Present (Low_Bound));
+
-- Now we can safely compute the upper bound, normally
-- Low_Bound + Length - 1.
@@ -3621,6 +3639,7 @@ package body Exp_Ch4 is
Result := New_Occurrence_Of (Ent, Loc);
<<Done>>
+ pragma Assert (Present (Result));
Rewrite (Cnode, Result);
Analyze_And_Resolve (Cnode, Atyp);
@@ -4130,7 +4149,7 @@ package body Exp_Ch4 is
-- we avoid never-ending loops expanding them, and we also ensure
-- the back end never receives nonbinary modular type expressions.
- if Nkind_In (Nkind (N), N_Op_And, N_Op_Or, N_Op_Xor) then
+ if Nkind (N) in N_Op_And | N_Op_Or | N_Op_Xor then
Set_Left_Opnd (Op_Expr,
Unchecked_Convert_To (Standard_Unsigned,
New_Copy_Tree (Left_Opnd (N))));
@@ -4146,7 +4165,7 @@ package body Exp_Ch4 is
-- errors on large legal literals of the type.
if Modulus (Etype (N)) > UI_From_Int (Int (Integer'Last)) then
- Target_Type := Standard_Long_Integer;
+ Target_Type := Standard_Long_Long_Integer;
else
Target_Type := Standard_Integer;
end if;
@@ -4369,8 +4388,7 @@ package body Exp_Ch4 is
declare
Idx : Node_Id := First_Index (E);
Len : Node_Id;
- Res : Node_Id;
- pragma Warnings (Off, Res);
+ Res : Node_Id := Empty;
begin
for J in 1 .. Number_Dimensions (E) loop
@@ -4443,6 +4461,7 @@ package body Exp_Ch4 is
Res := Len;
else
+ pragma Assert (Present (Res));
Res :=
Make_Op_Multiply (Loc,
Left_Opnd => Res,
@@ -4483,10 +4502,10 @@ package body Exp_Ch4 is
and then Nkind (Associated_Node_For_Itype (PtrT)) =
N_Object_Declaration)
then
- Error_Msg_N ("?use of an anonymous access type allocator", N);
+ Error_Msg_N ("??use of an anonymous access type allocator", N);
end if;
- -- RM E.2.3(22). We enforce that the expected type of an allocator
+ -- RM E.2.2(17). We enforce that the expected type of an allocator
-- shall not be a remote access-to-class-wide-limited-private type
-- Why is this being done at expansion time, seems clearly wrong ???
@@ -4513,11 +4532,11 @@ package body Exp_Ch4 is
-- lifetime of the object must be associated with the named access
-- type. Use the finalization-related attributes of this type.
- if Nkind_In (Parent (N), N_Type_Conversion,
- N_Unchecked_Type_Conversion)
- and then Ekind_In (Etype (Parent (N)), E_Access_Subtype,
- E_Access_Type,
- E_General_Access_Type)
+ if Nkind (Parent (N)) in N_Type_Conversion
+ | N_Unchecked_Type_Conversion
+ and then Ekind (Etype (Parent (N))) in E_Access_Subtype
+ | E_Access_Type
+ | E_General_Access_Type
then
Rel_Typ := Etype (Parent (N));
else
@@ -4792,19 +4811,8 @@ package body Exp_Ch4 is
end if;
-- Handle case of qualified expression (other than optimization above)
- -- First apply constraint checks, because the bounds or discriminants
- -- in the aggregate might not match the subtype mark in the allocator.
if Nkind (Expression (N)) = N_Qualified_Expression then
- declare
- Exp : constant Node_Id := Expression (Expression (N));
- Typ : constant Entity_Id := Etype (Expression (N));
-
- begin
- Apply_Constraint_Check (Exp, Typ);
- Apply_Predicate_Check (Exp, Typ);
- end;
-
Expand_Allocator_Expression (N);
return;
end if;
@@ -4837,6 +4845,22 @@ package body Exp_Ch4 is
Temp_Type : Entity_Id;
begin
+ -- Apply constraint checks against designated subtype (RM 4.8(10/2))
+ -- but ignore the expression if the No_Initialization flag is set.
+ -- Discriminant checks will be generated by the expansion below.
+
+ if Is_Array_Type (Dtyp) and then not No_Initialization (N) then
+ Apply_Constraint_Check (Expression (N), Dtyp, No_Sliding => True);
+
+ Apply_Predicate_Check (Expression (N), Dtyp);
+
+ if Nkind (Expression (N)) = N_Raise_Constraint_Error then
+ Rewrite (N, New_Copy (Expression (N)));
+ Set_Etype (N, PtrT);
+ return;
+ end if;
+ end if;
+
if No_Initialization (N) then
-- Even though this might be a simple allocation, create a custom
@@ -5026,20 +5050,18 @@ package body Exp_Ch4 is
-- The designated type was an incomplete type, and the
-- access type did not get expanded. Salvage it now.
- if not Restriction_Active (No_Task_Hierarchy) then
- if Present (Parent (Base_Type (PtrT))) then
- Expand_N_Full_Type_Declaration
- (Parent (Base_Type (PtrT)));
+ if Present (Parent (Base_Type (PtrT))) then
+ Expand_N_Full_Type_Declaration
+ (Parent (Base_Type (PtrT)));
- -- The only other possibility is an itype. For this
- -- case, the master must exist in the context. This is
- -- the case when the allocator initializes an access
- -- component in an init-proc.
+ -- The only other possibility is an itype. For this
+ -- case, the master must exist in the context. This is
+ -- the case when the allocator initializes an access
+ -- component in an init-proc.
- else
- pragma Assert (Is_Itype (PtrT));
- Build_Master_Renaming (PtrT, N);
- end if;
+ else
+ pragma Assert (Is_Itype (PtrT));
+ Build_Master_Renaming (PtrT, N);
end if;
end if;
@@ -5062,8 +5084,8 @@ package body Exp_Ch4 is
New_Occurrence_Of
(Entity (Nam), Sloc (Nam)), T);
- elsif Nkind_In (Nam, N_Indexed_Component,
- N_Selected_Component)
+ elsif Nkind (Nam) in N_Indexed_Component
+ | N_Selected_Component
and then Is_Entity_Name (Prefix (Nam))
then
Decls :=
@@ -5309,7 +5331,7 @@ package body Exp_Ch4 is
Case_Stmt : Node_Id;
Decl : Node_Id;
Expr : Node_Id;
- Target : Entity_Id;
+ Target : Entity_Id := Empty;
Target_Typ : Entity_Id;
In_Predicate : Boolean := False;
@@ -5333,7 +5355,7 @@ package body Exp_Ch4 is
-- to which it applies has a static predicate aspect, do not expand,
-- because it will be converted to the proper predicate form later.
- if Ekind_In (Current_Scope, E_Function, E_Procedure)
+ if Ekind (Current_Scope) in E_Function | E_Procedure
and then Is_Predicate_Function (Current_Scope)
then
In_Predicate := True;
@@ -5766,11 +5788,21 @@ package body Exp_Ch4 is
Elsex : constant Node_Id := Next (Thenx);
Typ : constant Entity_Id := Etype (N);
- Actions : List_Id;
- Decl : Node_Id;
- Expr : Node_Id;
- New_If : Node_Id;
- New_N : Node_Id;
+ Actions : List_Id;
+ Decl : Node_Id;
+ Expr : Node_Id;
+ New_If : Node_Id;
+ New_N : Node_Id;
+
+ -- Determine if we are dealing with a special case of a conditional
+ -- expression used as an actual for an anonymous access type which
+ -- forces us to transform the if expression into an expression with
+ -- actions in order to create a temporary to capture the level of the
+ -- expression in each branch.
+
+ Force_Expand : constant Boolean := Is_Anonymous_Access_Actual (N);
+
+ -- Start of processing for Expand_N_If_Expression
begin
-- Check for MINIMIZED/ELIMINATED overflow mode
@@ -5970,9 +6002,13 @@ package body Exp_Ch4 is
end;
-- For other types, we only need to expand if there are other actions
- -- associated with either branch.
+ -- associated with either branch or we need to force expansion to deal
+ -- with if expressions used as an actual of an anonymous access type.
- elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
+ elsif Present (Then_Actions (N))
+ or else Present (Else_Actions (N))
+ or else Force_Expand
+ then
-- We now wrap the actions into the appropriate expression
@@ -6046,6 +6082,62 @@ package body Exp_Ch4 is
Analyze_And_Resolve (Elsex, Typ);
end if;
+ -- We must force expansion into an expression with actions when
+ -- an if expression gets used directly as an actual for an
+ -- anonymous access type.
+
+ if Force_Expand then
+ declare
+ Cnn : constant Entity_Id := Make_Temporary (Loc, 'C');
+ Acts : List_Id;
+ begin
+ Acts := New_List;
+
+ -- Generate:
+ -- Cnn : Ann;
+
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Cnn,
+ Object_Definition => New_Occurrence_Of (Typ, Loc));
+ Append_To (Acts, Decl);
+
+ Set_No_Initialization (Decl);
+
+ -- Generate:
+ -- if Cond then
+ -- Cnn := <Thenx>;
+ -- else
+ -- Cnn := <Elsex>;
+ -- end if;
+
+ New_If :=
+ Make_Implicit_If_Statement (N,
+ Condition => Relocate_Node (Cond),
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Sloc (Thenx),
+ Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
+ Expression => Relocate_Node (Thenx))),
+
+ Else_Statements => New_List (
+ Make_Assignment_Statement (Sloc (Elsex),
+ Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
+ Expression => Relocate_Node (Elsex))));
+ Append_To (Acts, New_If);
+
+ -- Generate:
+ -- do
+ -- ...
+ -- in Cnn end;
+
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Expression => New_Occurrence_Of (Cnn, Loc),
+ Actions => Acts));
+ Analyze_And_Resolve (N, Typ);
+ end;
+ end if;
+
return;
end if;
@@ -6132,8 +6224,8 @@ package body Exp_Ch4 is
-- to consider???
loop
- if Nkind_In (Obj_Ref, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ if Nkind (Obj_Ref) in
+ N_Type_Conversion | N_Unchecked_Type_Conversion
then
Obj_Ref := Expression (Obj_Ref);
else
@@ -6457,6 +6549,12 @@ package body Exp_Ch4 is
end if;
end;
+ -- Try to narrow the operation
+
+ if Ltyp = Universal_Integer and then Nkind (N) = N_In then
+ Narrow_Large_Operation (N);
+ end if;
+
-- For all other cases of an explicit range, nothing to be done
goto Leave;
@@ -6465,12 +6563,13 @@ package body Exp_Ch4 is
else
declare
- Typ : Entity_Id := Etype (Rop);
- Is_Acc : constant Boolean := Is_Access_Type (Typ);
- Cond : Node_Id := Empty;
- New_N : Node_Id;
- Obj : Node_Id := Lop;
- SCIL_Node : Node_Id;
+ Typ : Entity_Id := Etype (Rop);
+ Is_Acc : constant Boolean := Is_Access_Type (Typ);
+ Check_Null_Exclusion : Boolean;
+ Cond : Node_Id := Empty;
+ New_N : Node_Id;
+ Obj : Node_Id := Lop;
+ SCIL_Node : Node_Id;
begin
Remove_Side_Effects (Obj);
@@ -6523,35 +6622,43 @@ package body Exp_Ch4 is
goto Leave;
- -- Ada 2005 (AI-216): Program_Error is raised when evaluating
- -- a membership test if the subtype mark denotes a constrained
- -- Unchecked_Union subtype and the expression lacks inferable
- -- discriminants.
+ -- Ada 2005 (AI95-0216 amended by AI12-0162): Program_Error is
+ -- raised when evaluating an individual membership test if the
+ -- subtype mark denotes a constrained Unchecked_Union subtype
+ -- and the expression lacks inferable discriminants.
elsif Is_Unchecked_Union (Base_Type (Typ))
and then Is_Constrained (Typ)
and then not Has_Inferable_Discriminants (Lop)
then
- Insert_Action (N,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Unchecked_Union_Restriction));
-
- -- Prevent Gigi from generating incorrect code by rewriting the
- -- test as False. What is this undocumented thing about ???
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Actions =>
+ New_List (Make_Raise_Program_Error (Loc,
+ Reason => PE_Unchecked_Union_Restriction)),
+ Expression =>
+ New_Occurrence_Of (Standard_False, Loc)));
+ Analyze_And_Resolve (N, Restyp);
- Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
goto Leave;
end if;
-- Here we have a non-scalar type
if Is_Acc then
+
+ -- If the null exclusion checks are not compatible, need to
+ -- perform further checks. In other words, we cannot have
+ -- Ltyp including null and Typ excluding null. All other cases
+ -- are OK.
+
+ Check_Null_Exclusion :=
+ Can_Never_Be_Null (Typ) and then not Can_Never_Be_Null (Ltyp);
Typ := Designated_Type (Typ);
end if;
if not Is_Constrained (Typ) then
- Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
- Analyze_And_Resolve (N, Restyp);
+ Cond := New_Occurrence_Of (Standard_True, Loc);
-- For the constrained array case, we have to check the subscripts
-- for an exact match if the lengths are non-zero (the lengths
@@ -6607,19 +6714,6 @@ package body Exp_Ch4 is
Build_Attribute_Reference
(New_Occurrence_Of (Typ, Loc), Name_Last, J)));
end loop;
-
- if Is_Acc then
- Cond :=
- Make_Or_Else (Loc,
- Left_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd => Obj,
- Right_Opnd => Make_Null (Loc)),
- Right_Opnd => Cond);
- end if;
-
- Rewrite (N, Cond);
- Analyze_And_Resolve (N, Restyp);
end Check_Subscripts;
-- These are the cases where constraint checks may be required,
@@ -6635,24 +6729,32 @@ package body Exp_Ch4 is
if Has_Discriminants (Typ) then
Cond := Make_Op_Not (Loc,
Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
-
- if Is_Acc then
- Cond := Make_Or_Else (Loc,
- Left_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd => Obj,
- Right_Opnd => Make_Null (Loc)),
- Right_Opnd => Cond);
- end if;
-
else
Cond := New_Occurrence_Of (Standard_True, Loc);
end if;
+ end if;
- Rewrite (N, Cond);
- Analyze_And_Resolve (N, Restyp);
+ if Is_Acc then
+ if Check_Null_Exclusion then
+ Cond := Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => Obj,
+ Right_Opnd => Make_Null (Loc)),
+ Right_Opnd => Cond);
+ else
+ Cond := Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Obj,
+ Right_Opnd => Make_Null (Loc)),
+ Right_Opnd => Cond);
+ end if;
end if;
+ Rewrite (N, Cond);
+ Analyze_And_Resolve (N, Restyp);
+
-- Ada 2012 (AI05-0149): Handle membership tests applied to an
-- expression of an anonymous access type. This can involve an
-- accessibility test and a tagged type membership test in the
@@ -6724,18 +6826,7 @@ package body Exp_Ch4 is
-- If the designated type is tagged, do tagged membership
-- operation.
- -- *** NOTE: we have to check not null before doing the
- -- tagged membership test (but maybe that can be done
- -- inside Tagged_Membership?).
-
if Is_Tagged_Type (Typ) then
- Rewrite (N,
- Make_And_Then (Loc,
- Left_Opnd => Relocate_Node (N),
- Right_Opnd =>
- Make_Op_Ne (Loc,
- Left_Opnd => Obj,
- Right_Opnd => Make_Null (Loc))));
-- No expansion will be performed for VM targets, as
-- the VM back ends will handle the membership tests
@@ -6861,7 +6952,6 @@ package body Exp_Ch4 is
Typ : constant Entity_Id := Etype (N);
P : constant Node_Id := Prefix (N);
T : constant Entity_Id := Etype (P);
- Atp : Entity_Id;
begin
-- A special optimization, if we have an indexed component that is
@@ -6910,20 +7000,6 @@ package body Exp_Ch4 is
Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
end if;
- -- If the prefix is an access type, then we unconditionally rewrite if
- -- as an explicit dereference. This simplifies processing for several
- -- cases, including packed array cases and certain cases in which checks
- -- must be generated. We used to try to do this only when it was
- -- necessary, but it cleans up the code to do it all the time.
-
- if Is_Access_Type (T) then
- Insert_Explicit_Dereference (P);
- Analyze_And_Resolve (P, Designated_Type (T));
- Atp := Designated_Type (T);
- else
- Atp := T;
- end if;
-
-- Generate index and validity checks
Generate_Index_Checks (N);
@@ -6935,8 +7011,8 @@ package body Exp_Ch4 is
-- If selecting from an array with atomic components, and atomic sync
-- is not suppressed for this array type, set atomic sync flag.
- if (Has_Atomic_Components (Atp)
- and then not Atomic_Synchronization_Disabled (Atp))
+ if (Has_Atomic_Components (T)
+ and then not Atomic_Synchronization_Disabled (T))
or else (Is_Atomic (Typ)
and then not Atomic_Synchronization_Disabled (Typ))
or else (Is_Entity_Name (P)
@@ -7005,9 +7081,9 @@ package body Exp_Ch4 is
return;
elsif Nkind (Parnt) = N_Attribute_Reference
- and then Nam_In (Attribute_Name (Parnt), Name_Address,
- Name_Bit,
- Name_Size)
+ and then Attribute_Name (Parnt) in Name_Address
+ | Name_Bit
+ | Name_Size
and then Prefix (Parnt) = Child
then
return;
@@ -7147,6 +7223,7 @@ package body Exp_Ch4 is
procedure Expand_N_Op_Abs (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Expr : constant Node_Id := Right_Opnd (N);
+ Typ : constant Entity_Id := Etype (N);
begin
Unary_Op_Validity_Checks (N);
@@ -7158,9 +7235,19 @@ package body Exp_Ch4 is
return;
end if;
+ -- Try to narrow the operation
+
+ if Typ = Universal_Integer then
+ Narrow_Large_Operation (N);
+
+ if Nkind (N) /= N_Op_Abs then
+ return;
+ end if;
+ end if;
+
-- Deal with software overflow checking
- if Is_Signed_Integer_Type (Etype (N))
+ if Is_Signed_Integer_Type (Typ)
and then Do_Overflow_Check (N)
then
-- The only case to worry about is when the argument is equal to the
@@ -7220,6 +7307,16 @@ package body Exp_Ch4 is
end if;
end if;
+ -- Try to narrow the operation
+
+ if Typ = Universal_Integer then
+ Narrow_Large_Operation (N);
+
+ if Nkind (N) /= N_Op_Add then
+ return;
+ end if;
+ end if;
+
-- Arithmetic overflow checks for signed integer/fixed point types
if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
@@ -7397,6 +7494,16 @@ package body Exp_Ch4 is
return;
end if;
+ -- Try to narrow the operation
+
+ if Typ = Universal_Integer then
+ Narrow_Large_Operation (N);
+
+ if Nkind (N) /= N_Op_Divide then
+ return;
+ end if;
+ end if;
+
-- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
-- Is_Power_Of_2_For_Shift is set means that we know that our left
-- operand is an unsigned integer, as required for this to work.
@@ -7429,16 +7536,10 @@ package body Exp_Ch4 is
if Is_Fixed_Point_Type (Typ) then
- -- No special processing if Treat_Fixed_As_Integer is set, since
- -- from a semantic point of view such operations are simply integer
- -- operations and will be treated that way.
-
- if not Treat_Fixed_As_Integer (N) then
- if Is_Integer_Type (Rtyp) then
- Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
- else
- Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
- end if;
+ if Is_Integer_Type (Rtyp) then
+ Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
+ else
+ Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
end if;
-- Deal with divide-by-zero check if back end cannot handle them
@@ -7462,12 +7563,9 @@ package body Exp_Ch4 is
Reason => CE_Divide_By_Zero));
end if;
- -- Other cases of division of fixed-point operands. Again we exclude the
- -- case where Treat_Fixed_As_Integer is set.
+ -- Other cases of division of fixed-point operands
- elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
- and then not Treat_Fixed_As_Integer (N)
- then
+ elsif Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp) then
if Is_Integer_Type (Typ) then
Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
else
@@ -7910,7 +8008,7 @@ package body Exp_Ch4 is
if Is_Equality (E, Typ) then
return E;
end if;
- E := Next_Entity (E);
+ Next_Entity (E);
end loop;
end loop;
@@ -8342,13 +8440,12 @@ package body Exp_Ch4 is
-- records because there may be padding or undefined fields.
elsif Unnest_Subprogram_Mode
- and then Ekind_In (Typl, E_Class_Wide_Type,
- E_Class_Wide_Subtype,
- E_Access_Subprogram_Type,
- E_Access_Protected_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type,
- E_Access_Subprogram_Type,
- E_Exception_Type)
+ and then Ekind (Typl) in E_Class_Wide_Type
+ | E_Class_Wide_Subtype
+ | E_Access_Subprogram_Type
+ | E_Access_Protected_Subprogram_Type
+ | E_Anonymous_Access_Protected_Subprogram_Type
+ | E_Exception_Type
and then Present (Equivalent_Type (Typl))
and then Is_Record_Type (Equivalent_Type (Typl))
then
@@ -8369,6 +8466,12 @@ package body Exp_Ch4 is
Rewrite_Comparison (N);
+ -- Try to narrow the operation
+
+ if Typl = Universal_Integer and then Nkind (N) = N_Op_Eq then
+ Narrow_Large_Operation (N);
+ end if;
+
-- Special optimization of length comparison
Optimize_Length_Comparison (N);
@@ -8641,7 +8744,7 @@ package body Exp_Ch4 is
-- We only handle cases where the right type is a integer
and then Is_Integer_Type (Root_Type (Exptyp))
- and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
+ and then Esize (Root_Type (Exptyp)) <= Standard_Integer_Size
-- This transformation is not applicable for a modular type with a
-- nonbinary modulus because we do not handle modular reduction in
@@ -8655,7 +8758,7 @@ package body Exp_Ch4 is
-- too tricky to combine the overflow check at the parent level.
if not Ovflo
- and then Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply)
+ and then Nkind (Parent (N)) in N_Op_Divide | N_Op_Multiply
then
declare
P : constant Node_Id := Parent (N);
@@ -8724,8 +8827,7 @@ package body Exp_Ch4 is
-- Determine range to see if it can be larger than MaxS
- Determine_Range
- (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
+ Determine_Range (Exp, OK, Lo, Hi, Assume_Valid => True);
TestS := (not OK) or else Hi > MaxS;
-- Signed integer case
@@ -8742,7 +8844,7 @@ package body Exp_Ch4 is
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Gt (Loc,
- Left_Opnd => Duplicate_Subexpr (Right_Opnd (N)),
+ Left_Opnd => Duplicate_Subexpr (Exp),
Right_Opnd => Make_Integer_Literal (Loc, MaxS)),
Reason => CE_Overflow_Check_Failed));
end if;
@@ -8752,7 +8854,7 @@ package body Exp_Ch4 is
Rewrite (N,
Make_Op_Shift_Left (Loc,
Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
- Right_Opnd => Right_Opnd (N)));
+ Right_Opnd => Exp));
-- Modular integer case
@@ -8770,7 +8872,7 @@ package body Exp_Ch4 is
Test_Gt :=
Make_Op_Gt (Loc,
- Left_Opnd => Duplicate_Subexpr (Right_Opnd (N)),
+ Left_Opnd => Duplicate_Subexpr (Exp),
Right_Opnd => Make_Integer_Literal (Loc, MaxS));
Rewrite (N,
@@ -8780,7 +8882,7 @@ package body Exp_Ch4 is
Make_Integer_Literal (Loc, Uint_0),
Make_Op_Shift_Left (Loc,
Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
- Right_Opnd => Right_Opnd (N)))));
+ Right_Opnd => Exp))));
-- If we know shift count cannot be greater than MaxS, then
-- it is safe to just rewrite as a shift with no test.
@@ -8789,7 +8891,7 @@ package body Exp_Ch4 is
Rewrite (N,
Make_Op_Shift_Left (Loc,
Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
- Right_Opnd => Right_Opnd (N)));
+ Right_Opnd => Exp));
end if;
end if;
@@ -8986,6 +9088,12 @@ package body Exp_Ch4 is
Rewrite_Comparison (N);
+ -- Try to narrow the operation
+
+ if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Ge then
+ Narrow_Large_Operation (N);
+ end if;
+
Optimize_Length_Comparison (N);
end Expand_N_Op_Ge;
@@ -9029,6 +9137,12 @@ package body Exp_Ch4 is
Rewrite_Comparison (N);
+ -- Try to narrow the operation
+
+ if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Gt then
+ Narrow_Large_Operation (N);
+ end if;
+
Optimize_Length_Comparison (N);
end Expand_N_Op_Gt;
@@ -9072,6 +9186,12 @@ package body Exp_Ch4 is
Rewrite_Comparison (N);
+ -- Try to narrow the operation
+
+ if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Le then
+ Narrow_Large_Operation (N);
+ end if;
+
Optimize_Length_Comparison (N);
end Expand_N_Op_Le;
@@ -9115,6 +9235,12 @@ package body Exp_Ch4 is
Rewrite_Comparison (N);
+ -- Try to narrow the operation
+
+ if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Lt then
+ Narrow_Large_Operation (N);
+ end if;
+
Optimize_Length_Comparison (N);
end Expand_N_Op_Lt;
@@ -9136,8 +9262,18 @@ package body Exp_Ch4 is
return;
end if;
+ -- Try to narrow the operation
+
+ if Typ = Universal_Integer then
+ Narrow_Large_Operation (N);
+
+ if Nkind (N) /= N_Op_Minus then
+ return;
+ end if;
+ end if;
+
if not Backend_Overflow_Checks_On_Target
- and then Is_Signed_Integer_Type (Etype (N))
+ and then Is_Signed_Integer_Type (Typ)
and then Do_Overflow_Check (N)
then
-- Software overflow checking expands -expr into (0 - expr)
@@ -9185,7 +9321,17 @@ package body Exp_Ch4 is
return;
end if;
- if Is_Integer_Type (Etype (N)) then
+ -- Try to narrow the operation
+
+ if Typ = Universal_Integer then
+ Narrow_Large_Operation (N);
+
+ if Nkind (N) /= N_Op_Mod then
+ return;
+ end if;
+ end if;
+
+ if Is_Integer_Type (Typ) then
Apply_Divide_Checks (N);
-- All done if we don't have a MOD any more, which can happen as a
@@ -9484,6 +9630,16 @@ package body Exp_Ch4 is
end if;
end if;
+ -- Try to narrow the operation
+
+ if Typ = Universal_Integer then
+ Narrow_Large_Operation (N);
+
+ if Nkind (N) /= N_Op_Multiply then
+ return;
+ end if;
+ end if;
+
-- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
-- Is_Power_Of_2_For_Shift is set means that we know that our left
-- operand is an integer, as required for this to work.
@@ -9571,35 +9727,25 @@ package body Exp_Ch4 is
if Is_Fixed_Point_Type (Typ) then
- -- No special processing if Treat_Fixed_As_Integer is set, since from
- -- a semantic point of view such operations are simply integer
- -- operations and will be treated that way.
+ -- Case of fixed * integer => fixed
- if not Treat_Fixed_As_Integer (N) then
+ if Is_Integer_Type (Rtyp) then
+ Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
- -- Case of fixed * integer => fixed
+ -- Case of integer * fixed => fixed
- if Is_Integer_Type (Rtyp) then
- Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
+ elsif Is_Integer_Type (Ltyp) then
+ Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
- -- Case of integer * fixed => fixed
+ -- Case of fixed * fixed => fixed
- elsif Is_Integer_Type (Ltyp) then
- Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
-
- -- Case of fixed * fixed => fixed
-
- else
- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
- end if;
+ else
+ Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
end if;
- -- Other cases of multiplication of fixed-point operands. Again we
- -- exclude the cases where Treat_Fixed_As_Integer flag is set.
+ -- Other cases of multiplication of fixed-point operands
- elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
- and then not Treat_Fixed_As_Integer (N)
- then
+ elsif Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp) then
if Is_Integer_Type (Typ) then
Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
else
@@ -9645,13 +9791,12 @@ package body Exp_Ch4 is
if Is_Elementary_Type (Typ)
and then Sloc (Entity (N)) = Standard_Location
- and then not (Ekind_In (Typ, E_Class_Wide_Type,
- E_Class_Wide_Subtype,
- E_Access_Subprogram_Type,
- E_Access_Protected_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type,
- E_Access_Subprogram_Type,
- E_Exception_Type)
+ and then not (Ekind (Typ) in E_Class_Wide_Type
+ | E_Class_Wide_Subtype
+ | E_Access_Subprogram_Type
+ | E_Access_Protected_Subprogram_Type
+ | E_Anonymous_Access_Protected_Subprogram_Type
+ | E_Exception_Type
and then Present (Equivalent_Type (Typ))
and then Is_Record_Type (Equivalent_Type (Typ)))
then
@@ -9677,6 +9822,12 @@ package body Exp_Ch4 is
Rewrite_Comparison (N);
+ -- Try to narrow the operation
+
+ if Typ = Universal_Integer and then Nkind (N) = N_Op_Ne then
+ Narrow_Large_Operation (N);
+ end if;
+
-- For all cases other than elementary types, we rewrite node as the
-- negation of an equality operation, and reanalyze. The equality to be
-- used is defined in the same scope and has the same signature. This
@@ -9825,7 +9976,7 @@ package body Exp_Ch4 is
-- Special case the negation of a binary operation
- elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor)
+ elsif Nkind (Opnd) in N_Op_And | N_Op_Or | N_Op_Xor
and then Safe_In_Place_Array_Op
(Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
then
@@ -9959,6 +10110,8 @@ package body Exp_Ch4 is
----------------------
procedure Expand_N_Op_Plus (N : Node_Id) is
+ Typ : constant Entity_Id := Etype (N);
+
begin
Unary_Op_Validity_Checks (N);
@@ -9968,6 +10121,12 @@ package body Exp_Ch4 is
Apply_Arithmetic_Overflow_Check (N);
return;
end if;
+
+ -- Try to narrow the operation
+
+ if Typ = Universal_Integer then
+ Narrow_Large_Operation (N);
+ end if;
end Expand_N_Op_Plus;
---------------------
@@ -10001,6 +10160,16 @@ package body Exp_Ch4 is
return;
end if;
+ -- Try to narrow the operation
+
+ if Typ = Universal_Integer then
+ Narrow_Large_Operation (N);
+
+ if Nkind (N) /= N_Op_Rem then
+ return;
+ end if;
+ end if;
+
if Is_Integer_Type (Etype (N)) then
Apply_Divide_Checks (N);
@@ -10365,6 +10534,16 @@ package body Exp_Ch4 is
return;
end if;
+ -- Try to narrow the operation
+
+ if Typ = Universal_Integer then
+ Narrow_Large_Operation (N);
+
+ if Nkind (N) /= N_Op_Subtract then
+ return;
+ end if;
+ end if;
+
-- N - 0 = N for integer types
if Is_Integer_Type (Typ)
@@ -10440,6 +10619,10 @@ package body Exp_Ch4 is
Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
+ -- Apply possible predicate check
+
+ Apply_Predicate_Check (Operand, Target_Type);
+
if Do_Range_Check (Operand) then
Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
end if;
@@ -10588,7 +10771,7 @@ package body Exp_Ch4 is
Par : constant Node_Id := Parent (N);
P : constant Node_Id := Prefix (N);
S : constant Node_Id := Selector_Name (N);
- Ptyp : Entity_Id := Underlying_Type (Etype (P));
+ Ptyp : constant Entity_Id := Underlying_Type (Etype (P));
Disc : Entity_Id;
New_N : Node_Id;
Dcon : Elmt_Id;
@@ -10639,21 +10822,6 @@ package body Exp_Ch4 is
-- Start of processing for Expand_N_Selected_Component
begin
- -- Insert explicit dereference if required
-
- if Is_Access_Type (Ptyp) then
-
- -- First set prefix type to proper access type, in case it currently
- -- has a private (non-access) view of this type.
-
- Set_Etype (P, Ptyp);
-
- Insert_Explicit_Dereference (P);
- Analyze_And_Resolve (P, Designated_Type (Ptyp));
-
- Ptyp := Etype (P);
- end if;
-
-- Deal with discriminant check required
if Do_Discriminant_Check (N) then
@@ -10983,9 +11151,9 @@ package body Exp_Ch4 is
-- since these are additional cases that do can appear on
-- procedure actuals.
- elsif Nkind_In (Par, N_Type_Conversion,
- N_Parameter_Association,
- N_Qualified_Expression)
+ elsif Nkind (Par) in N_Type_Conversion
+ | N_Parameter_Association
+ | N_Qualified_Expression
then
Par := Parent (Par);
@@ -11026,23 +11194,10 @@ package body Exp_Ch4 is
-- Local variables
Pref : constant Node_Id := Prefix (N);
- Pref_Typ : Entity_Id := Etype (Pref);
-- Start of processing for Expand_N_Slice
begin
- -- Special handling for access types
-
- if Is_Access_Type (Pref_Typ) then
- Pref_Typ := Designated_Type (Pref_Typ);
-
- Rewrite (Pref,
- Make_Explicit_Dereference (Sloc (N),
- Prefix => Relocate_Node (Pref)));
-
- Analyze_And_Resolve (Pref, Pref_Typ);
- end if;
-
-- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
-- function, then additional actuals must be passed.
@@ -11148,6 +11303,11 @@ package body Exp_Ch4 is
-- True iff Present (Effective_Extra_Accessibility (Id)) successfully
-- evaluates to True.
+ function Statically_Deeper_Relation_Applies (Targ_Typ : Entity_Id)
+ return Boolean;
+ -- Given a target type for a conversion, determine whether the
+ -- statically deeper accessibility rules apply to it.
+
--------------------------
-- Discrete_Range_Check --
--------------------------
@@ -11160,6 +11320,51 @@ package body Exp_Ch4 is
Expr : Node_Id;
Ityp : Entity_Id;
+ procedure Generate_Temporary;
+ -- Generate a temporary to facilitate in the C backend the code
+ -- generation of the unchecked conversion since the size of the
+ -- source type may differ from the size of the target type.
+
+ ------------------------
+ -- Generate_Temporary --
+ ------------------------
+
+ procedure Generate_Temporary is
+ begin
+ if Esize (Etype (Expr)) < Esize (Etype (Ityp)) then
+ declare
+ Exp_Type : constant Entity_Id := Ityp;
+ Def_Id : constant Entity_Id :=
+ Make_Temporary (Loc, 'R', Expr);
+ E : Node_Id;
+ Res : Node_Id;
+
+ begin
+ Set_Is_Internal (Def_Id);
+ Set_Etype (Def_Id, Exp_Type);
+ Res := New_Occurrence_Of (Def_Id, Loc);
+
+ E :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Object_Definition => New_Occurrence_Of
+ (Exp_Type, Loc),
+ Constant_Present => True,
+ Expression => Relocate_Node (Expr));
+
+ Set_Assignment_OK (E);
+ Insert_Action (Expr, E);
+
+ Set_Assignment_OK (Res, Assignment_OK (Expr));
+
+ Rewrite (Expr, Res);
+ Analyze_And_Resolve (Expr, Exp_Type);
+ end;
+ end if;
+ end Generate_Temporary;
+
+ -- Start of processing for Discrete_Range_Check
+
begin
-- Nothing to do if conversion was rewritten
@@ -11190,12 +11395,19 @@ package body Exp_Ch4 is
-- integer type large enough to hold the result.
if Is_Fixed_Point_Type (Etype (Expr)) then
- if Esize (Base_Type (Etype (Expr))) > Esize (Standard_Integer) then
+ if Esize (Base_Type (Etype (Expr))) > Standard_Integer_Size then
Ityp := Standard_Long_Long_Integer;
else
Ityp := Standard_Integer;
end if;
+ -- Generate a temporary with the large type to facilitate in the C
+ -- backend the code generation for the unchecked conversion.
+
+ if Modify_Tree_For_C then
+ Generate_Temporary;
+ end if;
+
Set_Do_Range_Check (Expr, False);
Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
end if;
@@ -11222,7 +11434,7 @@ package body Exp_Ch4 is
begin
-- Nothing else to do if no change of representation
- if Same_Representation (Operand_Type, Target_Type) then
+ if Has_Compatible_Representation (Target_Type, Operand_Type) then
return;
-- The real change of representation work is done by the assignment
@@ -11671,13 +11883,32 @@ package body Exp_Ch4 is
function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is
begin
- if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then
+ if Is_Formal (Id) or else Ekind (Id) in E_Constant | E_Variable then
return Present (Effective_Extra_Accessibility (Id));
else
return False;
end if;
end Has_Extra_Accessibility;
+ ----------------------------------------
+ -- Statically_Deeper_Relation_Applies --
+ ----------------------------------------
+
+ function Statically_Deeper_Relation_Applies (Targ_Typ : Entity_Id)
+ return Boolean
+ is
+ begin
+ -- The case where the target type is an anonymous access type is
+ -- ignored since they have different semantics and get covered by
+ -- various runtime checks depending on context.
+
+ -- Note, the current implementation of this predicate is incomplete
+ -- and doesn't fully reflect the rules given in RM 3.10.2 (19) and
+ -- (19.1) ???
+
+ return Ekind (Targ_Typ) /= E_Anonymous_Access_Type;
+ end Statically_Deeper_Relation_Applies;
+
-- Start of processing for Expand_N_Type_Conversion
begin
@@ -11742,6 +11973,39 @@ package body Exp_Ch4 is
Remove_Side_Effects (N);
Insert_Action (N, Make_Invariant_Call (Duplicate_Subexpr (N)));
goto Done;
+
+ -- AI12-0042: For a view conversion to a class-wide type occurring
+ -- within the immediate scope of T, from a specific type that is
+ -- a descendant of T (including T itself), an invariant check is
+ -- performed on the part of the object that is of type T. (We don't
+ -- need to explicitly check for the operand type being a descendant,
+ -- just that it's a specific type, because the conversion would be
+ -- illegal if it's specific and not a descendant -- downward conversion
+ -- is not allowed).
+
+ elsif Is_Class_Wide_Type (Target_Type)
+ and then not Is_Class_Wide_Type (Etype (Expression (N)))
+ and then Present (Invariant_Procedure (Root_Type (Target_Type)))
+ and then Comes_From_Source (N)
+ and then Within_Scope (Find_Enclosing_Scope (N), Scope (Target_Type))
+ then
+ Remove_Side_Effects (N);
+
+ -- Perform the invariant check on a conversion to the class-wide
+ -- type's root type.
+
+ declare
+ Root_Conv : constant Node_Id :=
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Root_Type (Target_Type), Loc),
+ Expression => Duplicate_Subexpr (Expression (N)));
+ begin
+ Set_Etype (Root_Conv, Root_Type (Target_Type));
+
+ Insert_Action (N, Make_Invariant_Call (Root_Conv));
+ goto Done;
+ end;
end if;
-- Here if we may need to expand conversion
@@ -11791,20 +12055,13 @@ package body Exp_Ch4 is
L, R : Node_Id;
begin
- R :=
- Make_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
- Expression => Relocate_Node (Right_Opnd (Operand)));
-
Opnd := New_Op_Node (Nkind (Operand), Loc);
+
+ R := Convert_To (Standard_Integer, Right_Opnd (Operand));
Set_Right_Opnd (Opnd, R);
if Nkind (Operand) in N_Binary_Op then
- L :=
- Make_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
- Expression => Relocate_Node (Left_Opnd (Operand)));
-
+ L := Convert_To (Standard_Integer, Left_Opnd (Operand));
Set_Left_Opnd (Opnd, L);
end if;
@@ -11876,9 +12133,9 @@ package body Exp_Ch4 is
or else Attribute_Name (Original_Node (N)) = Name_Access)
then
if not Comes_From_Source (N)
- and then Nkind_In (Parent (N), N_Function_Call,
- N_Parameter_Association,
- N_Procedure_Call_Statement)
+ and then Nkind (Parent (N)) in N_Function_Call
+ | N_Parameter_Association
+ | N_Procedure_Call_Statement
and then Is_Interface (Designated_Type (Target_Type))
and then Is_Class_Wide_Type (Designated_Type (Target_Type))
then
@@ -11898,21 +12155,7 @@ package body Exp_Ch4 is
-- Note: warnings are issued by the analyzer for the instance cases
elsif In_Instance_Body
-
- -- The case where the target type is an anonymous access type of
- -- a discriminant is excluded, because the level of such a type
- -- depends on the context and currently the level returned for such
- -- types is zero, resulting in warnings about check failures
- -- in certain legal cases involving class-wide interfaces as the
- -- designated type (some cases, such as return statements, are
- -- checked at run time, but not clear if these are handled right
- -- in general, see 3.10.2(12/2-12.5/3) ???).
-
- and then
- not (Ekind (Target_Type) = E_Anonymous_Access_Type
- and then Present (Associated_Node_For_Itype (Target_Type))
- and then Nkind (Associated_Node_For_Itype (Target_Type)) =
- N_Discriminant_Specification)
+ and then Statically_Deeper_Relation_Applies (Target_Type)
and then
Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type)
then
@@ -11969,7 +12212,6 @@ package body Exp_Ch4 is
Tagged_Conversion : declare
Actual_Op_Typ : Entity_Id;
Actual_Targ_Typ : Entity_Id;
- Make_Conversion : Boolean := False;
Root_Op_Typ : Entity_Id;
procedure Make_Tag_Check (Targ_Typ : Entity_Id);
@@ -12053,78 +12295,26 @@ package body Exp_Ch4 is
goto Done;
end if;
- if not Tag_Checks_Suppressed (Actual_Targ_Typ) then
-
- -- Create a runtime tag check for a downward class-wide type
- -- conversion.
+ -- Create a runtime tag check for a downward CW type conversion
- if Is_Class_Wide_Type (Actual_Op_Typ)
- and then Actual_Op_Typ /= Actual_Targ_Typ
- and then Root_Op_Typ /= Actual_Targ_Typ
- and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ,
- Use_Full_View => True)
- then
+ if Is_Class_Wide_Type (Actual_Op_Typ)
+ and then Actual_Op_Typ /= Actual_Targ_Typ
+ and then Root_Op_Typ /= Actual_Targ_Typ
+ and then Is_Ancestor
+ (Root_Op_Typ, Actual_Targ_Typ, Use_Full_View => True)
+ and then not Tag_Checks_Suppressed (Actual_Targ_Typ)
+ then
+ declare
+ Conv : Node_Id;
+ begin
Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
- Make_Conversion := True;
- end if;
-
- -- AI05-0073: If the result subtype of the function is defined
- -- by an access_definition designating a specific tagged type
- -- T, a check is made that the result value is null or the tag
- -- of the object designated by the result value identifies T.
- -- Constraint_Error is raised if this check fails.
-
- if Nkind (Parent (N)) = N_Simple_Return_Statement then
- declare
- Func : Entity_Id;
- Func_Typ : Entity_Id;
-
- begin
- -- Climb scope stack looking for the enclosing function
-
- Func := Current_Scope;
- while Present (Func)
- and then Ekind (Func) /= E_Function
- loop
- Func := Scope (Func);
- end loop;
-
- -- The function's return subtype must be defined using
- -- an access definition.
-
- if Nkind (Result_Definition (Parent (Func))) =
- N_Access_Definition
- then
- Func_Typ := Directly_Designated_Type (Etype (Func));
-
- -- The return subtype denotes a specific tagged type,
- -- in other words, a non class-wide type.
-
- if Is_Tagged_Type (Func_Typ)
- and then not Is_Class_Wide_Type (Func_Typ)
- then
- Make_Tag_Check (Actual_Targ_Typ);
- Make_Conversion := True;
- end if;
- end if;
- end;
- end if;
-
- -- We have generated a tag check for either a class-wide type
- -- conversion or for AI05-0073.
-
- if Make_Conversion then
- declare
- Conv : Node_Id;
- begin
- Conv :=
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
- Expression => Relocate_Node (Expression (N)));
- Rewrite (N, Conv);
- Analyze_And_Resolve (N, Target_Type);
- end;
- end if;
+ Conv :=
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
+ Expression => Relocate_Node (Expression (N)));
+ Rewrite (N, Conv);
+ Analyze_And_Resolve (N, Target_Type);
+ end;
end if;
end Tagged_Conversion;
@@ -12262,9 +12452,11 @@ package body Exp_Ch4 is
-- Special processing is required if there is a change of
-- representation (from enumeration representation clauses).
- if not Same_Representation (Target_Type, Operand_Type) then
+ if not Has_Compatible_Representation (Target_Type, Operand_Type)
+ and then not Conversion_OK (N)
+ then
- -- Convert: x(y) to x'val (ytyp'val (y))
+ -- Convert: x(y) to x'val (ytyp'pos (y))
Rewrite (N,
Make_Attribute_Reference (Loc,
@@ -12355,8 +12547,7 @@ package body Exp_Ch4 is
-- guard is necessary to prevent infinite recursions when we generate
-- internal conversions for the purpose of checking predicates.
- if Present (Predicate_Function (Target_Type))
- and then not Predicates_Ignored (Target_Type)
+ if Predicate_Enabled (Target_Type)
and then Target_Type /= Operand_Type
and then Comes_From_Source (N)
then
@@ -12364,14 +12555,14 @@ package body Exp_Ch4 is
New_Expr : constant Node_Id := Duplicate_Subexpr (N);
begin
- -- Avoid infinite recursion on the subsequent expansion of
- -- of the copy of the original type conversion. When needed,
- -- a range check has already been applied to the expression.
+ -- Avoid infinite recursion on the subsequent expansion of the
+ -- copy of the original type conversion. When needed, a range
+ -- check has already been applied to the expression.
Set_Comes_From_Source (New_Expr, False);
Insert_Action (N,
- Make_Predicate_Check (Target_Type, New_Expr),
- Suppress => Range_Check);
+ Make_Predicate_Check (Target_Type, New_Expr),
+ Suppress => Range_Check);
end;
end if;
end Expand_N_Type_Conversion;
@@ -12424,7 +12615,7 @@ package body Exp_Ch4 is
-- If we have a conversion of a compile time known value to a target
-- type and the value is in range of the target type, then we can simply
-- replace the construct by an integer literal of the correct type. We
- -- only apply this to integer types being converted. Possibly it may
+ -- only apply this to discrete types being converted. Possibly it may
-- apply in other cases, but it is too much trouble to worry about.
-- Note that we do not do this transformation if the Kill_Range_Check
@@ -12437,13 +12628,13 @@ package body Exp_Ch4 is
if Is_Integer_Type (Target_Type)
and then not Has_Biased_Representation (Target_Type)
- and then Is_Integer_Type (Operand_Type)
+ and then Is_Discrete_Type (Operand_Type)
and then not Has_Biased_Representation (Operand_Type)
and then Compile_Time_Known_Value (Operand)
and then not Kill_Range_Check (N)
then
declare
- Val : constant Uint := Expr_Value (Operand);
+ Val : constant Uint := Expr_Rep_Value (Operand);
begin
if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
@@ -12559,7 +12750,7 @@ package body Exp_Ch4 is
exit when No (Comp);
- exit when Ekind_In (Comp, E_Discriminant, E_Component)
+ exit when Ekind (Comp) in E_Discriminant | E_Component
and then not (
-- Skip inherited components
@@ -12698,6 +12889,14 @@ package body Exp_Ch4 is
Make_Op_Eq (Sloc (Alt),
Left_Opnd => L,
Right_Opnd => R);
+
+ if Is_Record_Or_Limited_Type (Etype (Alt)) then
+
+ -- We reset the Entity in order to use the primitive equality
+ -- of the type, as per RM 4.5.2 (28.1/4).
+
+ Set_Entity (Cond, Empty);
+ end if;
end if;
return Cond;
@@ -12708,16 +12907,19 @@ package body Exp_Ch4 is
begin
Remove_Side_Effects (Lop);
- Alt := Last (Alternatives (N));
+ Alt := First (Alternatives (N));
Res := Make_Cond (Alt);
+ Next (Alt);
+
+ -- We use left associativity as in the equivalent boolean case. This
+ -- kind of canonicalization helps the optimizer of the code generator.
- Prev (Alt);
while Present (Alt) loop
Res :=
Make_Or_Else (Sloc (Alt),
- Left_Opnd => Make_Cond (Alt),
- Right_Opnd => Res);
- Prev (Alt);
+ Left_Opnd => Res,
+ Right_Opnd => Make_Cond (Alt));
+ Next (Alt);
end loop;
Rewrite (N, Res);
@@ -13326,13 +13528,9 @@ package body Exp_Ch4 is
-- value and unary negation. Unary "+" is omitted since it is a
-- no-op and thus can't overflow.
- and then Nkind_In (Operand, N_Op_Abs,
- N_Op_Add,
- N_Op_Divide,
- N_Op_Expon,
- N_Op_Minus,
- N_Op_Multiply,
- N_Op_Subtract);
+ and then Nkind (Operand) in
+ N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
+ N_Op_Minus | N_Op_Multiply | N_Op_Subtract;
end Integer_Promotion_Possible;
------------------------------
@@ -13735,6 +13933,232 @@ package body Exp_Ch4 is
and then Overflow_Check_Mode in Minimized_Or_Eliminated;
end Minimized_Eliminated_Overflow_Check;
+ ----------------------------
+ -- Narrow_Large_Operation --
+ ----------------------------
+
+ procedure Narrow_Large_Operation (N : Node_Id) is
+ Kind : constant Node_Kind := Nkind (N);
+ In_Rng : constant Boolean := Kind = N_In;
+ Binary : constant Boolean := Kind in N_Binary_Op or else In_Rng;
+ Compar : constant Boolean := Kind in N_Op_Compare or else In_Rng;
+ R : constant Node_Id := Right_Opnd (N);
+ Typ : constant Entity_Id := Etype (R);
+ Tsiz : constant Uint := RM_Size (Typ);
+
+ function Get_Size_For_Range (Lo, Hi : Uint) return Uint;
+ -- Return the size of a small signed integer type covering Lo .. Hi.
+ -- The important thing is to return a size lower than that of Typ.
+
+ ------------------------
+ -- Get_Size_For_Range --
+ ------------------------
+
+ function Get_Size_For_Range (Lo, Hi : Uint) return Uint is
+
+ function Is_OK_For_Range (Siz : Uint) return Boolean;
+ -- Return True if a signed integer with given size can cover Lo .. Hi
+
+ --------------------------
+ -- Is_OK_For_Range --
+ --------------------------
+
+ function Is_OK_For_Range (Siz : Uint) return Boolean is
+ B : constant Uint := Uint_2 ** (Siz - 1);
+
+ begin
+ -- Test B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
+
+ return Lo >= -B and then Hi >= -B and then Lo < B and then Hi < B;
+ end Is_OK_For_Range;
+
+ begin
+ -- This is (almost always) the size of Integer
+
+ if Is_OK_For_Range (Uint_32) then
+ return Uint_32;
+
+ -- If the size of Typ is 64 then check 63
+
+ elsif Tsiz = Uint_64 and then Is_OK_For_Range (Uint_63) then
+ return Uint_63;
+
+ -- This is (almost always) the size of Long_Long_Integer
+
+ elsif Is_OK_For_Range (Uint_64) then
+ return Uint_64;
+
+ else
+ return Uint_128;
+ end if;
+ end Get_Size_For_Range;
+
+ -- Local variables
+
+ L : Node_Id;
+ Llo, Lhi : Uint;
+ Rlo, Rhi : Uint;
+ Lsiz, Rsiz : Uint;
+ Nlo, Nhi : Uint;
+ Nsiz : Uint;
+ Ntyp : Entity_Id;
+ Nop : Node_Id;
+ OK : Boolean;
+
+ -- Start of processing for Narrow_Large_Operation
+
+ begin
+ -- First, determine the range of the left operand, if any
+
+ if Binary then
+ L := Left_Opnd (N);
+ Determine_Range (L, OK, Llo, Lhi, Assume_Valid => True);
+ if not OK then
+ return;
+ end if;
+
+ else
+ L := Empty;
+ Llo := Uint_0;
+ Lhi := Uint_0;
+ end if;
+
+ -- Second, determine the range of the right operand, which can itself
+ -- be a range, in which case we take the lower bound of the low bound
+ -- and the upper bound of the high bound.
+
+ if In_Rng then
+ declare
+ Zlo, Zhi : Uint;
+
+ begin
+ Determine_Range
+ (Low_Bound (R), OK, Rlo, Zhi, Assume_Valid => True);
+ if not OK then
+ return;
+ end if;
+
+ Determine_Range
+ (High_Bound (R), OK, Zlo, Rhi, Assume_Valid => True);
+ if not OK then
+ return;
+ end if;
+ end;
+
+ else
+ Determine_Range (R, OK, Rlo, Rhi, Assume_Valid => True);
+ if not OK then
+ return;
+ end if;
+ end if;
+
+ -- Then compute a size suitable for each range
+
+ if Binary then
+ Lsiz := Get_Size_For_Range (Llo, Lhi);
+ else
+ Lsiz := Uint_0;
+ end if;
+
+ Rsiz := Get_Size_For_Range (Rlo, Rhi);
+
+ -- Now compute the size of the narrower type
+
+ if Compar then
+ -- The type must be able to accommodate the operands
+
+ Nsiz := UI_Max (Lsiz, Rsiz);
+
+ else
+ -- The type must be able to accommodate the operand(s) and result.
+
+ -- Note that Determine_Range typically does not report the bounds of
+ -- the value as being larger than those of the base type, which means
+ -- that it does not report overflow (see also Enable_Overflow_Check).
+
+ Determine_Range (N, OK, Nlo, Nhi, Assume_Valid => True);
+ if not OK then
+ return;
+ end if;
+
+ -- Therefore, if Nsiz is not lower than the size of the original type
+ -- here, we cannot be sure that the operation does not overflow.
+
+ Nsiz := Get_Size_For_Range (Nlo, Nhi);
+ Nsiz := UI_Max (Nsiz, Lsiz);
+ Nsiz := UI_Max (Nsiz, Rsiz);
+ end if;
+
+ -- If the size is not lower than the size of the original type, then
+ -- there is no point in changing the type, except in the case where
+ -- we can remove a conversion to the original type from an operand.
+
+ if Nsiz >= Tsiz
+ and then not (Binary
+ and then Nkind (L) = N_Type_Conversion
+ and then Entity (Subtype_Mark (L)) = Typ)
+ and then not (Nkind (R) = N_Type_Conversion
+ and then Entity (Subtype_Mark (R)) = Typ)
+ then
+ return;
+ end if;
+
+ -- Now pick the narrower type according to the size. We use the base
+ -- type instead of the first subtype because operations are done in
+ -- the base type, so this avoids the need for useless conversions.
+
+ if Nsiz <= Standard_Integer_Size then
+ Ntyp := Etype (Standard_Integer);
+
+ elsif Nsiz <= Standard_Long_Long_Integer_Size then
+ Ntyp := Etype (Standard_Long_Long_Integer);
+
+ else
+ return;
+ end if;
+
+ -- Finally, rewrite the operation in the narrower type
+
+ Nop := New_Op_Node (Kind, Sloc (N));
+
+ if Binary then
+ Set_Left_Opnd (Nop, Convert_To (Ntyp, L));
+ end if;
+
+ if In_Rng then
+ Set_Right_Opnd (Nop,
+ Make_Range (Sloc (N),
+ Convert_To (Ntyp, Low_Bound (R)),
+ Convert_To (Ntyp, High_Bound (R))));
+ else
+ Set_Right_Opnd (Nop, Convert_To (Ntyp, R));
+ end if;
+
+ Rewrite (N, Nop);
+
+ if Compar then
+ -- Analyze it with the comparison type and checks suppressed since
+ -- the conversions of the operands cannot overflow.
+
+ Analyze_And_Resolve
+ (N, Etype (Original_Node (N)), Suppress => Overflow_Check);
+
+ else
+ -- Analyze it with the narrower type and checks suppressed, but only
+ -- when we are sure that the operation does not overflow, see above.
+
+ if Nsiz < Tsiz then
+ Analyze_And_Resolve (N, Ntyp, Suppress => Overflow_Check);
+ else
+ Analyze_And_Resolve (N, Ntyp);
+ end if;
+
+ -- Put back a conversion to the original type
+
+ Convert_To_And_Rewrite (Typ, N);
+ end if;
+ end Narrow_Large_Operation;
+
--------------------------------
-- Optimize_Length_Comparison --
--------------------------------
@@ -13752,61 +14176,79 @@ package body Exp_Ch4 is
Is_Zero : Boolean;
-- True for comparison operand of zero
+ Maybe_Superflat : Boolean;
+ -- True if we may be in the dynamic superflat case, i.e. Is_Zero is set
+ -- to false but the comparison operand can be zero at run time. In this
+ -- case, we normally cannot do anything because the canonical formula of
+ -- the length is not valid, but there is one exception: when the operand
+ -- is itself the length of an array with the same bounds as the array on
+ -- the LHS, we can entirely optimize away the comparison.
+
Comp : Node_Id;
-- Comparison operand, set only if Is_Zero is false
- Ent : Entity_Id := Empty;
- -- Entity whose length is being compared
+ Ent : array (Pos range 1 .. 2) of Entity_Id := (Empty, Empty);
+ -- Entities whose length is being compared
- Index : Node_Id := Empty;
- -- Integer_Literal node for length attribute expression, or Empty
+ Index : array (Pos range 1 .. 2) of Node_Id := (Empty, Empty);
+ -- Integer_Literal nodes for length attribute expressions, or Empty
-- if there is no such expression present.
- Ityp : Entity_Id;
- -- Type of array index to which 'Length is applied
-
Op : Node_Kind := Nkind (N);
-- Kind of comparison operator, gets flipped if operands backwards
- function Is_Optimizable (N : Node_Id) return Boolean;
- -- Tests N to see if it is an optimizable comparison value (defined as
- -- constant zero or one, or something else where the value is known to
- -- be positive and in the range of 32-bits, and where the corresponding
- -- Length value is also known to be 32-bits. If result is true, sets
- -- Is_Zero, Ityp, and Comp accordingly.
+ function Convert_To_Long_Long_Integer (N : Node_Id) return Node_Id;
+ -- Given a discrete expression, returns a Long_Long_Integer typed
+ -- expression representing the underlying value of the expression.
+ -- This is done with an unchecked conversion to Long_Long_Integer.
+ -- We use unchecked conversion to handle the enumeration type case.
- function Is_Entity_Length (N : Node_Id) return Boolean;
+ function Is_Entity_Length (N : Node_Id; Num : Pos) return Boolean;
-- Tests if N is a length attribute applied to a simple entity. If so,
-- returns True, and sets Ent to the entity, and Index to the integer
-- literal provided as an attribute expression, or to Empty if none.
+ -- Num is the index designating the relevant slot in Ent and Index.
-- Also returns True if the expression is a generated type conversion
-- whose expression is of the desired form. This latter case arises
-- when Apply_Universal_Integer_Attribute_Check installs a conversion
-- to check for being in range, which is not needed in this context.
-- Returns False if neither condition holds.
- function Prepare_64 (N : Node_Id) return Node_Id;
- -- Given a discrete expression, returns a Long_Long_Integer typed
- -- expression representing the underlying value of the expression.
- -- This is done with an unchecked conversion to the result type. We
- -- use unchecked conversion to handle the enumeration type case.
+ function Is_Optimizable (N : Node_Id) return Boolean;
+ -- Tests N to see if it is an optimizable comparison value (defined as
+ -- constant zero or one, or something else where the value is known to
+ -- be nonnegative and in the 32-bit range and where the corresponding
+ -- Length value is also known to be 32 bits). If result is true, sets
+ -- Is_Zero, Maybe_Superflat and Comp accordingly.
+
+ procedure Rewrite_For_Equal_Lengths;
+ -- Rewrite the comparison of two equal lengths into either True or False
+
+ ----------------------------------
+ -- Convert_To_Long_Long_Integer --
+ ----------------------------------
+
+ function Convert_To_Long_Long_Integer (N : Node_Id) return Node_Id is
+ begin
+ return Unchecked_Convert_To (Standard_Long_Long_Integer, N);
+ end Convert_To_Long_Long_Integer;
----------------------
-- Is_Entity_Length --
----------------------
- function Is_Entity_Length (N : Node_Id) return Boolean is
+ function Is_Entity_Length (N : Node_Id; Num : Pos) return Boolean is
begin
if Nkind (N) = N_Attribute_Reference
and then Attribute_Name (N) = Name_Length
and then Is_Entity_Name (Prefix (N))
then
- Ent := Entity (Prefix (N));
+ Ent (Num) := Entity (Prefix (N));
if Present (Expressions (N)) then
- Index := First (Expressions (N));
+ Index (Num) := First (Expressions (N));
else
- Index := Empty;
+ Index (Num) := Empty;
end if;
return True;
@@ -13814,7 +14256,7 @@ package body Exp_Ch4 is
elsif Nkind (N) = N_Type_Conversion
and then not Comes_From_Source (N)
then
- return Is_Entity_Length (Expression (N));
+ return Is_Entity_Length (Expression (N), Num);
else
return False;
@@ -13831,64 +14273,106 @@ package body Exp_Ch4 is
Lo : Uint;
Hi : Uint;
Indx : Node_Id;
+ Dbl : Boolean;
+ Ityp : Entity_Id;
begin
if Compile_Time_Known_Value (N) then
Val := Expr_Value (N);
if Val = Uint_0 then
- Is_Zero := True;
- Comp := Empty;
+ Is_Zero := True;
+ Maybe_Superflat := False;
+ Comp := Empty;
return True;
elsif Val = Uint_1 then
- Is_Zero := False;
- Comp := Empty;
+ Is_Zero := False;
+ Maybe_Superflat := False;
+ Comp := Empty;
return True;
end if;
end if;
- -- Here we have to make sure of being within 32-bits
+ -- Here we have to make sure of being within a 32-bit range (take the
+ -- full unsigned range so the length of 32-bit arrays is accepted).
Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
if not OK
- or else Lo < Uint_1
- or else Hi > UI_From_Int (Int'Last)
+ or else Lo < Uint_0
+ or else Hi > Uint_2 ** 32
then
return False;
end if;
- -- Comparison value was within range, so now we must check the index
- -- value to make sure it is also within 32-bits.
+ Maybe_Superflat := (Lo = Uint_0);
- Indx := First_Index (Etype (Ent));
+ -- Tests if N is also a length attribute applied to a simple entity
- if Present (Index) then
- for J in 2 .. UI_To_Int (Intval (Index)) loop
- Next_Index (Indx);
- end loop;
- end if;
+ Dbl := Is_Entity_Length (N, 2);
- Ityp := Etype (Indx);
+ -- We can deal with the superflat case only if N is also a length
- if Esize (Ityp) > 32 then
+ if Maybe_Superflat and then not Dbl then
return False;
end if;
+ -- Comparison value was within range, so now we must check the index
+ -- value to make sure it is also within 32 bits.
+
+ for K in Pos range 1 .. 2 loop
+ Indx := First_Index (Etype (Ent (K)));
+
+ if Present (Index (K)) then
+ for J in 2 .. UI_To_Int (Intval (Index (K))) loop
+ Next_Index (Indx);
+ end loop;
+ end if;
+
+ Ityp := Etype (Indx);
+
+ if Esize (Ityp) > 32 then
+ return False;
+ end if;
+
+ exit when not Dbl;
+ end loop;
+
Is_Zero := False;
Comp := N;
return True;
end Is_Optimizable;
- ----------------
- -- Prepare_64 --
- ----------------
+ -------------------------------
+ -- Rewrite_For_Equal_Lengths --
+ -------------------------------
- function Prepare_64 (N : Node_Id) return Node_Id is
+ procedure Rewrite_For_Equal_Lengths is
begin
- return Unchecked_Convert_To (Standard_Long_Long_Integer, N);
- end Prepare_64;
+ case Op is
+ when N_Op_Eq
+ | N_Op_Ge
+ | N_Op_Le
+ =>
+ Rewrite (N,
+ Convert_To (Typ,
+ New_Occurrence_Of (Standard_True, Sloc (N))));
+
+ when N_Op_Ne
+ | N_Op_Gt
+ | N_Op_Lt
+ =>
+ Rewrite (N,
+ Convert_To (Typ,
+ New_Occurrence_Of (Standard_False, Sloc (N))));
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ Analyze_And_Resolve (N, Typ);
+ end Rewrite_For_Equal_Lengths;
-- Start of processing for Optimize_Length_Comparison
@@ -13907,14 +14391,14 @@ package body Exp_Ch4 is
-- Ent'Length op 0/1
- if Is_Entity_Length (Left_Opnd (N))
+ if Is_Entity_Length (Left_Opnd (N), 1)
and then Is_Optimizable (Right_Opnd (N))
then
null;
-- 0/1 op Ent'Length
- elsif Is_Entity_Length (Right_Opnd (N))
+ elsif Is_Entity_Length (Right_Opnd (N), 1)
and then Is_Optimizable (Left_Opnd (N))
then
-- Flip comparison to opposite sense
@@ -14008,41 +14492,124 @@ package body Exp_Ch4 is
Left :=
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ent, Loc),
+ Prefix => New_Occurrence_Of (Ent (1), Loc),
Attribute_Name => Name_First);
- if Present (Index) then
- Set_Expressions (Left, New_List (New_Copy (Index)));
+ if Present (Index (1)) then
+ Set_Expressions (Left, New_List (New_Copy (Index (1))));
+ end if;
+
+ -- Build the Last reference we will use
+
+ Right :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ent (1), Loc),
+ Attribute_Name => Name_Last);
+
+ if Present (Index (1)) then
+ Set_Expressions (Right, New_List (New_Copy (Index (1))));
end if;
-- If general value case, then do the addition of (n - 1), and
-- also add the needed conversions to type Long_Long_Integer.
+ -- If n = Y'Length, we rewrite X'First + (n - 1) op X'Last into:
+
+ -- Y'Last + (X'First - Y'First) op X'Last
+
+ -- in the hope that X'First - Y'First can be computed statically.
+
if Present (Comp) then
- Left :=
- Make_Op_Add (Loc,
- Left_Opnd => Prepare_64 (Left),
- Right_Opnd =>
- Make_Op_Subtract (Loc,
- Left_Opnd => Prepare_64 (Comp),
- Right_Opnd => Make_Integer_Literal (Loc, 1)));
- end if;
+ if Present (Ent (2)) then
+ declare
+ Y_First : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ent (2), Loc),
+ Attribute_Name => Name_First);
+ Y_Last : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ent (2), Loc),
+ Attribute_Name => Name_Last);
+ R : Compare_Result;
- -- Build the Last reference we will use
+ begin
+ if Present (Index (2)) then
+ Set_Expressions (Y_First, New_List (New_Copy (Index (2))));
+ Set_Expressions (Y_Last, New_List (New_Copy (Index (2))));
+ end if;
- Right :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ent, Loc),
- Attribute_Name => Name_Last);
+ Analyze (Left);
+ Analyze (Y_First);
+
+ -- If X'First = Y'First, simplify the above formula into a
+ -- direct comparison of Y'Last and X'Last.
+
+ R := Compile_Time_Compare (Left, Y_First, Assume_Valid => True);
+
+ if R = EQ then
+ Analyze (Right);
+ Analyze (Y_Last);
+
+ R := Compile_Time_Compare
+ (Right, Y_Last, Assume_Valid => True);
+
+ -- If the pairs of attributes are equal, we are done
+
+ if R = EQ then
+ Rewrite_For_Equal_Lengths;
+ return;
+ end if;
- if Present (Index) then
- Set_Expressions (Right, New_List (New_Copy (Index)));
+ -- If the base types are different, convert both operands to
+ -- Long_Long_Integer, else compare them directly.
+
+ if Base_Type (Etype (Right)) /= Base_Type (Etype (Y_Last))
+ then
+ Left := Convert_To_Long_Long_Integer (Y_Last);
+ else
+ Left := Y_Last;
+ Comp := Empty;
+ end if;
+
+ -- Otherwise, use the above formula as-is
+
+ else
+ Left :=
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Convert_To_Long_Long_Integer (Y_Last),
+ Right_Opnd =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Convert_To_Long_Long_Integer (Left),
+ Right_Opnd =>
+ Convert_To_Long_Long_Integer (Y_First)));
+ end if;
+ end;
+
+ -- General value case
+
+ else
+ Left :=
+ Make_Op_Add (Loc,
+ Left_Opnd => Convert_To_Long_Long_Integer (Left),
+ Right_Opnd =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd => Convert_To_Long_Long_Integer (Comp),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)));
+ end if;
+ end if;
+
+ -- We cannot do anything in the superflat case past this point
+
+ if Maybe_Superflat then
+ return;
end if;
-- If general operand, convert Last reference to Long_Long_Integer
if Present (Comp) then
- Right := Prepare_64 (Right);
+ Right := Convert_To_Long_Long_Integer (Right);
end if;
-- Check for cases to optimize
@@ -14119,11 +14686,10 @@ package body Exp_Ch4 is
raise Program_Error;
end if;
- -- Rewrite and finish up
+ -- Rewrite and finish up (we can suppress overflow checks, see above)
Rewrite (N, Result);
- Analyze_And_Resolve (N, Typ);
- return;
+ Analyze_And_Resolve (N, Typ, Suppress => Overflow_Check);
end Optimize_Length_Comparison;
--------------------------------
@@ -14174,9 +14740,9 @@ package body Exp_Ch4 is
-- transient object.
begin
- pragma Assert (Nkind_In (Expr, N_Case_Expression,
- N_Expression_With_Actions,
- N_If_Expression));
+ pragma Assert (Nkind (Expr) in N_Case_Expression
+ | N_Expression_With_Actions
+ | N_If_Expression);
-- When the context is a Boolean evaluation, all three nodes capture the
-- result of their computation in a local temporary:
@@ -14243,7 +14809,7 @@ package body Exp_Ch4 is
-- <or>
-- Hook := Obj_Id'Unrestricted_Access;
- if Ekind_In (Obj_Id, E_Constant, E_Variable)
+ if Ekind (Obj_Id) in E_Constant | E_Variable
and then Present (Last_Aggregate_Assignment (Obj_Id))
then
Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
@@ -14377,7 +14943,7 @@ package body Exp_Ch4 is
elsif Is_Entity_Name (Op) then
return Is_Unaliased (Op);
- elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then
+ elsif Nkind (Op) in N_Indexed_Component | N_Selected_Component then
return Is_Unaliased (Prefix (Op));
elsif Nkind (Op) = N_Slice then
@@ -14430,6 +14996,9 @@ package body Exp_Ch4 is
-- usually implemented by looking in the ancestor tables contained in the
-- dispatch table pointed by Left_Expr.Tag for Typ'Tag
+ -- In both cases if Left_Expr is an access type, we first check whether it
+ -- is null.
+
-- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
-- function IW_Membership which is usually implemented by looking in the
-- table of abstract interface types plus the ancestor table contained in
@@ -14444,19 +15013,17 @@ package body Exp_Ch4 is
Right : constant Node_Id := Right_Opnd (N);
Loc : constant Source_Ptr := Sloc (N);
- Full_R_Typ : Entity_Id;
- Left_Type : Entity_Id;
- New_Node : Node_Id;
- Right_Type : Entity_Id;
- Obj_Tag : Node_Id;
+ -- Handle entities from the limited view
- begin
- SCIL_Node := Empty;
+ Orig_Right_Type : constant Entity_Id := Available_View (Etype (Right));
- -- Handle entities from the limited view
+ Full_R_Typ : Entity_Id;
+ Left_Type : Entity_Id := Available_View (Etype (Left));
+ Right_Type : Entity_Id := Orig_Right_Type;
+ Obj_Tag : Node_Id;
- Left_Type := Available_View (Etype (Left));
- Right_Type := Available_View (Etype (Right));
+ begin
+ SCIL_Node := Empty;
-- In the case where the type is an access type, the test is applied
-- using the designated types (needed in Ada 2012 for implicit anonymous
@@ -14530,7 +15097,7 @@ package body Exp_Ch4 is
or else Is_Interface (Left_Type)
then
-- Issue error if IW_Membership operation not available in a
- -- configurable run time setting.
+ -- configurable run-time setting.
if not RTE_Available (RE_IW_Membership) then
Error_Msg_CRT
@@ -14553,25 +15120,32 @@ package body Exp_Ch4 is
-- Ada 95: Normal case
else
- Build_CW_Membership (Loc,
- Obj_Tag_Node => Obj_Tag,
- Typ_Tag_Node =>
- New_Occurrence_Of (
- Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc),
- Related_Nod => N,
- New_Node => New_Node);
+ -- Issue error if CW_Membership operation not available in a
+ -- configurable run-time setting.
+
+ if not RTE_Available (RE_CW_Membership) then
+ Error_Msg_CRT
+ ("dynamic membership test on tagged types", N);
+ Result := Empty;
+ return;
+ end if;
+
+ Result :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (RE_CW_Membership), Loc),
+ Parameter_Associations => New_List (
+ Obj_Tag,
+ New_Occurrence_Of (
+ Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
+ Loc)));
-- Generate the SCIL node for this class-wide membership test.
- -- Done here because the previous call to Build_CW_Membership
- -- relocates Obj_Tag.
if Generate_SCIL then
SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
end if;
-
- Result := New_Node;
end if;
-- Right_Type is not a class-wide type
@@ -14591,6 +15165,29 @@ package body Exp_Ch4 is
(Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc));
end if;
end if;
+
+ -- if Left is an access object then generate test of the form:
+ -- * if Right_Type excludes null: Left /= null and then ...
+ -- * if Right_Type includes null: Left = null or else ...
+
+ if Is_Access_Type (Orig_Right_Type) then
+ if Can_Never_Be_Null (Orig_Right_Type) then
+ Result := Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => Left,
+ Right_Opnd => Make_Null (Loc)),
+ Right_Opnd => Result);
+
+ else
+ Result := Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Left,
+ Right_Opnd => Make_Null (Loc)),
+ Right_Opnd => Result);
+ end if;
+ end if;
end Tagged_Membership;
------------------------------
diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads
index 44872fd..ed5e236 100644
--- a/gcc/ada/exp_ch4.ads
+++ b/gcc/ada/exp_ch4.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index b30171e..309297b 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,7 +29,6 @@ with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
-with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
@@ -279,8 +278,9 @@ package body Exp_Ch5 is
begin
return
Nkind (Rhs) = N_Type_Conversion
- and then
- not Same_Representation (Etype (Rhs), Etype (Expression (Rhs)));
+ and then not Has_Compatible_Representation
+ (Target_Type => Etype (Rhs),
+ Operand_Type => Etype (Expression (Rhs)));
end Change_Of_Representation;
------------------------------
@@ -442,7 +442,7 @@ package body Exp_Ch5 is
-- respect to the right-hand side as given, not a possible underlying
-- renamed object, since this would generate incorrect extra checks.
- Apply_Length_Check (Rhs, L_Type);
+ Apply_Length_Check_On_Assignment (Rhs, L_Type, Lhs);
-- We start by assuming that the move can be done in either direction,
-- i.e. that the two sides are completely disjoint.
@@ -1452,17 +1452,14 @@ package body Exp_Ch5 is
L_Prefix_Comp : constant Boolean :=
-- True if the left-hand side is a slice of a component or slice
Nkind (Name (N)) = N_Slice
- and then Nkind_In (Prefix (Name (N)),
- N_Selected_Component,
- N_Indexed_Component,
- N_Slice);
+ and then Nkind (Prefix (Name (N))) in
+ N_Selected_Component | N_Indexed_Component | N_Slice;
R_Prefix_Comp : constant Boolean :=
-- Likewise for the right-hand side
Nkind (Expression (N)) = N_Slice
- and then Nkind_In (Prefix (Expression (N)),
- N_Selected_Component,
- N_Indexed_Component,
- N_Slice);
+ and then Nkind (Prefix (Expression (N))) in
+ N_Selected_Component | N_Indexed_Component | N_Slice;
+
begin
-- Determine whether Copy_Bitfield is appropriate (will work, and will
-- be more efficient than component-by-component copy). Copy_Bitfield
@@ -1522,7 +1519,7 @@ package body Exp_Ch5 is
-- be assigned.
elsif Possible_Bit_Aligned_Component (Lhs)
- or
+ or else
Possible_Bit_Aligned_Component (Rhs)
then
null;
@@ -1595,6 +1592,18 @@ package body Exp_Ch5 is
while Present (C) loop
if Chars (C) = Chars (Comp) then
return C;
+
+ -- The component may be a renamed discriminant, in
+ -- which case check against the name of the original
+ -- discriminant of the parent type.
+
+ elsif Is_Derived_Type (Scope (Comp))
+ and then Ekind (Comp) = E_Discriminant
+ and then Present (Corresponding_Discriminant (Comp))
+ and then
+ Chars (C) = Chars (Corresponding_Discriminant (Comp))
+ then
+ return C;
end if;
Next_Entity (C);
@@ -1887,8 +1896,8 @@ package body Exp_Ch5 is
-- We know the underlying type is a record, but its current view
-- may be private. We must retrieve the usable record declaration.
- if Nkind_In (Decl, N_Private_Type_Declaration,
- N_Private_Extension_Declaration)
+ if Nkind (Decl) in N_Private_Type_Declaration
+ | N_Private_Extension_Declaration
and then Present (Full_View (R_Typ))
then
RDef := Type_Definition (Declaration_Node (Full_View (R_Typ)));
@@ -2248,7 +2257,7 @@ package body Exp_Ch5 is
-- Since P is going to be evaluated more than once, any subscripts
-- in P must have their evaluation forced.
- if Nkind_In (Lhs, N_Indexed_Component, N_Selected_Component)
+ if Nkind (Lhs) in N_Indexed_Component | N_Selected_Component
and then Is_Ref_To_Bit_Packed_Array (Prefix (Lhs))
then
declare
@@ -2284,8 +2293,7 @@ package body Exp_Ch5 is
loop
Set_Analyzed (Exp, False);
- if Nkind_In (Exp, N_Indexed_Component,
- N_Selected_Component)
+ if Nkind (Exp) in N_Indexed_Component | N_Selected_Component
then
Exp := Prefix (Exp);
else
@@ -2448,38 +2456,7 @@ package body Exp_Ch5 is
if Is_Constrained (Etype (Lhs)) then
Apply_Length_Check (Rhs, Etype (Lhs));
end if;
-
- if Nkind (Rhs) = N_Allocator then
- declare
- Target_Typ : constant Entity_Id := Etype (Expression (Rhs));
- C_Es : Check_Result;
-
- begin
- C_Es :=
- Get_Range_Checks
- (Lhs,
- Target_Typ,
- Etype (Designated_Type (Etype (Lhs))));
-
- Insert_Range_Checks
- (C_Es,
- N,
- Target_Typ,
- Sloc (Lhs),
- Lhs);
- end;
- end if;
end if;
-
- -- Apply range check for access type case
-
- elsif Is_Access_Type (Etype (Lhs))
- and then Nkind (Rhs) = N_Allocator
- and then Nkind (Expression (Rhs)) = N_Qualified_Expression
- then
- Analyze_And_Resolve (Expression (Rhs));
- Apply_Range_Check
- (Expression (Rhs), Designated_Type (Etype (Lhs)));
end if;
-- Ada 2005 (AI-231): Generate the run-time check
@@ -2665,25 +2642,13 @@ package body Exp_Ch5 is
and then
not Restriction_Active (No_Dispatching_Calls))
then
- if Is_Limited_Type (Typ) then
-
- -- This can happen in an instance when the formal is an
- -- extension of a limited interface, and the actual is
- -- limited. This is an error according to AI05-0087, but
- -- is not caught at the point of instantiation in earlier
- -- versions. We also must verify that the limited type does
- -- not come from source as corner cases may exist where
- -- an assignment was not intended like the pathological case
- -- of a raise expression within a return statement.
-
- -- This is wrong, error messages cannot be issued during
- -- expansion, since they would be missed in -gnatc mode ???
-
- if Comes_From_Source (N) then
- Error_Msg_N
- ("assignment not available on limited type", N);
- end if;
+ -- We should normally not encounter any limited type here,
+ -- except in the corner case where an assignment was not
+ -- intended like the pathological case of a raise expression
+ -- within a return statement.
+ if Is_Limited_Type (Typ) then
+ pragma Assert (not Comes_From_Source (N));
return;
end if;
@@ -2896,8 +2861,8 @@ package body Exp_Ch5 is
Actual_Rhs : Node_Id := Rhs;
begin
- while Nkind_In (Actual_Rhs, N_Type_Conversion,
- N_Qualified_Expression)
+ while Nkind (Actual_Rhs) in
+ N_Type_Conversion | N_Qualified_Expression
loop
Actual_Rhs := Expression (Actual_Rhs);
end loop;
@@ -2971,7 +2936,7 @@ package body Exp_Ch5 is
-- Skip this if left-hand side is an array or record component
-- and elementary component validity checks are suppressed.
- if Nkind_In (Lhs, N_Selected_Component, N_Indexed_Component)
+ if Nkind (Lhs) in N_Selected_Component | N_Indexed_Component
and then not Validity_Check_Components
then
null;
@@ -3755,7 +3720,7 @@ package body Exp_Ch5 is
-- specific to pure if statements, however (see
-- Sem_Ch5.Analyze_If_Statement).
- Set_Comes_From_Source (New_If, Comes_From_Source (N));
+ Preserve_Comes_From_Source (New_If, N);
return;
-- No special processing for that elsif part, move to next
@@ -3775,9 +3740,9 @@ package body Exp_Ch5 is
-- Another optimization, special cases that can be simplified
-- if expression then
- -- return true;
+ -- return [standard.]true;
-- else
- -- return false;
+ -- return [standard.]false;
-- end if;
-- can be changed to:
@@ -3787,9 +3752,9 @@ package body Exp_Ch5 is
-- and
-- if expression then
- -- return false;
+ -- return [standard.]false;
-- else
- -- return true;
+ -- return [standard.]true;
-- end if;
-- can be changed to:
@@ -3822,9 +3787,9 @@ package body Exp_Ch5 is
Else_Expr : constant Node_Id := Expression (Else_Stm);
begin
- if Nkind (Then_Expr) = N_Identifier
+ if Nkind (Then_Expr) in N_Expanded_Name | N_Identifier
and then
- Nkind (Else_Expr) = N_Identifier
+ Nkind (Else_Expr) in N_Expanded_Name | N_Identifier
then
if Entity (Then_Expr) = Standard_True
and then Entity (Else_Expr) = Standard_False
@@ -3900,15 +3865,20 @@ package body Exp_Ch5 is
Array_Dim : constant Pos := Number_Dimensions (Array_Typ);
Id : constant Entity_Id := Defining_Identifier (I_Spec);
Loc : constant Source_Ptr := Sloc (Isc);
- Stats : constant List_Id := Statements (N);
+ Stats : List_Id := Statements (N);
Core_Loop : Node_Id;
Dim1 : Int;
Ind_Comp : Node_Id;
Iterator : Entity_Id;
- -- Start of processing for Expand_Iterator_Loop_Over_Array
-
begin
+ if Present (Iterator_Filter (I_Spec)) then
+ pragma Assert (Ada_Version >= Ada_2020);
+ Stats := New_List (Make_If_Statement (Loc,
+ Condition => Iterator_Filter (I_Spec),
+ Then_Statements => Stats));
+ end if;
+
-- for Element of Array loop
-- It requires an internally generated cursor to iterate over the array
@@ -4179,7 +4149,9 @@ package body Exp_Ch5 is
Elem_Typ : constant Entity_Id := Etype (Id);
Id_Kind : constant Entity_Kind := Ekind (Id);
Loc : constant Source_Ptr := Sloc (N);
- Stats : constant List_Id := Statements (N);
+
+ Stats : List_Id := Statements (N);
+ -- Maybe wrapped in a conditional if a filter is present
Cursor : Entity_Id;
Decl : Node_Id;
@@ -4201,6 +4173,13 @@ package body Exp_Ch5 is
-- The package in which the container type is declared
begin
+ if Present (Iterator_Filter (I_Spec)) then
+ pragma Assert (Ada_Version >= Ada_2020);
+ Stats := New_List (Make_If_Statement (Loc,
+ Condition => Iterator_Filter (I_Spec),
+ Then_Statements => Stats));
+ end if;
+
-- Determine the advancement and initialization steps for the cursor.
-- Analysis of the expanded loop will verify that the container has a
-- reverse iterator.
@@ -4674,11 +4653,20 @@ package body Exp_Ch5 is
Loop_Id : constant Entity_Id := Defining_Identifier (LPS);
Ltype : constant Entity_Id := Etype (Loop_Id);
Btype : constant Entity_Id := Base_Type (Ltype);
+ Stats : constant List_Id := Statements (N);
Expr : Node_Id;
Decls : List_Id;
New_Id : Entity_Id;
begin
+ if Present (Iterator_Filter (LPS)) then
+ pragma Assert (Ada_Version >= Ada_2020);
+ Set_Statements (N,
+ New_List (Make_If_Statement (Loc,
+ Condition => Iterator_Filter (LPS),
+ Then_Statements => Stats)));
+ end if;
+
-- Deal with loop over predicates
if Is_Discrete_Type (Ltype)
@@ -4795,7 +4783,7 @@ package body Exp_Ch5 is
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Statements (N)))),
+ Statements => Stats))),
End_Label => End_Label (N)));
@@ -4897,7 +4885,7 @@ package body Exp_Ch5 is
end if;
end if;
- -- When the iteration scheme mentiones attribute 'Loop_Entry, the loop
+ -- When the iteration scheme mentions attribute 'Loop_Entry, the loop
-- is transformed into a conditional block where the original loop is
-- the sole statement. Inspect the statements of the nested loop for
-- controlled objects.
@@ -4921,13 +4909,14 @@ package body Exp_Ch5 is
-- mode, the semantic analyzer may disallow one or both forms.
procedure Expand_Predicated_Loop (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Isc : constant Node_Id := Iteration_Scheme (N);
- LPS : constant Node_Id := Loop_Parameter_Specification (Isc);
- Loop_Id : constant Entity_Id := Defining_Identifier (LPS);
- Ltype : constant Entity_Id := Etype (Loop_Id);
- Stat : constant List_Id := Static_Discrete_Predicate (Ltype);
- Stmts : constant List_Id := Statements (N);
+ Orig_Loop_Id : Node_Id := Empty;
+ Loc : constant Source_Ptr := Sloc (N);
+ Isc : constant Node_Id := Iteration_Scheme (N);
+ LPS : constant Node_Id := Loop_Parameter_Specification (Isc);
+ Loop_Id : constant Entity_Id := Defining_Identifier (LPS);
+ Ltype : constant Entity_Id := Etype (Loop_Id);
+ Stat : constant List_Id := Static_Discrete_Predicate (Ltype);
+ Stmts : constant List_Id := Statements (N);
begin
-- Case of iteration over non-static predicate, should not be possible
@@ -5206,7 +5195,13 @@ package body Exp_Ch5 is
Alternatives => Alts);
Append_To (Stmts, Cstm);
- -- Rewrite the loop
+ -- Rewrite the loop preserving the loop identifier in case there
+ -- are exit statements referencing it.
+
+ if Present (Identifier (N)) then
+ Orig_Loop_Id := New_Occurrence_Of
+ (Entity (Identifier (N)), Loc);
+ end if;
Set_Suppress_Assignment_Checks (D);
@@ -5218,6 +5213,7 @@ package body Exp_Ch5 is
Statements => New_List (
Make_Loop_Statement (Loc,
Statements => Stmts,
+ Identifier => Orig_Loop_Id,
End_Label => Empty)))));
Analyze (N);
diff --git a/gcc/ada/exp_ch5.ads b/gcc/ada/exp_ch5.ads
index 052dd2c..f4cb868 100644
--- a/gcc/ada/exp_ch5.ads
+++ b/gcc/ada/exp_ch5.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index b50e5d0..57d3884 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -78,6 +78,15 @@ with Validsw; use Validsw;
package body Exp_Ch6 is
+ -- Suffix for BIP formals
+
+ BIP_Alloc_Suffix : constant String := "BIPalloc";
+ BIP_Storage_Pool_Suffix : constant String := "BIPstoragepool";
+ BIP_Finalization_Master_Suffix : constant String := "BIPfinalizationmaster";
+ BIP_Task_Master_Suffix : constant String := "BIPtaskmaster";
+ BIP_Activation_Chain_Suffix : constant String := "BIPactivationchain";
+ BIP_Object_Access_Suffix : constant String := "BIPaccess";
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -137,6 +146,16 @@ package body Exp_Ch6 is
-- the activation Chain. Note: Master_Actual can be Empty, but only if
-- there are no tasks.
+ procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id);
+ -- Ada 2005 (AI95-344): If the result type is class-wide, insert a check
+ -- that the level of the return expression's underlying type is not deeper
+ -- than the level of the master enclosing the function. Always generate the
+ -- check when the type of the return expression is class-wide, when it's a
+ -- type conversion, or when it's a formal parameter. Otherwise suppress the
+ -- check in the case where the return expression has a specific type whose
+ -- level is known not to be statically deeper than the result type of the
+ -- function.
+
function Caller_Known_Size
(Func_Call : Node_Id;
Result_Subt : Entity_Id) return Boolean;
@@ -146,6 +165,12 @@ package body Exp_Ch6 is
-- access discriminants do not require secondary stack use. Note we must
-- always use the secondary stack for dispatching-on-result calls.
+ function Check_BIP_Actuals
+ (Subp_Call : Node_Id;
+ Subp_Id : Entity_Id) return Boolean;
+ -- Given a subprogram call to the given subprogram return True if the
+ -- names of BIP extra actual and formal parameters match.
+
function Check_Number_Of_Actuals
(Subp_Call : Node_Id;
Subp_Id : Entity_Id) return Boolean;
@@ -244,10 +269,14 @@ package body Exp_Ch6 is
-- Expand simple return from function. In the case where we are returning
-- from a function body this is called by Expand_N_Simple_Return_Statement.
- function Has_Unconstrained_Access_Discriminants
- (Subtyp : Entity_Id) return Boolean;
- -- Returns True if the given subtype is unconstrained and has one or more
- -- access discriminants.
+ function Has_BIP_Extra_Formal
+ (E : Entity_Id;
+ Kind : BIP_Formal_Kind) return Boolean;
+ -- Given a frozen subprogram, subprogram type, entry or entry family,
+ -- return True if E has the BIP extra formal associated with Kind. It must
+ -- be invoked with a frozen entity or a subprogram type of a dispatching
+ -- call since we can only rely on the availability of the extra formals
+ -- on these entities.
procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id);
-- Insert the Post_Call list previously produced by routine Expand_Actuals
@@ -277,6 +306,10 @@ package body Exp_Ch6 is
-- out of. This ensures that the secondary stack is not released; otherwise
-- the function result would be reclaimed before returning to the caller.
+ procedure Warn_BIP (Func_Call : Node_Id);
+ -- Give a warning on a build-in-place function call if the -gnatd_B switch
+ -- was given.
+
----------------------------------------------
-- Add_Access_Actual_To_Build_In_Place_Call --
----------------------------------------------
@@ -615,6 +648,115 @@ package body Exp_Ch6 is
Add_Extra_Actual_To_Call (Function_Call, Chain_Formal, Chain_Actual);
end Add_Task_Actuals_To_Build_In_Place_Call;
+ ----------------------------------
+ -- Apply_CW_Accessibility_Check --
+ ----------------------------------
+
+ procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (Exp);
+
+ begin
+ if Ada_Version >= Ada_2005
+ and then Tagged_Type_Expansion
+ and then not Scope_Suppress.Suppress (Accessibility_Check)
+ and then
+ (Is_Class_Wide_Type (Etype (Exp))
+ or else Nkind (Exp) in
+ N_Type_Conversion | N_Unchecked_Type_Conversion
+ or else (Is_Entity_Name (Exp)
+ and then Is_Formal (Entity (Exp)))
+ or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) >
+ Scope_Depth (Enclosing_Dynamic_Scope (Func)))
+ then
+ declare
+ Tag_Node : Node_Id;
+
+ begin
+ -- Ada 2005 (AI-251): In class-wide interface objects we displace
+ -- "this" to reference the base of the object. This is required to
+ -- get access to the TSD of the object.
+
+ if Is_Class_Wide_Type (Etype (Exp))
+ and then Is_Interface (Etype (Exp))
+ then
+ -- If the expression is an explicit dereference then we can
+ -- directly displace the pointer to reference the base of
+ -- the object.
+
+ if Nkind (Exp) = N_Explicit_Dereference then
+ Tag_Node :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Base_Address), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Address),
+ Duplicate_Subexpr (Prefix (Exp)))))));
+
+ -- Similar case to the previous one but the expression is a
+ -- renaming of an explicit dereference.
+
+ elsif Nkind (Exp) = N_Identifier
+ and then Present (Renamed_Object (Entity (Exp)))
+ and then Nkind (Renamed_Object (Entity (Exp)))
+ = N_Explicit_Dereference
+ then
+ Tag_Node :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Base_Address), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Address),
+ Duplicate_Subexpr
+ (Prefix
+ (Renamed_Object (Entity (Exp)))))))));
+
+ -- Common case: obtain the address of the actual object and
+ -- displace the pointer to reference the base of the object.
+
+ else
+ Tag_Node :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Base_Address), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Exp),
+ Attribute_Name => Name_Address)))));
+ end if;
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Exp),
+ Attribute_Name => Name_Tag);
+ end if;
+
+ -- CodePeer does not do anything useful with
+ -- Ada.Tags.Type_Specific_Data components.
+
+ if not CodePeer_Mode then
+ Insert_Action (Exp,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ Scope_Depth (Enclosing_Dynamic_Scope (Func)))),
+ Reason => PE_Accessibility_Check_Failed));
+ end if;
+ end;
+ end if;
+ end Apply_CW_Accessibility_Check;
+
-----------------------
-- BIP_Formal_Suffix --
-----------------------
@@ -623,25 +765,68 @@ package body Exp_Ch6 is
begin
case Kind is
when BIP_Alloc_Form =>
- return "BIPalloc";
+ return BIP_Alloc_Suffix;
when BIP_Storage_Pool =>
- return "BIPstoragepool";
+ return BIP_Storage_Pool_Suffix;
when BIP_Finalization_Master =>
- return "BIPfinalizationmaster";
+ return BIP_Finalization_Master_Suffix;
when BIP_Task_Master =>
- return "BIPtaskmaster";
+ return BIP_Task_Master_Suffix;
when BIP_Activation_Chain =>
- return "BIPactivationchain";
+ return BIP_Activation_Chain_Suffix;
when BIP_Object_Access =>
- return "BIPaccess";
+ return BIP_Object_Access_Suffix;
end case;
end BIP_Formal_Suffix;
+ ---------------------
+ -- BIP_Suffix_Kind --
+ ---------------------
+
+ function BIP_Suffix_Kind (E : Entity_Id) return BIP_Formal_Kind is
+ Nam : constant String := Get_Name_String (Chars (E));
+
+ function Has_Suffix (Suffix : String) return Boolean;
+ -- Return True if Nam has suffix Suffix
+
+ function Has_Suffix (Suffix : String) return Boolean is
+ Len : constant Natural := Suffix'Length;
+ begin
+ return Nam'Length > Len
+ and then Nam (Nam'Last - Len + 1 .. Nam'Last) = Suffix;
+ end Has_Suffix;
+
+ -- Start of processing for BIP_Suffix_Kind
+
+ begin
+ if Has_Suffix (BIP_Alloc_Suffix) then
+ return BIP_Alloc_Form;
+
+ elsif Has_Suffix (BIP_Storage_Pool_Suffix) then
+ return BIP_Storage_Pool;
+
+ elsif Has_Suffix (BIP_Finalization_Master_Suffix) then
+ return BIP_Finalization_Master;
+
+ elsif Has_Suffix (BIP_Task_Master_Suffix) then
+ return BIP_Task_Master;
+
+ elsif Has_Suffix (BIP_Activation_Chain_Suffix) then
+ return BIP_Activation_Chain;
+
+ elsif Has_Suffix (BIP_Object_Access_Suffix) then
+ return BIP_Object_Access;
+
+ else
+ raise Program_Error;
+ end if;
+ end BIP_Suffix_Kind;
+
---------------------------
-- Build_In_Place_Formal --
---------------------------
@@ -650,8 +835,8 @@ package body Exp_Ch6 is
(Func : Entity_Id;
Kind : BIP_Formal_Kind) return Entity_Id
is
+ Extra_Formal : Entity_Id := Extra_Formals (Func);
Formal_Suffix : constant String := BIP_Formal_Suffix (Kind);
- Extra_Formal : Entity_Id := Extra_Formals (Func);
begin
-- Maybe it would be better for each implicit formal of a build-in-place
@@ -873,6 +1058,42 @@ package body Exp_Ch6 is
or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
end Caller_Known_Size;
+ -----------------------
+ -- Check_BIP_Actuals --
+ -----------------------
+
+ function Check_BIP_Actuals
+ (Subp_Call : Node_Id;
+ Subp_Id : Entity_Id) return Boolean
+ is
+ Formal : Entity_Id;
+ Actual : Node_Id;
+
+ begin
+ pragma Assert (Nkind (Subp_Call) in N_Entry_Call_Statement
+ | N_Function_Call
+ | N_Procedure_Call_Statement);
+
+ Formal := First_Formal_With_Extras (Subp_Id);
+ Actual := First_Actual (Subp_Call);
+
+ while Present (Formal) and then Present (Actual) loop
+ if Is_Build_In_Place_Entity (Formal)
+ and then Nkind (Actual) = N_Identifier
+ and then Is_Build_In_Place_Entity (Entity (Actual))
+ and then BIP_Suffix_Kind (Formal)
+ /= BIP_Suffix_Kind (Entity (Actual))
+ then
+ return False;
+ end if;
+
+ Next_Formal_With_Extras (Formal);
+ Next_Actual (Actual);
+ end loop;
+
+ return No (Formal) and then No (Actual);
+ end Check_BIP_Actuals;
+
-----------------------------
-- Check_Number_Of_Actuals --
-----------------------------
@@ -885,9 +1106,9 @@ package body Exp_Ch6 is
Actual : Node_Id;
begin
- pragma Assert (Nkind_In (Subp_Call, N_Entry_Call_Statement,
- N_Function_Call,
- N_Procedure_Call_Statement));
+ pragma Assert (Nkind (Subp_Call) in N_Entry_Call_Statement
+ | N_Function_Call
+ | N_Procedure_Call_Statement);
Formal := First_Formal_With_Extras (Subp_Id);
Actual := First_Actual (Subp_Call);
@@ -1252,11 +1473,16 @@ package body Exp_Ch6 is
-- also takes care of any constraint checks required for the type
-- conversion case (on both the way in and the way out).
- procedure Add_Simple_Call_By_Copy_Code (Bit_Packed_Array : Boolean);
+ procedure Add_Simple_Call_By_Copy_Code (Force : Boolean);
-- This is similar to the above, but is used in cases where we know
-- that all that is needed is to simply create a temporary and copy
- -- the value in and out of the temporary. If Bit_Packed_Array is True,
- -- the procedure is called for a bit-packed array actual.
+ -- the value in and out of the temporary. If Force is True, then the
+ -- procedure may disregard legality considerations.
+
+ -- ??? We need to do the copy for a bit-packed array because this is
+ -- where the rewriting into a mask-and-shift sequence is done. But of
+ -- course this may break the program if it expects bits to be really
+ -- passed by reference. That's what we have done historically though.
procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id);
-- Perform copy-back for actual parameter Act which denotes a validation
@@ -1345,8 +1571,9 @@ package body Exp_Ch6 is
Var := Make_Var (Expression (Actual));
- Crep := not Same_Representation
- (F_Typ, Etype (Expression (Actual)));
+ Crep := not Has_Compatible_Representation
+ (Target_Type => F_Typ,
+ Operand_Type => Etype (Expression (Actual)));
else
V_Typ := Etype (Actual);
@@ -1451,6 +1678,25 @@ package body Exp_Ch6 is
then
Init := New_Occurrence_Of (Var, Loc);
+ -- View conversions when the formal type has the Default_Value aspect
+ -- require passing in the value of the conversion's operand. The type
+ -- of that operand also has Default_Value, as required by AI12-0074
+ -- (RM 6.4.1(5.3/4)). The subtype denoted by the subtype_indication
+ -- is changed to the base type of the formal subtype, to ensure that
+ -- the actual's value can be assigned without a constraint check
+ -- (note that no check is done on passing to an out parameter). Also
+ -- note that the two types necessarily share the same ancestor type,
+ -- as required by 6.4.1(5.2/4), so underlying base types will match.
+
+ elsif Ekind (Formal) = E_Out_Parameter
+ and then Is_Scalar_Type (Etype (F_Typ))
+ and then Nkind (Actual) = N_Type_Conversion
+ and then Present (Default_Aspect_Value (Etype (F_Typ)))
+ then
+ Indic := New_Occurrence_Of (Base_Type (F_Typ), Loc);
+ Init := Convert_To
+ (Base_Type (F_Typ), New_Occurrence_Of (Var, Loc));
+
else
Init := Empty;
end if;
@@ -1615,7 +1861,7 @@ package body Exp_Ch6 is
-- Add_Simple_Call_By_Copy_Code --
----------------------------------
- procedure Add_Simple_Call_By_Copy_Code (Bit_Packed_Array : Boolean) is
+ procedure Add_Simple_Call_By_Copy_Code (Force : Boolean) is
Decl : Node_Id;
F_Typ : Entity_Id := Etype (Formal);
Incod : Node_Id;
@@ -1626,12 +1872,9 @@ package body Exp_Ch6 is
Temp : Entity_Id;
begin
- -- ??? We need to do the copy for a bit-packed array because this is
- -- where the rewriting into a mask-and-shift sequence is done. But of
- -- course this may break the program if it expects bits to be really
- -- passed by reference. That's what we have done historically though.
+ -- Unless forced not to, check the legality of the copy operation
- if not Bit_Packed_Array and then not Is_Legal_Copy then
+ if not Force and then not Is_Legal_Copy then
return;
end if;
@@ -1937,7 +2180,7 @@ package body Exp_Ch6 is
loop
Set_Analyzed (Pfx, False);
exit when
- not Nkind_In (Pfx, N_Selected_Component, N_Indexed_Component);
+ Nkind (Pfx) not in N_Selected_Component | N_Indexed_Component;
Pfx := Prefix (Pfx);
end loop;
end Reset_Packed_Prefix;
@@ -1954,13 +2197,20 @@ package body Exp_Ch6 is
return False;
end if;
+ -- There is no requirement inside initialization procedures and this
+ -- would generate copies for atomic or volatile composite components.
+
+ if Inside_Init_Proc then
+ return False;
+ end if;
+
-- Check for atomicity mismatch
if Is_Atomic_Object (Actual) and then not Is_Atomic (E_Formal)
then
if Comes_From_Source (N) then
Error_Msg_N
- ("?atomic actual passed by copy (RM C.6(19))", Actual);
+ ("??atomic actual passed by copy (RM C.6(19))", Actual);
end if;
return True;
end if;
@@ -1971,7 +2221,7 @@ package body Exp_Ch6 is
then
if Comes_From_Source (N) then
Error_Msg_N
- ("?volatile actual passed by copy (RM C.6(19))", Actual);
+ ("??volatile actual passed by copy (RM C.6(19))", Actual);
end if;
return True;
end if;
@@ -2027,13 +2277,24 @@ package body Exp_Ch6 is
-- Ada 2005 (AI-318-02): If the actual parameter is a call to a
-- build-in-place function, then a temporary return object needs
- -- to be created and access to it must be passed to the function.
+ -- to be created and access to it must be passed to the function
+ -- (and ensure that we have an activation chain defined for tasks
+ -- and a Master variable).
+
-- Currently we limit such functions to those with inherently
-- limited result subtypes, but eventually we plan to expand the
-- functions that are treated as build-in-place to include other
-- composite result types.
- if Is_Build_In_Place_Function_Call (Actual) then
+ -- But do not do it here for intrinsic subprograms since this will
+ -- be done properly after the subprogram is expanded.
+
+ if Is_Intrinsic_Subprogram (Subp) then
+ null;
+
+ elsif Is_Build_In_Place_Function_Call (Actual) then
+ Build_Activation_Chain_Entity (N);
+ Build_Master_Entity (Etype (Actual));
Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
-- Ada 2005 (AI-318-02): Specialization of the previous case for
@@ -2041,6 +2302,8 @@ package body Exp_Ch6 is
-- object covers interface types.
elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then
+ Build_Activation_Chain_Entity (N);
+ Build_Master_Entity (Etype (Actual));
Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual);
end if;
@@ -2111,9 +2374,9 @@ package body Exp_Ch6 is
-- Also pass by copy if change of representation
- or else not Same_Representation
- (Etype (Formal),
- Etype (Expression (Actual))))
+ or else not Has_Compatible_Representation
+ (Target_Type => Etype (Formal),
+ Operand_Type => Etype (Expression (Actual))))
then
Add_Call_By_Copy_Code;
@@ -2123,7 +2386,7 @@ package body Exp_Ch6 is
-- [in] out parameters.
elsif Is_Ref_To_Bit_Packed_Array (Actual) then
- Add_Simple_Call_By_Copy_Code (Bit_Packed_Array => True);
+ Add_Simple_Call_By_Copy_Code (Force => True);
-- If a nonscalar actual is possibly bit-aligned, we need a copy
-- because the back-end cannot cope with such objects. In other
@@ -2139,7 +2402,7 @@ package body Exp_Ch6 is
Component_May_Be_Bit_Aligned (Entity (Selector_Name (Actual)))
and then not Represented_As_Scalar (Etype (Formal))
then
- Add_Simple_Call_By_Copy_Code (Bit_Packed_Array => False);
+ Add_Simple_Call_By_Copy_Code (Force => False);
-- References to slices of bit-packed arrays are expanded
@@ -2210,46 +2473,6 @@ package body Exp_Ch6 is
Aund : constant Entity_Id := Underlying_Type (E_Actual);
Atyp : Entity_Id;
- function Is_Public_Subp return Boolean;
- -- Check whether the subprogram being called is a visible
- -- operation of the type of the actual. Used to determine
- -- whether an invariant check must be generated on the
- -- caller side.
-
- ---------------------
- -- Is_Public_Subp --
- ---------------------
-
- function Is_Public_Subp return Boolean is
- Pack : constant Entity_Id := Scope (Subp);
- Subp_Decl : Node_Id;
-
- begin
- if not Is_Subprogram (Subp) then
- return False;
-
- -- The operation may be inherited, or a primitive of the
- -- root type.
-
- elsif
- Nkind_In (Parent (Subp), N_Private_Extension_Declaration,
- N_Full_Type_Declaration)
- then
- Subp_Decl := Parent (Subp);
-
- else
- Subp_Decl := Unit_Declaration_Node (Subp);
- end if;
-
- return Ekind (Pack) = E_Package
- and then
- List_Containing (Subp_Decl) =
- Visible_Declarations
- (Specification (Unit_Declaration_Node (Pack)));
- end Is_Public_Subp;
-
- -- Start of processing for By_Ref_Predicate_Check
-
begin
if No (Aund) then
Atyp := E_Actual;
@@ -2257,8 +2480,7 @@ package body Exp_Ch6 is
Atyp := Aund;
end if;
- if Has_Predicates (Atyp)
- and then Present (Predicate_Function (Atyp))
+ if Predicate_Enabled (Atyp)
-- Skip predicate checks for special cases
@@ -2267,33 +2489,6 @@ package body Exp_Ch6 is
Append_To (Post_Call,
Make_Predicate_Check (Atyp, Actual));
end if;
-
- -- We generated caller-side invariant checks in two cases:
-
- -- a) when calling an inherited operation, where there is an
- -- implicit view conversion of the actual to the parent type.
-
- -- b) When the conversion is explicit
-
- -- We treat these cases separately because the required
- -- conversion for a) is added later when expanding the call.
-
- if Has_Invariants (Etype (Actual))
- and then
- Nkind (Parent (Subp)) = N_Private_Extension_Declaration
- then
- if Comes_From_Source (N) and then Is_Public_Subp then
- Append_To (Post_Call, Make_Invariant_Call (Actual));
- end if;
-
- elsif Nkind (Actual) = N_Type_Conversion
- and then Has_Invariants (Etype (Expression (Actual)))
- then
- if Comes_From_Source (N) and then Is_Public_Subp then
- Append_To (Post_Call,
- Make_Invariant_Call (Expression (Actual)));
- end if;
- end if;
end By_Ref_Predicate_Check;
-- Processing for IN parameters
@@ -2325,14 +2520,19 @@ package body Exp_Ch6 is
-- Is this really necessary in all cases???
elsif Is_Ref_To_Bit_Packed_Array (Actual) then
- Add_Simple_Call_By_Copy_Code (Bit_Packed_Array => True);
+ Add_Simple_Call_By_Copy_Code (Force => True);
+
+ -- If we have a C++ constructor call, we need to create the object
+
+ elsif Is_CPP_Constructor_Call (Actual) then
+ Add_Simple_Call_By_Copy_Code (Force => True);
-- If a nonscalar actual is possibly unaligned, we need a copy
elsif Is_Possibly_Unaligned_Object (Actual)
and then not Represented_As_Scalar (Etype (Formal))
then
- Add_Simple_Call_By_Copy_Code (Bit_Packed_Array => False);
+ Add_Simple_Call_By_Copy_Code (Force => False);
-- Similarly, we have to expand slices of packed arrays here
-- because the result must be byte aligned.
@@ -2373,6 +2573,85 @@ package body Exp_Ch6 is
end if;
end if;
+ -- Type-invariant checks for in-out and out parameters, as well as
+ -- for in parameters of procedures (AI05-0289 and AI12-0044).
+
+ if Ekind (Formal) /= E_In_Parameter
+ or else Ekind (Subp) = E_Procedure
+ then
+ Caller_Side_Invariant_Checks : declare
+
+ function Is_Public_Subp return Boolean;
+ -- Check whether the subprogram being called is a visible
+ -- operation of the type of the actual. Used to determine
+ -- whether an invariant check must be generated on the
+ -- caller side.
+
+ ---------------------
+ -- Is_Public_Subp --
+ ---------------------
+
+ function Is_Public_Subp return Boolean is
+ Pack : constant Entity_Id := Scope (Subp);
+ Subp_Decl : Node_Id;
+
+ begin
+ if not Is_Subprogram (Subp) then
+ return False;
+
+ -- The operation may be inherited, or a primitive of the
+ -- root type.
+
+ elsif
+ Nkind (Parent (Subp)) in N_Private_Extension_Declaration
+ | N_Full_Type_Declaration
+ then
+ Subp_Decl := Parent (Subp);
+
+ else
+ Subp_Decl := Unit_Declaration_Node (Subp);
+ end if;
+
+ return Ekind (Pack) = E_Package
+ and then
+ List_Containing (Subp_Decl) =
+ Visible_Declarations
+ (Specification (Unit_Declaration_Node (Pack)));
+ end Is_Public_Subp;
+
+ -- Start of processing for Caller_Side_Invariant_Checks
+
+ begin
+ -- We generate caller-side invariant checks in two cases:
+
+ -- a) when calling an inherited operation, where there is an
+ -- implicit view conversion of the actual to the parent type.
+
+ -- b) When the conversion is explicit
+
+ -- We treat these cases separately because the required
+ -- conversion for a) is added later when expanding the call.
+
+ if Has_Invariants (Etype (Actual))
+ and then
+ Nkind (Parent (Etype (Actual)))
+ = N_Private_Extension_Declaration
+ then
+ if Comes_From_Source (N) and then Is_Public_Subp then
+ Append_To (Post_Call, Make_Invariant_Call (Actual));
+ end if;
+
+ elsif Nkind (Actual) = N_Type_Conversion
+ and then Has_Invariants (Etype (Expression (Actual)))
+ then
+ if Comes_From_Source (N) and then Is_Public_Subp then
+ Append_To
+ (Post_Call, Make_Invariant_Call (Expression (Actual)));
+ end if;
+ end if;
+ end Caller_Side_Invariant_Checks;
+ end if;
+
Next_Formal (Formal);
Next_Actual (Actual);
end loop;
@@ -2385,13 +2664,93 @@ package body Exp_Ch6 is
procedure Expand_Call (N : Node_Id) is
Post_Call : List_Id;
+ -- If this is an indirect call through an Access_To_Subprogram
+ -- with contract specifications, it is rewritten as a call to
+ -- the corresponding Access_Subprogram_Wrapper with the same
+ -- actuals, whose body contains a naked indirect call (which
+ -- itself must not be rewritten, to prevent infinite recursion).
+
+ Must_Rewrite_Indirect_Call : constant Boolean :=
+ Ada_Version >= Ada_2020
+ and then Nkind (Name (N)) = N_Explicit_Dereference
+ and then Ekind (Etype (Name (N))) = E_Subprogram_Type
+ and then Present
+ (Access_Subprogram_Wrapper (Etype (Name (N))));
+
begin
- pragma Assert (Nkind_In (N, N_Entry_Call_Statement,
- N_Function_Call,
- N_Procedure_Call_Statement));
+ pragma Assert (Nkind (N) in N_Entry_Call_Statement
+ | N_Function_Call
+ | N_Procedure_Call_Statement);
+
+ -- Check that this is not the call in the body of the wrapper.
- Expand_Call_Helper (N, Post_Call);
- Insert_Post_Call_Actions (N, Post_Call);
+ if Must_Rewrite_Indirect_Call
+ and then (not Is_Overloadable (Current_Scope)
+ or else not Is_Access_Subprogram_Wrapper (Current_Scope))
+ then
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Wrapper : constant Entity_Id :=
+ Access_Subprogram_Wrapper (Etype (Name (N)));
+ Ptr : constant Node_Id := Prefix (Name (N));
+ Ptr_Type : constant Entity_Id := Etype (Ptr);
+ Typ : constant Entity_Id := Etype (N);
+
+ New_N : Node_Id;
+ Parms : List_Id := Parameter_Associations (N);
+ Ptr_Act : Node_Id;
+
+ begin
+ -- The last actual in the call is the pointer itself.
+ -- If the aspect is inherited, convert the pointer to the
+ -- parent type that specifies the contract.
+ -- If the original access_to_subprogram has defaults for
+ -- in_parameters, the call may include named associations, so
+ -- we create one for the pointer as well.
+
+ if Is_Derived_Type (Ptr_Type)
+ and then Ptr_Type /= Etype (Last_Formal (Wrapper))
+ then
+ Ptr_Act :=
+ Make_Type_Conversion (Loc,
+ New_Occurrence_Of
+ (Etype (Last_Formal (Wrapper)), Loc), Ptr);
+
+ else
+ Ptr_Act := Ptr;
+ end if;
+
+ -- Handle parameterless subprogram.
+
+ if No (Parms) then
+ Parms := New_List;
+ end if;
+
+ Append
+ (Make_Parameter_Association (Loc,
+ Selector_Name => Make_Identifier (Loc,
+ Chars (Last_Formal (Wrapper))),
+ Explicit_Actual_Parameter => Ptr_Act),
+ Parms);
+
+ if Nkind (N) = N_Procedure_Call_Statement then
+ New_N := Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Wrapper, Loc),
+ Parameter_Associations => Parms);
+ else
+ New_N := Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Wrapper, Loc),
+ Parameter_Associations => Parms);
+ end if;
+
+ Rewrite (N, New_N);
+ Analyze_And_Resolve (N, Typ);
+ end;
+
+ else
+ Expand_Call_Helper (N, Post_Call);
+ Insert_Post_Call_Actions (N, Post_Call);
+ end if;
end Expand_Call;
------------------------
@@ -2587,7 +2946,7 @@ package body Exp_Ch6 is
end loop;
if not Is_Empty_List (Inv_Checks) then
- Insert_Actions_After (N, Inv_Checks);
+ Insert_Actions_After (Call_Node, Inv_Checks);
end if;
end Add_View_Conversion_Invariants;
@@ -2861,7 +3220,7 @@ package body Exp_Ch6 is
Formal : Node_Id;
begin
- Actual := First (Parameter_Associations (N));
+ Actual := First (Parameter_Associations (Call_Node));
Formal := First_Formal (Subp);
while Present (Actual)
and then Present (Formal)
@@ -2905,7 +3264,7 @@ package body Exp_Ch6 is
Param_Count : Natural := 0;
Parent_Formal : Entity_Id;
Parent_Subp : Entity_Id;
- Pref_Entity : Entity_Id;
+ Prev_Ult : Node_Id;
Scop : Entity_Id;
Subp : Entity_Id;
@@ -2928,7 +3287,7 @@ package body Exp_Ch6 is
if Ada_Version >= Ada_2012
and then
- Nkind_In (Call_Node, N_Procedure_Call_Statement, N_Function_Call)
+ Nkind (Call_Node) in N_Procedure_Call_Statement | N_Function_Call
and then Present (Parameter_Associations (Call_Node))
then
Expand_Put_Call_With_Symbol (Call_Node);
@@ -3163,6 +3522,8 @@ package body Exp_Ch6 is
Expand_Actuals (Call_Node, Subp, Post_Call);
pragma Assert (Is_Empty_List (Post_Call));
+ pragma Assert (Check_Number_Of_Actuals (Call_Node, Subp));
+ pragma Assert (Check_BIP_Actuals (Call_Node, Subp));
return;
end;
end if;
@@ -3226,8 +3587,8 @@ package body Exp_Ch6 is
-- as out parameter actuals on calls to stream procedures.
Act_Prev := Prev;
- while Nkind_In (Act_Prev, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ while Nkind (Act_Prev) in N_Type_Conversion
+ | N_Unchecked_Type_Conversion
loop
Act_Prev := Expression (Act_Prev);
end loop;
@@ -3303,6 +3664,19 @@ package body Exp_Ch6 is
then
Prev_Orig := Prev;
+ -- If the actual is an attribute reference that was expanded
+ -- into a reference to an entity, then get accessibility level
+ -- from that entity. AARM 6.1.1(27.d) says "... the implicit
+ -- constant declaration defines the accessibility level of X'Old".
+
+ elsif Nkind (Prev_Orig) = N_Attribute_Reference
+ and then Attribute_Name (Prev_Orig) in Name_Old | Name_Loop_Entry
+ and then Is_Entity_Name (Prev)
+ and then Present (Entity (Prev))
+ and then Is_Object (Entity (Prev))
+ then
+ Prev_Orig := Prev;
+
elsif Nkind (Prev_Orig) = N_Type_Conversion then
Prev_Orig := Expression (Prev_Orig);
end if;
@@ -3450,60 +3824,30 @@ package body Exp_Ch6 is
Expression (Original_Node (Prev_Orig));
end if;
- -- If this is an Access attribute applied to the
- -- the current instance object passed to a type
- -- initialization procedure, then use the level
- -- of the type itself. This is not really correct,
- -- as there should be an extra level parameter
- -- passed in with _init formals (only in the case
- -- where the type is immutably limited), but we
- -- don't have an easy way currently to create such
- -- an extra formal (init procs aren't ever frozen).
- -- For now we just use the level of the type,
- -- which may be too shallow, but that works better
- -- than passing Object_Access_Level of the type,
- -- which can be one level too deep in some cases.
- -- ???
-
- -- A further case that requires special handling
- -- is the common idiom E.all'access. If E is a
- -- formal of the enclosing subprogram, the
- -- accessibility of the expression is that of E.
-
- if Is_Entity_Name (Prev_Orig) then
- Pref_Entity := Entity (Prev_Orig);
-
- elsif Nkind (Prev_Orig) = N_Explicit_Dereference
- and then Is_Entity_Name (Prefix (Prev_Orig))
- then
- Pref_Entity := Entity (Prefix ((Prev_Orig)));
-
- else
- Pref_Entity := Empty;
- end if;
+ -- Obtain the ultimate prefix so we can check for
+ -- the case where we are taking 'Access of a
+ -- component of an anonymous access formal - which
+ -- would mean we need to pass said formal's
+ -- corresponding extra accessibility formal.
- if Is_Entity_Name (Prev_Orig)
- and then Is_Type (Entity (Prev_Orig))
- then
- Add_Extra_Actual
- (Expr =>
- Make_Integer_Literal (Loc,
- Intval =>
- Type_Access_Level (Pref_Entity)),
- EF => Get_Accessibility (Formal));
+ Prev_Ult := Ultimate_Prefix (Prev_Orig);
- elsif Nkind (Prev_Orig) = N_Explicit_Dereference
- and then Present (Pref_Entity)
- and then Is_Formal (Pref_Entity)
+ if Is_Entity_Name (Prev_Ult)
+ and then not Is_Type (Entity (Prev_Ult))
and then Present
- (Get_Accessibility (Pref_Entity))
+ (Get_Accessibility
+ (Entity (Prev_Ult)))
then
Add_Extra_Actual
(Expr =>
New_Occurrence_Of
- (Get_Accessibility (Pref_Entity), Loc),
+ (Get_Accessibility
+ (Entity (Prev_Ult)), Loc),
EF => Get_Accessibility (Formal));
+ -- Normal case, call Object_Access_Level. Note:
+ -- should be Dynamic_Accessibility_Level ???
+
else
Add_Extra_Actual
(Expr =>
@@ -3552,10 +3896,228 @@ package body Exp_Ch6 is
-- Prev_Orig denotes an original expression that has
-- not been analyzed.
+ -- However, when the actual is wrapped in a conditional
+ -- expression we must add a local temporary to store the
+ -- level at each branch, and, possibly, expand the call
+ -- into an expression with actions.
+
when others =>
- Add_Extra_Actual
- (Expr => Dynamic_Accessibility_Level (Prev),
- EF => Get_Accessibility (Formal));
+ if Nkind (Prev) = N_Expression_With_Actions
+ and then Nkind (Original_Node (Prev)) in
+ N_If_Expression | N_Case_Expression
+ then
+ declare
+ Decl : Node_Id;
+ pragma Warnings (Off, Decl);
+ -- Suppress warning for the final removal loop
+ Lvl : Entity_Id;
+ Res : Entity_Id;
+ Temp : Node_Id;
+ Typ : Node_Id;
+
+ procedure Insert_Level_Assign (Branch : Node_Id);
+ -- Recursivly add assignment of the level temporary
+ -- on each branch while moving through nested
+ -- conditional expressions.
+
+ -------------------------
+ -- Insert_Level_Assign --
+ -------------------------
+
+ procedure Insert_Level_Assign (Branch : Node_Id) is
+
+ procedure Expand_Branch (Assn : Node_Id);
+ -- Perform expansion or iterate further within
+ -- nested conditionals.
+
+ -------------------
+ -- Expand_Branch --
+ -------------------
+
+ procedure Expand_Branch (Assn : Node_Id) is
+ begin
+ pragma Assert (Nkind (Assn) =
+ N_Assignment_Statement);
+
+ -- There are more nested conditional
+ -- expressions so we must go deeper.
+
+ if Nkind (Expression (Assn)) =
+ N_Expression_With_Actions
+ and then
+ Nkind
+ (Original_Node (Expression (Assn))) in
+ N_Case_Expression | N_If_Expression
+ then
+ Insert_Level_Assign (Expression (Assn));
+
+ -- Add the level assignment
+
+ else
+ Insert_Before_And_Analyze (Assn,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Lvl, Loc),
+ Expression =>
+ Dynamic_Accessibility_Level
+ (Expression (Assn))));
+ end if;
+ end Expand_Branch;
+
+ Cond : Node_Id;
+ Alt : Node_Id;
+
+ -- Start of processing for Insert_Level_Assign
+
+ begin
+ -- Examine further nested condtionals
+
+ pragma Assert (Nkind (Branch) =
+ N_Expression_With_Actions);
+
+ -- Find the relevant statement in the actions
+
+ Cond := First (Actions (Branch));
+ loop
+ exit when Nkind (Cond) in
+ N_Case_Statement | N_If_Statement;
+
+ Next (Cond);
+
+ if No (Cond) then
+ raise Program_Error;
+ end if;
+ end loop;
+
+ -- Iterate through if expression branches
+
+ if Nkind (Cond) = N_If_Statement then
+ Expand_Branch (Last (Then_Statements (Cond)));
+ Expand_Branch (Last (Else_Statements (Cond)));
+
+ -- Iterate through case alternatives
+
+ elsif Nkind (Cond) = N_Case_Statement then
+
+ Alt := First (Alternatives (Cond));
+ while Present (Alt) loop
+ Expand_Branch (Last (Statements (Alt)));
+
+ Next (Alt);
+ end loop;
+ end if;
+ end Insert_Level_Assign;
+
+ -- Start of processing for cond expression case
+
+ begin
+ -- Create declaration of a temporary to store the
+ -- accessibility level of each branch of the
+ -- conditional expression.
+
+ Lvl := Make_Temporary (Loc, 'L');
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Lvl,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Natural, Loc));
+
+ -- Install the declaration and perform necessary
+ -- expansion if we are dealing with a function
+ -- call.
+
+ if Nkind (Call_Node) = N_Procedure_Call_Statement
+ then
+ -- Generate:
+ -- Lvl : Natural;
+ -- Call (
+ -- {do
+ -- If_Exp_Res : Typ;
+ -- if Cond then
+ -- Lvl := 0; -- Access level
+ -- If_Exp_Res := Exp;
+ -- ...
+ -- in If_Exp_Res end;},
+ -- Lvl,
+ -- ...
+ -- )
+
+ Insert_Before_And_Analyze (Call_Node, Decl);
+
+ -- A function call must be transformed into an
+ -- expression with actions.
+
+ else
+ -- Generate:
+ -- do
+ -- Lvl : Natural;
+ -- in Call (do{
+ -- If_Exp_Res : Typ
+ -- if Cond then
+ -- Lvl := 0; -- Access level
+ -- If_Exp_Res := Exp;
+ -- in If_Exp_Res end;},
+ -- Lvl,
+ -- ...
+ -- )
+ -- end;
+
+ Res := Make_Temporary (Loc, 'R');
+ Typ := Etype (Call_Node);
+ Temp := Relocate_Node (Call_Node);
+
+ -- Perform the rewrite with the dummy
+
+ Rewrite (Call_Node,
+
+ Make_Expression_With_Actions (Loc,
+ Expression => New_Occurrence_Of (Res, Loc),
+ Actions => New_List (
+ Decl,
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Res,
+ Object_Definition =>
+ New_Occurrence_Of (Typ, Loc)))));
+
+ -- Analyze the expression with the dummy
+
+ Analyze_And_Resolve (Call_Node, Typ);
+
+ -- Properly set the expression and move our view
+ -- of the call node
+
+ Set_Expression (Call_Node, Relocate_Node (Temp));
+ Call_Node := Expression (Call_Node);
+
+ -- Remove the declaration of the dummy and the
+ -- subsequent actions its analysis has created.
+
+ while Present (Remove_Next (Decl)) loop
+ null;
+ end loop;
+ end if;
+
+ -- Decorate the conditional expression with
+ -- assignments to our level temporary.
+
+ Insert_Level_Assign (Prev);
+
+ -- Make our level temporary the passed actual
+
+ Add_Extra_Actual
+ (Expr => New_Occurrence_Of (Lvl, Loc),
+ EF => Get_Accessibility (Formal));
+ end;
+
+ -- General case uncomplicated by conditional expressions
+
+ else
+ Add_Extra_Actual
+ (Expr => Dynamic_Accessibility_Level (Prev),
+ EF => Get_Accessibility (Formal));
+ end if;
end case;
end if;
end if;
@@ -3603,7 +4165,7 @@ package body Exp_Ch6 is
then
null;
- elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then
+ elsif Nkind (Prev) in N_Allocator | N_Attribute_Reference then
null;
else
@@ -3635,8 +4197,8 @@ package body Exp_Ch6 is
begin
Nod := Actual;
- while Nkind_In (Nod, N_Indexed_Component,
- N_Selected_Component)
+ while Nkind (Nod) in
+ N_Indexed_Component | N_Selected_Component
loop
Set_Analyzed (Nod, False);
Nod := Prefix (Nod);
@@ -3743,7 +4305,7 @@ package body Exp_Ch6 is
-- generating spurious checks on complex expansion such as object
-- initialization through an extension aggregate.
- if Comes_From_Source (N)
+ if Comes_From_Source (Call_Node)
and then Ekind (Formal) /= E_In_Parameter
and then Nkind (Actual) = N_Type_Conversion
then
@@ -3775,7 +4337,7 @@ package body Exp_Ch6 is
-- "accessibility level determined by the point of call" (AI05-0234)
-- passed in to it, then pass it in.
- if Ekind_In (Subp, E_Function, E_Operator, E_Subprogram_Type)
+ if Ekind (Subp) in E_Function | E_Operator | E_Subprogram_Type
and then
Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp)))
then
@@ -3921,6 +4483,8 @@ package body Exp_Ch6 is
if Present (Ass)
and then Is_Class_Wide_Type (Etype (Name (Ass)))
then
+ -- Move the error messages below to sem???
+
if Is_Access_Type (Etype (Call_Node)) then
if Designated_Type (Etype (Call_Node)) /=
Root_Type (Etype (Name (Ass)))
@@ -4068,8 +4632,7 @@ package body Exp_Ch6 is
-- and reanalyzed (see Expand_Protected_Subprogram_Call).
elsif Is_Protected_Type (Scope (Subp))
- and then (Ekind (Subp) = E_Procedure
- or else Ekind (Subp) = E_Function)
+ and then Ekind (Subp) in E_Procedure | E_Function
then
null;
@@ -4115,6 +4678,8 @@ package body Exp_Ch6 is
Set_Entity (Name (Call_Node), Parent_Subp);
+ -- Move this check to sem???
+
if Is_Abstract_Subprogram (Parent_Subp)
and then not In_Instance
then
@@ -4144,9 +4709,8 @@ package body Exp_Ch6 is
procedure Convert (Act : Node_Id; Typ : Entity_Id) is
begin
- Rewrite (Act, OK_Convert_To (Typ, Relocate_Node (Act)));
- Analyze (Act);
- Resolve (Act, Typ);
+ Rewrite (Act, OK_Convert_To (Typ, Act));
+ Analyze_And_Resolve (Act, Typ);
end Convert;
-- Local variables
@@ -4164,8 +4728,8 @@ package body Exp_Ch6 is
Formal_Typ := Etype (Formal);
Parent_Typ := Etype (Parent_Formal);
- -- For an IN parameter of a scalar type, the parent formal
- -- type and derived formal type differ or the parent formal
+ -- For an IN parameter of a scalar type, the derived formal
+ -- type and parent formal type differ, and the parent formal
-- type and actual type do not match statically.
if Is_Scalar_Type (Formal_Typ)
@@ -4176,15 +4740,6 @@ package body Exp_Ch6 is
and then not Raises_Constraint_Error (Actual)
then
Convert (Actual, Parent_Typ);
- Enable_Range_Check (Actual);
-
- -- If the actual has been marked as requiring a range
- -- check, then generate it here.
-
- if Do_Range_Check (Actual) then
- Generate_Range_Check
- (Actual, Etype (Formal), CE_Range_Check_Failed);
- end if;
-- For access types, the parent formal type and actual type
-- differ.
@@ -4206,16 +4761,17 @@ package body Exp_Ch6 is
-- inlined.
Rewrite (Actual,
- Unchecked_Convert_To (Parent_Typ,
- Relocate_Node (Actual)));
- Analyze (Actual);
- Resolve (Actual, Parent_Typ);
+ Unchecked_Convert_To (Parent_Typ, Actual));
+ Analyze_And_Resolve (Actual, Parent_Typ);
end if;
-- If there is a change of representation, then generate a
-- warning, and do the change of representation.
- elsif not Same_Representation (Formal_Typ, Parent_Typ) then
+ elsif not Has_Compatible_Representation
+ (Target_Type => Formal_Typ,
+ Operand_Type => Parent_Typ)
+ then
Error_Msg_N
("??change of representation required", Actual);
Convert (Actual, Parent_Typ);
@@ -4252,7 +4808,7 @@ package body Exp_Ch6 is
if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
- -- Handle case of access to protected subprogram type
+ -- Handle case of access to protected subprogram type
if Is_Access_Protected_Subprogram_Type
(Base_Type (Etype (Prefix (Name (Call_Node)))))
@@ -4354,7 +4910,7 @@ package body Exp_Ch6 is
return;
end if;
- if Ekind_In (Subp, E_Function, E_Procedure) then
+ if Ekind (Subp) in E_Function | E_Procedure then
-- We perform a simple optimization on calls for To_Address by
-- replacing them with an unchecked conversion. Not only is this
@@ -4400,8 +4956,9 @@ package body Exp_Ch6 is
-- back-end inlining is enabled).
elsif Is_Inlinable_Expression_Function (Subp) then
- Rewrite (N, New_Copy (Expression_Of_Expression_Function (Subp)));
- Analyze (N);
+ Rewrite
+ (Call_Node, New_Copy (Expression_Of_Expression_Function (Subp)));
+ Analyze (Call_Node);
return;
-- Handle front-end inlining
@@ -4463,7 +5020,7 @@ package body Exp_Ch6 is
-- visible a private entity in the body of the main unit,
-- that gigi will see before its sees its proper definition.
- elsif not (In_Extended_Main_Code_Unit (Call_Node))
+ elsif not In_Extended_Main_Code_Unit (Call_Node)
and then In_Package_Body
then
Must_Inline := not In_Extended_Main_Source_Unit (Subp);
@@ -4472,7 +5029,7 @@ package body Exp_Ch6 is
elsif Modify_Tree_For_C
and then In_Same_Extended_Unit (Sloc (Bod), Loc)
- and then Chars (Name (N)) = Name_uPostconditions
+ and then Chars (Name (Call_Node)) = Name_uPostconditions
then
Must_Inline := True;
end if;
@@ -4488,7 +5045,7 @@ package body Exp_Ch6 is
if Front_End_Inlining
and then Nkind (Spec) = N_Subprogram_Declaration
- and then (In_Extended_Main_Code_Unit (Call_Node))
+ and then In_Extended_Main_Code_Unit (Call_Node)
and then No (Body_To_Inline (Spec))
and then not Has_Completion (Subp)
and then In_Same_Extended_Unit (Sloc (Spec), Loc)
@@ -4570,18 +5127,19 @@ package body Exp_Ch6 is
-- intermediate result after its use.
elsif Is_Build_In_Place_Function_Call (Call_Node)
- and then Nkind_In (Parent (Unqual_Conv (Call_Node)),
- N_Attribute_Reference,
- N_Function_Call,
- N_Indexed_Component,
- N_Object_Renaming_Declaration,
- N_Procedure_Call_Statement,
- N_Selected_Component,
- N_Slice)
+ and then Nkind (Parent (Unqual_Conv (Call_Node))) in
+ N_Attribute_Reference
+ | N_Function_Call
+ | N_Indexed_Component
+ | N_Object_Renaming_Declaration
+ | N_Procedure_Call_Statement
+ | N_Selected_Component
+ | N_Slice
and then
(Ekind (Current_Scope) /= E_Loop
- or else Nkind (Parent (N)) /= N_Function_Call
- or else not Is_Build_In_Place_Function_Call (Parent (N)))
+ or else Nkind (Parent (Call_Node)) /= N_Function_Call
+ or else not Is_Build_In_Place_Function_Call
+ (Parent (Call_Node)))
then
Establish_Transient_Scope (Call_Node, Manage_Sec_Stack => True);
end if;
@@ -4995,6 +5553,17 @@ package body Exp_Ch6 is
Is_Build_In_Place_Function_Call (Exp));
null;
end if;
+
+ -- Ada 2005 (AI95-344): If the result type is class-wide, then insert
+ -- a check that the level of the return expression's underlying type
+ -- is not deeper than the level of the master enclosing the function.
+
+ -- AI12-043: The check is made immediately after the return object
+ -- is created.
+
+ if Present (Exp) and then Is_Class_Wide_Type (Ret_Typ) then
+ Apply_CW_Accessibility_Check (Exp, Func_Id);
+ end if;
else
Exp := Empty;
end if;
@@ -5747,7 +6316,14 @@ package body Exp_Ch6 is
Set_Comes_From_Extended_Return_Statement (Return_Stmt);
Rewrite (N, Result);
- Analyze (N, Suppress => All_Checks);
+
+ -- AI12-043: The checks of 6.5(8.1/3) and 6.5(21/3) are made immediately
+ -- before an object is returned. A predicate that applies to the return
+ -- subtype is checked immediately before an object is returned.
+
+ -- Suppress access checks to avoid generating extra checks for b-i-p.
+
+ Analyze (N, Suppress => Access_Check);
end Expand_N_Extended_Return_Statement;
----------------------------
@@ -5921,6 +6497,19 @@ package body Exp_Ch6 is
Name =>
New_Occurrence_Of (Postconditions_Proc (Spec_Id), Loc)));
end if;
+
+ -- Ada 2020 (AI12-0279): append the call to 'Yield unless this is
+ -- a generic subprogram (since in such case it will be added to
+ -- the instantiations).
+
+ if Has_Yield_Aspect (Spec_Id)
+ and then Ekind (Spec_Id) /= E_Generic_Procedure
+ and then RTE_Available (RE_Yield)
+ then
+ Insert_Action (Stmt,
+ Make_Procedure_Call_Statement (Loc,
+ New_Occurrence_Of (RTE (RE_Yield), Loc)));
+ end if;
end if;
end Add_Return;
@@ -6114,7 +6703,7 @@ package body Exp_Ch6 is
-- For a procedure, we add a return for all possible syntactic ends of
-- the subprogram.
- if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure) then
+ if Ekind (Spec_Id) in E_Procedure | E_Generic_Procedure then
Add_Return (Spec_Id, Statements (HSS));
if Present (Exception_Handlers (HSS)) then
@@ -6244,33 +6833,7 @@ package body Exp_Ch6 is
Prot_Decl : Node_Id;
Prot_Id : Entity_Id;
- -- Start of processing for Expand_N_Subprogram_Declaration
-
begin
- -- In SPARK, subprogram declarations are only allowed in package
- -- specifications.
-
- if Nkind (Parent (N)) /= N_Package_Specification then
- if Nkind (Parent (N)) = N_Compilation_Unit then
- Check_SPARK_05_Restriction
- ("subprogram declaration is not a library item", N);
-
- elsif Present (Next (N))
- and then Nkind (Next (N)) = N_Pragma
- and then Get_Pragma_Id (Next (N)) = Pragma_Import
- then
- -- In SPARK, subprogram declarations are also permitted in
- -- declarative parts when immediately followed by a corresponding
- -- pragma Import. We only check here that there is some pragma
- -- Import.
-
- null;
- else
- Check_SPARK_05_Restriction
- ("subprogram declaration is not allowed here", N);
- end if;
- end if;
-
-- Deal with case of protected subprogram. Do not generate protected
-- operation if operation is flagged as eliminated.
@@ -6310,19 +6873,6 @@ package body Exp_Ch6 is
Analyze (Prot_Decl);
Freeze_Before (N, Prot_Id);
Set_Protected_Body_Subprogram (Subp, Prot_Id);
-
- -- Create protected operation as well. Even though the operation
- -- is only accessible within the body, it is possible to make it
- -- available outside of the protected object by using 'Access to
- -- provide a callback, so build protected version in all cases.
-
- Prot_Decl :=
- Make_Subprogram_Declaration (Loc,
- Specification =>
- Build_Protected_Sub_Specification (N, Scop, Protected_Mode));
- Insert_Before (Prot_Bod, Prot_Decl);
- Analyze (Prot_Decl);
-
Pop_Scope;
end if;
@@ -6385,7 +6935,7 @@ package body Exp_Ch6 is
-- Call the _Postconditions procedure if the related subprogram has
-- contract assertions that need to be verified on exit.
- if Ekind_In (Scope_Id, E_Entry, E_Entry_Family, E_Procedure)
+ if Ekind (Scope_Id) in E_Entry | E_Entry_Family | E_Procedure
and then Present (Postconditions_Proc (Scope_Id))
then
Insert_Action (N,
@@ -6393,6 +6943,16 @@ package body Exp_Ch6 is
Name => New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc)));
end if;
+ -- Ada 2020 (AI12-0279)
+
+ if Has_Yield_Aspect (Scope_Id)
+ and then RTE_Available (RE_Yield)
+ then
+ Insert_Action (N,
+ Make_Procedure_Call_Statement (Loc,
+ New_Occurrence_Of (RTE (RE_Yield), Loc)));
+ end if;
+
-- If it is a return from a procedure do no extra steps
if Kind = E_Procedure or else Kind = E_Generic_Procedure then
@@ -6758,7 +7318,7 @@ package body Exp_Ch6 is
Exp : Node_Id := Expression (N);
pragma Assert (Present (Exp));
- Exptyp : constant Entity_Id := Etype (Exp);
+ Exp_Typ : constant Entity_Id := Etype (Exp);
-- The type of the expression (not necessarily the same as R_Type)
Subtype_Ind : Node_Id;
@@ -6769,12 +7329,35 @@ package body Exp_Ch6 is
-- of the return object to the specific type on assignments to the
-- individual components.
+ procedure Check_Against_Result_Level (Level : Node_Id);
+ -- Check the given accessibility level against the level
+ -- determined by the point of call. (AI05-0234).
+
+ --------------------------------
+ -- Check_Against_Result_Level --
+ --------------------------------
+
+ procedure Check_Against_Result_Level (Level : Node_Id) is
+ begin
+ Insert_Action (N,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => Level,
+ Right_Opnd =>
+ New_Occurrence_Of
+ (Extra_Accessibility_Of_Result (Scope_Id), Loc)),
+ Reason => PE_Accessibility_Check_Failed));
+ end Check_Against_Result_Level;
+
+ -- Start of processing for Expand_Simple_Function_Return
+
begin
if Is_Class_Wide_Type (R_Type)
- and then not Is_Class_Wide_Type (Exptyp)
+ and then not Is_Class_Wide_Type (Exp_Typ)
and then Nkind (Exp) /= N_Type_Conversion
then
- Subtype_Ind := New_Occurrence_Of (Exptyp, Loc);
+ Subtype_Ind := New_Occurrence_Of (Exp_Typ, Loc);
else
Subtype_Ind := New_Occurrence_Of (R_Type, Loc);
@@ -6784,7 +7367,7 @@ package body Exp_Ch6 is
-- altogether to prevent tag overwriting.
if Is_Class_Wide_Type (R_Type)
- and then not Is_Class_Wide_Type (Exptyp)
+ and then not Is_Class_Wide_Type (Exp_Typ)
and then Nkind (Exp) = N_Type_Conversion
then
Exp := Expression (Exp);
@@ -6845,7 +7428,7 @@ package body Exp_Ch6 is
-- handled by means of simple return statements. This leaves their
-- expansion simple and clean.
- and then not Is_Thunk (Current_Scope)
+ and then not Is_Thunk (Scope_Id)
then
declare
Return_Object_Entity : constant Entity_Id :=
@@ -6880,18 +7463,14 @@ package body Exp_Ch6 is
-- barrier functions for protected types, which turn the condition into
-- a return statement.
- if Is_Boolean_Type (Exptyp)
- and then Nonzero_Is_True (Exptyp)
- then
+ if Is_Boolean_Type (Exp_Typ) and then Nonzero_Is_True (Exp_Typ) then
Adjust_Condition (Exp);
- Adjust_Result_Type (Exp, Exptyp);
+ Adjust_Result_Type (Exp, Exp_Typ);
end if;
-- Do validity check if enabled for returns
- if Validity_Checks_On
- and then Validity_Check_Returns
- then
+ if Validity_Checks_On and then Validity_Check_Returns then
Ensure_Valid (Exp);
end if;
@@ -6901,7 +7480,7 @@ package body Exp_Ch6 is
-- only done for scalars.
-- ???
- if Is_Scalar_Type (Exptyp) then
+ if Is_Scalar_Type (Exp_Typ) then
Rewrite (Exp, Convert_To (R_Type, Exp));
-- The expression is resolved to ensure that the conversion gets
@@ -6917,7 +7496,7 @@ package body Exp_Ch6 is
-- it requires a cleanup scope for the secondary stack case).
if Is_Build_In_Place_Function (Scope_Id)
- or else Is_Limited_Interface (Exptyp)
+ or else Is_Limited_Interface (Exp_Typ)
then
null;
@@ -6925,13 +7504,13 @@ package body Exp_Ch6 is
-- the object is returned by reference and the maximum functionality
-- required is just to displace the pointer.
- elsif Is_Thunk (Current_Scope) and then Is_Interface (Exptyp) then
+ elsif Is_Thunk (Scope_Id) and then Is_Interface (Exp_Typ) then
null;
-- If the call is within a thunk and the type is a limited view, the
-- backend will eventually see the non-limited view of the type.
- elsif Is_Thunk (Current_Scope) and then Is_Incomplete_Type (Exptyp) then
+ elsif Is_Thunk (Scope_Id) and then Is_Incomplete_Type (Exp_Typ) then
return;
-- A return statement from an ignored Ghost function does not use the
@@ -6950,7 +7529,7 @@ package body Exp_Ch6 is
-- cause a temporary with maximum size to be created.
declare
- Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp));
+ Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exp_Typ));
Decl : Node_Id;
Ent : Entity_Id;
begin
@@ -6987,10 +7566,10 @@ package body Exp_Ch6 is
-- for array types if the constrained status of the target type is
-- different from that of the expression.
- if Requires_Transient_Scope (Exptyp)
+ if Requires_Transient_Scope (Exp_Typ)
and then
- (not Is_Array_Type (Exptyp)
- or else Is_Constrained (Exptyp) = Is_Constrained (R_Type)
+ (not Is_Array_Type (Exp_Typ)
+ or else Is_Constrained (Exp_Typ) = Is_Constrained (R_Type)
or else CW_Or_Has_Controlled_Part (Utyp))
and then Nkind (Exp) = N_Function_Call
then
@@ -7106,8 +7685,8 @@ package body Exp_Ch6 is
if Present (Utyp)
and then Is_Tagged_Type (Utyp)
and then not Is_Class_Wide_Type (Utyp)
- and then (Nkind_In (Exp, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ and then (Nkind (Exp) in
+ N_Type_Conversion | N_Unchecked_Type_Conversion
or else (Is_Entity_Name (Exp)
and then Is_Formal (Entity (Exp))))
then
@@ -7162,125 +7741,27 @@ package body Exp_Ch6 is
end;
end if;
- -- Ada 2005 (AI-344): If the result type is class-wide, then insert
+ -- Ada 2005 (AI95-344): If the result type is class-wide, then insert
-- a check that the level of the return expression's underlying type
-- is not deeper than the level of the master enclosing the function.
- -- Always generate the check when the type of the return expression
- -- is class-wide, when it's a type conversion, or when it's a formal
- -- parameter. Otherwise, suppress the check in the case where the
- -- return expression has a specific type whose level is known not to
- -- be statically deeper than the function's result type.
+
+ -- AI12-043: The check is made immediately after the return object is
+ -- created. This means that we do not apply it to the simple return
+ -- generated by the expansion of an extended return statement.
-- No runtime check needed in interface thunks since it is performed
-- by the target primitive associated with the thunk.
- -- Note: accessibility check is skipped in the VM case, since there
- -- does not seem to be any practical way to implement this check.
-
- elsif Ada_Version >= Ada_2005
- and then Tagged_Type_Expansion
- and then Is_Class_Wide_Type (R_Type)
- and then not Is_Thunk (Current_Scope)
- and then not Scope_Suppress.Suppress (Accessibility_Check)
- and then
- (Is_Class_Wide_Type (Etype (Exp))
- or else Nkind_In (Exp, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
- or else (Is_Entity_Name (Exp)
- and then Is_Formal (Entity (Exp)))
- or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) >
- Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))
+ elsif Is_Class_Wide_Type (R_Type)
+ and then not Comes_From_Extended_Return_Statement (N)
+ and then not Is_Thunk (Scope_Id)
then
- declare
- Tag_Node : Node_Id;
-
- begin
- -- Ada 2005 (AI-251): In class-wide interface objects we displace
- -- "this" to reference the base of the object. This is required to
- -- get access to the TSD of the object.
-
- if Is_Class_Wide_Type (Etype (Exp))
- and then Is_Interface (Etype (Exp))
- then
- -- If the expression is an explicit dereference then we can
- -- directly displace the pointer to reference the base of
- -- the object.
+ Apply_CW_Accessibility_Check (Exp, Scope_Id);
- if Nkind (Exp) = N_Explicit_Dereference then
- Tag_Node :=
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Base_Address), Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Address),
- Duplicate_Subexpr (Prefix (Exp)))))));
-
- -- Similar case to the previous one but the expression is a
- -- renaming of an explicit dereference.
-
- elsif Nkind (Exp) = N_Identifier
- and then Present (Renamed_Object (Entity (Exp)))
- and then Nkind (Renamed_Object (Entity (Exp)))
- = N_Explicit_Dereference
- then
- Tag_Node :=
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Base_Address), Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Address),
- Duplicate_Subexpr
- (Prefix
- (Renamed_Object (Entity (Exp)))))))));
-
- -- Common case: obtain the address of the actual object and
- -- displace the pointer to reference the base of the object.
-
- else
- Tag_Node :=
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Base_Address), Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Exp),
- Attribute_Name => Name_Address)))));
- end if;
- else
- Tag_Node :=
- Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Exp),
- Attribute_Name => Name_Tag);
- end if;
-
- -- CodePeer does not do anything useful with
- -- Ada.Tags.Type_Specific_Data components.
-
- if not CodePeer_Mode then
- Insert_Action (Exp,
- Make_Raise_Program_Error (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
- Reason => PE_Accessibility_Check_Failed));
- end if;
- end;
-
- -- AI05-0073: If function has a controlling access result, check that
- -- the tag of the return value, if it is not null, matches designated
- -- type of return type.
+ -- Ada 2012 (AI05-0073): If the result subtype of the function is
+ -- defined by an access_definition designating a specific tagged
+ -- type T, a check is made that the result value is null or the tag
+ -- of the object designated by the result value identifies T.
-- The return expression is referenced twice in the code below, so it
-- must be made free of side effects. Given that different compilers
@@ -7288,8 +7769,16 @@ package body Exp_Ch6 is
-- perform a copy.
elsif Ekind (R_Type) = E_Anonymous_Access_Type
- and then Has_Controlling_Result (Scope_Id)
+ and then Is_Tagged_Type (Designated_Type (R_Type))
+ and then not Is_Class_Wide_Type (Designated_Type (R_Type))
+ and then Nkind (Original_Node (Exp)) /= N_Null
+ and then not Tag_Checks_Suppressed (Designated_Type (R_Type))
then
+ -- Generate:
+ -- [Constraint_Error
+ -- when Exp /= null
+ -- and then Exp.all not in Designated_Type]
+
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
@@ -7299,53 +7788,37 @@ package body Exp_Ch6 is
Left_Opnd => Duplicate_Subexpr (Exp),
Right_Opnd => Make_Null (Loc)),
- Right_Opnd => Make_Op_Ne (Loc,
- Left_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Exp),
- Selector_Name => Make_Identifier (Loc, Name_uTag)),
-
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Designated_Type (R_Type), Loc),
- Attribute_Name => Name_Tag))),
+ Right_Opnd =>
+ Make_Not_In (Loc,
+ Left_Opnd =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => Duplicate_Subexpr (Exp)),
+ Right_Opnd =>
+ New_Occurrence_Of (Designated_Type (R_Type), Loc))),
Reason => CE_Tag_Check_Failed),
Suppress => All_Checks);
end if;
- -- AI05-0234: RM 6.5(21/3). Check access discriminants to
- -- ensure that the function result does not outlive an
- -- object designated by one of it discriminants.
+ -- Determine if the special rules within RM 3.10.2 for explicitly
+ -- aliased formals apply to Exp - in which case we require a dynamic
+ -- check to be generated.
+
+ if Is_Special_Aliased_Formal_Access (Exp, Scope_Id) then
+ Check_Against_Result_Level
+ (Make_Integer_Literal (Loc,
+ Object_Access_Level (Entity (Ultimate_Prefix (Prefix (Exp))))));
+ end if;
+
+ -- AI05-0234: Check unconstrained access discriminants to ensure
+ -- that the result does not outlive an object designated by one
+ -- of its discriminants (RM 6.5(21/3)).
if Present (Extra_Accessibility_Of_Result (Scope_Id))
and then Has_Unconstrained_Access_Discriminants (R_Type)
then
declare
Discrim_Source : Node_Id;
-
- procedure Check_Against_Result_Level (Level : Node_Id);
- -- Check the given accessibility level against the level
- -- determined by the point of call. (AI05-0234).
-
- --------------------------------
- -- Check_Against_Result_Level --
- --------------------------------
-
- procedure Check_Against_Result_Level (Level : Node_Id) is
- begin
- Insert_Action (N,
- Make_Raise_Program_Error (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd => Level,
- Right_Opnd =>
- New_Occurrence_Of
- (Extra_Accessibility_Of_Result (Scope_Id), Loc)),
- Reason => PE_Accessibility_Check_Failed));
- end Check_Against_Result_Level;
-
begin
Discrim_Source := Exp;
while Nkind (Discrim_Source) = N_Qualified_Expression loop
@@ -7364,8 +7837,8 @@ package body Exp_Ch6 is
end if;
elsif Nkind (Discrim_Source) = N_Identifier
- and then Nkind_In (Original_Node (Discrim_Source),
- N_Aggregate, N_Extension_Aggregate)
+ and then Nkind (Original_Node (Discrim_Source)) in
+ N_Aggregate | N_Extension_Aggregate
then
Discrim_Source := Original_Node (Discrim_Source);
@@ -7585,11 +8058,21 @@ package body Exp_Ch6 is
and then Comes_From_Extended_Return_Statement (N)
and then Nkind (Expression (N)) = N_Identifier
and then Is_Interface (Utyp)
- and then Utyp /= Underlying_Type (Exptyp)
+ and then Utyp /= Underlying_Type (Exp_Typ)
then
Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp);
end if;
+
+ -- Ada 2020 (AI12-0279)
+
+ if Has_Yield_Aspect (Scope_Id)
+ and then RTE_Available (RE_Yield)
+ then
+ Insert_Action (N,
+ Make_Procedure_Call_Statement (Loc,
+ New_Occurrence_Of (RTE (RE_Yield), Loc)));
+ end if;
end Expand_Simple_Function_Return;
-----------------------
@@ -7728,8 +8211,7 @@ package body Exp_Ch6 is
-- Build_Inherit_Prims takes care of initializing these slots.
elsif Is_Imported (Subp)
- and then (Convention (Subp) = Convention_CPP
- or else Convention (Subp) = Convention_C)
+ and then Convention (Subp) in Convention_C_Family
then
null;
@@ -7785,31 +8267,40 @@ package body Exp_Ch6 is
end if;
end Freeze_Subprogram;
- --------------------------------------------
- -- Has_Unconstrained_Access_Discriminants --
- --------------------------------------------
+ --------------------------
+ -- Has_BIP_Extra_Formal --
+ --------------------------
- function Has_Unconstrained_Access_Discriminants
- (Subtyp : Entity_Id) return Boolean
+ function Has_BIP_Extra_Formal
+ (E : Entity_Id;
+ Kind : BIP_Formal_Kind) return Boolean
is
- Discr : Entity_Id;
+ Extra_Formal : Entity_Id := Extra_Formals (E);
begin
- if Has_Discriminants (Subtyp)
- and then not Is_Constrained (Subtyp)
- then
- Discr := First_Discriminant (Subtyp);
- while Present (Discr) loop
- if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
- return True;
- end if;
+ -- We can only rely on the availability of the extra formals in frozen
+ -- entities or in subprogram types of dispatching calls (since their
+ -- extra formals are added when the target subprogram is frozen; see
+ -- Expand_Dispatching_Call).
- Next_Discriminant (Discr);
- end loop;
- end if;
+ pragma Assert (Is_Frozen (E)
+ or else (Ekind (E) = E_Subprogram_Type
+ and then Is_Dispatch_Table_Entity (E))
+ or else (Is_Dispatching_Operation (E)
+ and then Is_Frozen (Find_Dispatching_Type (E))));
+
+ while Present (Extra_Formal) loop
+ if Is_Build_In_Place_Entity (Extra_Formal)
+ and then BIP_Suffix_Kind (Extra_Formal) = Kind
+ then
+ return True;
+ end if;
+
+ Next_Formal_With_Extras (Extra_Formal);
+ end loop;
return False;
- end Has_Unconstrained_Access_Discriminants;
+ end Has_BIP_Extra_Formal;
------------------------------
-- Insert_Post_Call_Actions --
@@ -7823,12 +8314,15 @@ package body Exp_Ch6 is
return;
end if;
- -- Cases where the call is not a member of a statement list. This
- -- includes the case where the call is an actual in another function
- -- call or indexing, i.e. an expression context as well.
+ -- Cases where the call is not a member of a statement list. This also
+ -- includes the cases where the call is an actual in another function
+ -- call, or is an index, or is an operand of an if-expression, i.e. is
+ -- in an expression context.
if not Is_List_Member (N)
- or else Nkind_In (Context, N_Function_Call, N_Indexed_Component)
+ or else Nkind (Context) in N_Function_Call
+ | N_If_Expression
+ | N_Indexed_Component
then
-- In Ada 2012 the call may be a function call in an expression
-- (since OUT and IN OUT parameters are now allowed for such calls).
@@ -7836,7 +8330,9 @@ package body Exp_Ch6 is
-- but the constraint checks generated when subtypes of formal and
-- actual don't match must be inserted in the form of assignments.
- if Nkind (Original_Node (N)) = N_Function_Call then
+ if Nkind (N) = N_Function_Call
+ or else Nkind (Original_Node (N)) = N_Function_Call
+ then
pragma Assert (Ada_Version >= Ada_2012);
-- Functions with '[in] out' parameters are only allowed in Ada
-- 2012.
@@ -7904,8 +8400,8 @@ package body Exp_Ch6 is
-- corresponding statement list.
else
- pragma Assert (Nkind_In (Context, N_Entry_Call_Alternative,
- N_Triggering_Alternative));
+ pragma Assert (Nkind (Context) in N_Entry_Call_Alternative
+ | N_Triggering_Alternative);
if Is_Non_Empty_List (Statements (Context)) then
Insert_List_Before_And_Analyze
@@ -8015,6 +8511,34 @@ package body Exp_Ch6 is
end if;
end Is_Build_In_Place_Result_Type;
+ ------------------------------
+ -- Is_Build_In_Place_Entity --
+ ------------------------------
+
+ function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean is
+ Nam : constant String := Get_Name_String (Chars (E));
+
+ function Has_Suffix (Suffix : String) return Boolean;
+ -- Return True if Nam has suffix Suffix
+
+ function Has_Suffix (Suffix : String) return Boolean is
+ Len : constant Natural := Suffix'Length;
+ begin
+ return Nam'Length > Len
+ and then Nam (Nam'Last - Len + 1 .. Nam'Last) = Suffix;
+ end Has_Suffix;
+
+ -- Start of processing for Is_Build_In_Place_Entity
+
+ begin
+ return Has_Suffix (BIP_Alloc_Suffix)
+ or else Has_Suffix (BIP_Storage_Pool_Suffix)
+ or else Has_Suffix (BIP_Finalization_Master_Suffix)
+ or else Has_Suffix (BIP_Task_Master_Suffix)
+ or else Has_Suffix (BIP_Activation_Chain_Suffix)
+ or else Has_Suffix (BIP_Object_Access_Suffix);
+ end Is_Build_In_Place_Entity;
+
--------------------------------
-- Is_Build_In_Place_Function --
--------------------------------
@@ -8033,7 +8557,7 @@ package body Exp_Ch6 is
-- type whose result subtype is inherently limited. Later this test
-- may be revised to allow composite nonlimited types.
- if Ekind_In (E, E_Function, E_Generic_Function)
+ if Ekind (E) in E_Function | E_Generic_Function
or else (Ekind (E) = E_Subprogram_Type
and then Etype (E) /= Standard_Void_Type)
then
@@ -8187,9 +8711,9 @@ package body Exp_Ch6 is
-- Step past qualification or unchecked conversion (the latter can occur
-- in cases of calls to 'Input).
- if Nkind_In (Func_Call, N_Qualified_Expression,
- N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ if Nkind (Func_Call) in N_Qualified_Expression
+ | N_Type_Conversion
+ | N_Unchecked_Type_Conversion
then
Func_Call := Expression (Func_Call);
end if;
@@ -8209,6 +8733,8 @@ package body Exp_Ch6 is
raise Program_Error;
end if;
+ Warn_BIP (Func_Call);
+
Result_Subt := Available_View (Etype (Function_Id));
-- Create a temp for the function result. In the caller-allocates case,
@@ -8308,8 +8834,8 @@ package body Exp_Ch6 is
Temp_Init := Relocate_Node (Allocator);
- if Nkind_In (Function_Call, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ if Nkind (Function_Call) in
+ N_Type_Conversion | N_Unchecked_Type_Conversion
then
Temp_Init := Unchecked_Convert_To (Acc_Type, Temp_Init);
end if;
@@ -8354,8 +8880,8 @@ package body Exp_Ch6 is
-- that the full types will be compatible, but the types not visibly
-- compatible.
- elsif Nkind_In (Function_Call, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ elsif Nkind (Function_Call)
+ in N_Type_Conversion | N_Unchecked_Type_Conversion
then
Ref_Func_Call := Unchecked_Convert_To (Acc_Type, Ref_Func_Call);
end if;
@@ -8380,7 +8906,7 @@ package body Exp_Ch6 is
-- rather than some outer chain.
begin
- if Has_Task (Result_Subt) then
+ if Has_Task (Result_Subt) or else Might_Have_Tasks (Result_Subt) then
Actions := New_List;
Build_Task_Allocate_Block_With_Init_Stmts
(Actions, Allocator, Init_Stmts => New_List (Assign));
@@ -8423,6 +8949,7 @@ package body Exp_Ch6 is
Analyze_And_Resolve (Allocator, Acc_Type);
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
+ pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
end Make_Build_In_Place_Call_In_Allocator;
---------------------------------------------------
@@ -8464,6 +8991,8 @@ package body Exp_Ch6 is
raise Program_Error;
end if;
+ Warn_BIP (Func_Call);
+
Result_Subt := Etype (Function_Id);
-- If the build-in-place function returns a controlled object, then the
@@ -8545,6 +9074,7 @@ package body Exp_Ch6 is
(Func_Call, Function_Id, New_Occurrence_Of (Return_Obj_Id, Loc));
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
+ pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
-- When the result subtype is unconstrained, the function must allocate
-- the return object in the secondary stack, so appropriate implicit
@@ -8571,6 +9101,7 @@ package body Exp_Ch6 is
(Func_Call, Function_Id, Empty);
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
+ pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
end if;
end Make_Build_In_Place_Call_In_Anonymous_Context;
@@ -8609,6 +9140,8 @@ package body Exp_Ch6 is
raise Program_Error;
end if;
+ Warn_BIP (Func_Call);
+
Result_Subt := Etype (Func_Id);
-- When the result subtype is unconstrained, an additional actual must
@@ -8677,6 +9210,7 @@ package body Exp_Ch6 is
Rewrite (Assign, Make_Null_Statement (Loc));
pragma Assert (Check_Number_Of_Actuals (Func_Call, Func_Id));
+ pragma Assert (Check_BIP_Actuals (Func_Call, Func_Id));
end Make_Build_In_Place_Call_In_Assignment;
----------------------------------------------------
@@ -8752,6 +9286,8 @@ package body Exp_Ch6 is
Set_Is_Expanded_Build_In_Place_Call (Func_Call);
+ Warn_BIP (Func_Call);
+
-- Create an access type designating the function's result subtype.
-- We use the type of the original call because it may be a call to an
-- inherited operation, which the expansion has replaced with the parent
@@ -8809,7 +9345,7 @@ package body Exp_Ch6 is
begin
while Present (N)
- and then Nkind_In (N, N_Attribute_Reference, N_Pragma)
+ and then Nkind (N) in N_Attribute_Reference | N_Pragma
loop
Analyze (N);
D := N;
@@ -9031,8 +9567,8 @@ package body Exp_Ch6 is
Set_Etype (Def_Id, Ptr_Typ);
Set_Is_Known_Non_Null (Def_Id);
- if Nkind_In (Function_Call, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ if Nkind (Function_Call) in N_Type_Conversion
+ | N_Unchecked_Type_Conversion
then
Res_Decl :=
Make_Object_Declaration (Loc,
@@ -9120,6 +9656,7 @@ package body Exp_Ch6 is
end if;
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
+ pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
end Make_Build_In_Place_Call_In_Object_Declaration;
-------------------------------------------------
@@ -9157,6 +9694,7 @@ package body Exp_Ch6 is
Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call);
Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call));
Set_Etype (Anon_Type, Anon_Type);
+ Build_Class_Wide_Master (Anon_Type);
Tmp_Decl :=
Make_Object_Declaration (Loc,
@@ -9170,6 +9708,12 @@ package body Exp_Ch6 is
New_Occurrence_Of (Etype (BIP_Func_Call), Loc),
Expression => New_Copy_Tree (BIP_Func_Call))));
+ -- Manually set the associated node for the anonymous access type to
+ -- be its local declaration, to avoid confusing and complicating
+ -- the accessibility machinery.
+
+ Set_Associated_Node_For_Itype (Anon_Type, Tmp_Decl);
+
Expander_Mode_Save_And_Set (False);
Insert_Action (Allocator, Tmp_Decl);
Expander_Mode_Restore;
@@ -9178,7 +9722,12 @@ package body Exp_Ch6 is
(Allocator => Expression (Tmp_Decl),
Function_Call => Expression (Expression (Tmp_Decl)));
- Rewrite (Allocator, New_Occurrence_Of (Tmp_Id, Loc));
+ -- Add a conversion to displace the pointer to the allocated object
+ -- to reference the corresponding dispatch table.
+
+ Rewrite (Allocator,
+ Convert_To (Etype (Allocator),
+ New_Occurrence_Of (Tmp_Id, Loc)));
end Make_Build_In_Place_Iface_Call_In_Allocator;
---------------------------------------------------------
@@ -9391,15 +9940,76 @@ package body Exp_Ch6 is
Analyze_And_Resolve (Allocator, Acc_Type);
end Make_CPP_Constructor_Call_In_Allocator;
+ ----------------------
+ -- Might_Have_Tasks --
+ ----------------------
+
+ function Might_Have_Tasks (Typ : Entity_Id) return Boolean is
+ begin
+ return not Global_No_Tasking
+ and then not No_Run_Time_Mode
+ and then Is_Class_Wide_Type (Typ)
+ and then Is_Limited_Record (Typ);
+ end Might_Have_Tasks;
+
----------------------------
-- Needs_BIP_Task_Actuals --
----------------------------
function Needs_BIP_Task_Actuals (Func_Id : Entity_Id) return Boolean is
pragma Assert (Is_Build_In_Place_Function (Func_Id));
- Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
+ Subp_Id : Entity_Id;
+ Func_Typ : Entity_Id;
+
begin
- return Has_Task (Func_Typ);
+ if Global_No_Tasking or else No_Run_Time_Mode then
+ return False;
+ end if;
+
+ -- For thunks we must rely on their target entity; otherwise, given that
+ -- the profile of thunks for functions returning a limited interface
+ -- type returns a class-wide type, we would erroneously add these extra
+ -- formals.
+
+ if Is_Thunk (Func_Id) then
+ Subp_Id := Thunk_Entity (Func_Id);
+
+ -- Common case
+
+ else
+ Subp_Id := Func_Id;
+ end if;
+
+ Func_Typ := Underlying_Type (Etype (Subp_Id));
+
+ -- At first sight, for all the following cases, we could add assertions
+ -- to ensure that if Func_Id is frozen then the computed result matches
+ -- with the availability of the task master extra formal; unfortunately
+ -- this is not feasible because we may be precisely freezing this entity
+ -- (that is, Is_Frozen has been set by Freeze_Entity but it has not
+ -- completed its work).
+
+ if Has_Task (Func_Typ) then
+ return True;
+
+ elsif Ekind (Func_Id) = E_Function then
+ return Might_Have_Tasks (Func_Typ);
+
+ -- Handle subprogram type internally generated for dispatching call. We
+ -- cannot rely on the return type of the subprogram type of dispatching
+ -- calls since it is always a class-wide type (cf. Expand_Dispatching_
+ -- Call).
+
+ elsif Ekind (Func_Id) = E_Subprogram_Type then
+ if Is_Dispatch_Table_Entity (Func_Id) then
+ return Has_BIP_Extra_Formal (Func_Id, BIP_Task_Master);
+ else
+ return Might_Have_Tasks (Func_Typ);
+ end if;
+
+ else
+ raise Program_Error;
+ end if;
end Needs_BIP_Task_Actuals;
-----------------------------------
@@ -9439,144 +10049,6 @@ package body Exp_Ch6 is
return Requires_Transient_Scope (Func_Typ);
end Needs_BIP_Alloc_Form;
- --------------------------------------
- -- Needs_Result_Accessibility_Level --
- --------------------------------------
-
- function Needs_Result_Accessibility_Level
- (Func_Id : Entity_Id) return Boolean
- is
- Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
-
- function Has_Unconstrained_Access_Discriminant_Component
- (Comp_Typ : Entity_Id) return Boolean;
- -- Returns True if any component of the type has an unconstrained access
- -- discriminant.
-
- -----------------------------------------------------
- -- Has_Unconstrained_Access_Discriminant_Component --
- -----------------------------------------------------
-
- function Has_Unconstrained_Access_Discriminant_Component
- (Comp_Typ : Entity_Id) return Boolean
- is
- begin
- if not Is_Limited_Type (Comp_Typ) then
- return False;
-
- -- Only limited types can have access discriminants with
- -- defaults.
-
- elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then
- return True;
-
- elsif Is_Array_Type (Comp_Typ) then
- return Has_Unconstrained_Access_Discriminant_Component
- (Underlying_Type (Component_Type (Comp_Typ)));
-
- elsif Is_Record_Type (Comp_Typ) then
- declare
- Comp : Entity_Id;
-
- begin
- Comp := First_Component (Comp_Typ);
- while Present (Comp) loop
- if Has_Unconstrained_Access_Discriminant_Component
- (Underlying_Type (Etype (Comp)))
- then
- return True;
- end if;
-
- Next_Component (Comp);
- end loop;
- end;
- end if;
-
- return False;
- end Has_Unconstrained_Access_Discriminant_Component;
-
- Disable_Coextension_Cases : constant Boolean := True;
- -- Flag used to temporarily disable a "True" result for types with
- -- access discriminants and related coextension cases.
-
- -- Start of processing for Needs_Result_Accessibility_Level
-
- begin
- -- False if completion unavailable (how does this happen???)
-
- if not Present (Func_Typ) then
- return False;
-
- -- False if not a function, also handle enum-lit renames case
-
- elsif Func_Typ = Standard_Void_Type
- or else Is_Scalar_Type (Func_Typ)
- then
- return False;
-
- -- Handle a corner case, a cross-dialect subp renaming. For example,
- -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when
- -- an Ada 2005 (or earlier) unit references predefined run-time units.
-
- elsif Present (Alias (Func_Id)) then
-
- -- Unimplemented: a cross-dialect subp renaming which does not set
- -- the Alias attribute (e.g., a rename of a dereference of an access
- -- to subprogram value). ???
-
- return Present (Extra_Accessibility_Of_Result (Alias (Func_Id)));
-
- -- Remaining cases require Ada 2012 mode
-
- elsif Ada_Version < Ada_2012 then
- return False;
-
- -- Handle the situation where a result is an anonymous access type
- -- RM 3.10.2 (10.3/3).
-
- elsif Ekind (Func_Typ) = E_Anonymous_Access_Type then
- return True;
-
- -- The following cases are related to coextensions and do not fully
- -- cover everything mentioned in RM 3.10.2 (12) ???
-
- -- Temporarily disabled ???
-
- elsif Disable_Coextension_Cases then
- return False;
-
- -- In the case of, say, a null tagged record result type, the need for
- -- this extra parameter might not be obvious so this function returns
- -- True for all tagged types for compatibility reasons.
-
- -- A function with, say, a tagged null controlling result type might
- -- be overridden by a primitive of an extension having an access
- -- discriminant and the overrider and overridden must have compatible
- -- calling conventions (including implicitly declared parameters).
-
- -- Similarly, values of one access-to-subprogram type might designate
- -- both a primitive subprogram of a given type and a function which is,
- -- for example, not a primitive subprogram of any type. Again, this
- -- requires calling convention compatibility. It might be possible to
- -- solve these issues by introducing wrappers, but that is not the
- -- approach that was chosen.
-
- elsif Is_Tagged_Type (Func_Typ) then
- return True;
-
- elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then
- return True;
-
- elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then
- return True;
-
- -- False for all other cases
-
- else
- return False;
- end if;
- end Needs_Result_Accessibility_Level;
-
-------------------------------------
-- Replace_Renaming_Declaration_Id --
-------------------------------------
@@ -9636,7 +10108,7 @@ package body Exp_Ch6 is
Last_Formal := First_Formal (Proc_Id);
while Present (Next_Formal (Last_Formal)) loop
- Last_Formal := Next_Formal (Last_Formal);
+ Next_Formal (Last_Formal);
end loop;
Actuals := Parameter_Associations (N);
@@ -9744,7 +10216,7 @@ package body Exp_Ch6 is
-- Mark the label of a source or internally generated block or
-- loop.
- if Nkind_In (P, N_Block_Statement, N_Loop_Statement) then
+ if Nkind (P) in N_Block_Statement | N_Loop_Statement then
Set_Sec_Stack_Needed_For_Return (Entity (Identifier (P)));
-- Mark the enclosing function
@@ -9791,18 +10263,18 @@ package body Exp_Ch6 is
-- Recurse to handle case of multiple levels of qualification and/or
-- conversion.
- if Nkind_In (Expr, N_Qualified_Expression,
- N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ if Nkind (Expr) in N_Qualified_Expression
+ | N_Type_Conversion
+ | N_Unchecked_Type_Conversion
then
return Unqual_BIP_Function_Call (Expression (Expr));
-- Recurse to handle case of multiple levels of references and
-- explicit dereferences.
- elsif Nkind_In (Expr, N_Attribute_Reference,
- N_Explicit_Dereference,
- N_Reference)
+ elsif Nkind (Expr) in N_Attribute_Reference
+ | N_Explicit_Dereference
+ | N_Reference
then
return Unqual_BIP_Function_Call (Prefix (Expr));
@@ -9810,7 +10282,7 @@ package body Exp_Ch6 is
elsif Nkind (Expr) = N_Identifier
and then Present (Entity (Expr))
- and then Ekind_In (Entity (Expr), E_Constant, E_Variable)
+ and then Ekind (Entity (Expr)) in E_Constant | E_Variable
and then Nkind (Parent (Entity (Expr))) =
N_Object_Renaming_Declaration
and then Present (Renamed_Object (Entity (Expr)))
@@ -9823,7 +10295,7 @@ package body Exp_Ch6 is
elsif not On_Object_Declaration
and then Nkind (Expr) = N_Identifier
and then Present (Entity (Expr))
- and then Ekind_In (Entity (Expr), E_Constant, E_Variable)
+ and then Ekind (Entity (Expr)) in E_Constant | E_Variable
and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
and then Present (Expression (Parent (Entity (Expr))))
then
@@ -9871,4 +10343,15 @@ package body Exp_Ch6 is
return Unqual_BIP_Function_Call (Expr);
end Unqual_BIP_Iface_Function_Call;
+ --------------
+ -- Warn_BIP --
+ --------------
+
+ procedure Warn_BIP (Func_Call : Node_Id) is
+ begin
+ if Debug_Flag_Underscore_BB then
+ Error_Msg_N ("build-in-place function call?", Func_Call);
+ end if;
+ end Warn_BIP;
+
end Exp_Ch6;
diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads
index 13ccb2a..69b1909 100644
--- a/gcc/ada/exp_ch6.ads
+++ b/gcc/ada/exp_ch6.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -102,6 +102,9 @@ package Exp_Ch6 is
-- Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names
-- for build-in-place formal parameters of the given kind.
+ function BIP_Suffix_Kind (E : Entity_Id) return BIP_Formal_Kind;
+ -- Ada 2005 (AI-318-02): Returns the kind of the given BIP extra formal.
+
function Build_In_Place_Formal
(Func : Entity_Id;
Kind : BIP_Formal_Kind) return Entity_Id;
@@ -117,6 +120,9 @@ package Exp_Ch6 is
-- The returned node is the root of the procedure body which will replace
-- the original function body, which is not needed for the C program.
+ function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-318-02): Returns True if E is a BIP entity.
+
function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if functions returning the type use
-- build-in-place protocols. For inherently limited types, this must be
@@ -234,6 +240,10 @@ package Exp_Ch6 is
-- the constructor, and the allocator is rewritten to refer to that access
-- object. Function_Call must denote a call to a CPP_Constructor function.
+ function Might_Have_Tasks (Typ : Entity_Id) return Boolean;
+ -- Return True if Typ is a limited class-wide type (or subtype), since it
+ -- might have task components.
+
function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Return True if the function needs an implicit
-- BIP_Alloc_Form parameter (see type BIP_Formal_Kind).
@@ -247,12 +257,6 @@ package Exp_Ch6 is
function Needs_BIP_Task_Actuals (Func_Id : Entity_Id) return Boolean;
-- Return True if the function returns an object of a type that has tasks.
- function Needs_Result_Accessibility_Level
- (Func_Id : Entity_Id) return Boolean;
- -- Ada 2012 (AI05-0234): Return True if the function needs an implicit
- -- parameter to identify the accessibility level of the function result
- -- "determined by the point of call".
-
function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id;
-- Return the inner BIP function call removing any qualification from Expr
-- including qualified expressions, type conversions, references, unchecked
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 125eba6..07640bf 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -368,7 +368,7 @@ package body Exp_Ch7 is
-- Mode such subprograms must be handled as nested inside the (implicit)
-- elaboration procedure that executes that statement part. To handle
-- properly uplevel references we construct that subprogram explicitly,
- -- to contain blocks and inner subprograms, The statement part becomes
+ -- to contain blocks and inner subprograms, the statement part becomes
-- a call to this subprogram. This is only done if blocks are present
-- in the statement list of the body. (It would be nice to unify this
-- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since
@@ -909,7 +909,7 @@ package body Exp_Ch7 is
elsif Is_Protected_Body then
declare
Spec : constant Node_Id := Parent (Corresponding_Spec (N));
- Conc_Typ : Entity_Id;
+ Conc_Typ : Entity_Id := Empty;
Param : Node_Id;
Param_Typ : Entity_Id;
@@ -929,6 +929,7 @@ package body Exp_Ch7 is
end loop;
pragma Assert (Present (Param));
+ pragma Assert (Present (Conc_Typ));
-- Historical note: In earlier versions of GNAT, there was code
-- at this point to generate stuff to service entry queues. It is
@@ -1342,8 +1343,8 @@ package body Exp_Ch7 is
-- Treat use clauses as declarations and insert directly in front
-- of them.
- if Nkind_In (Insertion_Node, N_Use_Package_Clause,
- N_Use_Type_Clause)
+ if Nkind (Insertion_Node) in
+ N_Use_Package_Clause | N_Use_Type_Clause
then
Insert_List_Before_And_Analyze (Insertion_Node, Actions);
else
@@ -1375,12 +1376,12 @@ package body Exp_Ch7 is
---------------------
procedure Build_Finalizer
- (N : Node_Id;
- Clean_Stmts : List_Id;
- Mark_Id : Entity_Id;
- Top_Decls : List_Id;
- Defer_Abort : Boolean;
- Fin_Id : out Entity_Id)
+ (N : Node_Id;
+ Clean_Stmts : List_Id;
+ Mark_Id : Entity_Id;
+ Top_Decls : List_Id;
+ Defer_Abort : Boolean;
+ Fin_Id : out Entity_Id)
is
Acts_As_Clean : constant Boolean :=
Present (Mark_Id)
@@ -2049,10 +2050,8 @@ package body Exp_Ch7 is
-- freeze node, the body must be inserted directly after the
-- construct.
- if Nkind_In (Last_Top_Level_Ctrl_Construct,
- N_Freeze_Entity,
- N_Package_Declaration,
- N_Package_Body)
+ if Nkind (Last_Top_Level_Ctrl_Construct) in
+ N_Freeze_Entity | N_Package_Declaration | N_Package_Body
then
Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
end if;
@@ -2154,7 +2153,6 @@ package body Exp_Ch7 is
Decl := Last_Non_Pragma (Decls);
while Present (Decl) loop
-
-- Library-level tagged types
if Nkind (Decl) = N_Full_Type_Declaration then
@@ -2845,13 +2843,10 @@ package body Exp_Ch7 is
Result := Next (Stmt);
while Present (Result) loop
- if not Nkind_In (Result, N_Call_Marker,
- N_Raise_Program_Error)
- then
- exit;
- end if;
+ exit when Nkind (Result) not in
+ N_Call_Marker | N_Raise_Program_Error;
- Result := Next (Result);
+ Next (Result);
end loop;
return Result;
@@ -2894,7 +2889,7 @@ package body Exp_Ch7 is
if No_Initialization (Decl) then
if No (Expression (Last_Init)) then
loop
- Last_Init := Next (Last_Init);
+ Next (Last_Init);
exit when No (Last_Init);
exit when Nkind (Last_Init) = N_Object_Declaration
and then Nkind (Expression (Last_Init)) = N_Reference
@@ -3045,7 +3040,7 @@ package body Exp_Ch7 is
-- Insert the counter after all initialization has been done. The
-- place of insertion depends on the context.
- if Ekind_In (Obj_Id, E_Constant, E_Variable) then
+ if Ekind (Obj_Id) in E_Constant | E_Variable then
-- The object is initialized by a build-in-place function call.
-- The counter insertion point is after the function call.
@@ -3270,7 +3265,7 @@ package body Exp_Ch7 is
end;
end if;
- if Ekind_In (Obj_Id, E_Constant, E_Variable)
+ if Ekind (Obj_Id) in E_Constant | E_Variable
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
then
-- Temporaries created for the purpose of "exporting" a
@@ -3509,7 +3504,7 @@ package body Exp_Ch7 is
-- Step 3: Finalizer creation
- if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
+ if Acts_As_Clean or else Has_Ctrl_Objs or else Has_Tagged_Types then
Create_Finalizer;
end if;
end Build_Finalizer;
@@ -4361,7 +4356,7 @@ package body Exp_Ch7 is
if Is_Subprogram (E) then
return True;
- elsif Ekind_In (E, E_Block, E_Loop)
+ elsif Ekind (E) in E_Block | E_Loop
and then Contains_Subprogram (E)
then
return True;
@@ -4393,7 +4388,7 @@ package body Exp_Ch7 is
Ftyp := Etype (Fent);
- if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then
+ if Nkind (Arg) in N_Type_Conversion | N_Unchecked_Type_Conversion then
Atyp := Entity (Subtype_Mark (Arg));
else
Atyp := Etype (Arg);
@@ -4414,7 +4409,7 @@ package body Exp_Ch7 is
-- Make_Init_Call, set the target type to the type of the formal
-- directly, to avoid spurious typing problems.
- elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion)
+ elsif Nkind (Arg) in N_Unchecked_Type_Conversion | N_Type_Conversion
and then not Is_Class_Wide_Type (Atyp)
then
Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
@@ -4633,12 +4628,12 @@ package body Exp_Ch7 is
function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean is
begin
- return Ekind_In (Id, E_Entry,
- E_Entry_Family,
- E_Function,
- E_Package,
- E_Procedure,
- E_Subprogram_Body);
+ return Ekind (Id) in E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Package
+ | E_Procedure
+ | E_Subprogram_Body;
end Is_Package_Or_Subprogram;
-- Local variables
@@ -4711,11 +4706,12 @@ package body Exp_Ch7 is
----------------------------
procedure Expand_Cleanup_Actions (N : Node_Id) is
- pragma Assert (Nkind_In (N, N_Block_Statement,
- N_Entry_Body,
- N_Extended_Return_Statement,
- N_Subprogram_Body,
- N_Task_Body));
+ pragma Assert
+ (Nkind (N) in N_Block_Statement
+ | N_Entry_Body
+ | N_Extended_Return_Statement
+ | N_Subprogram_Body
+ | N_Task_Body);
Scop : constant Entity_Id := Current_Scope;
@@ -5305,9 +5301,8 @@ package body Exp_Ch7 is
-- of the alternative.
if Nkind (Parent (Curr)) = N_Entry_Call_Alternative
- and then Nkind_In (Parent (Parent (Curr)),
- N_Conditional_Entry_Call,
- N_Timed_Entry_Call)
+ and then Nkind (Parent (Parent (Curr))) in
+ N_Conditional_Entry_Call | N_Timed_Entry_Call
then
return Parent (Parent (Curr));
@@ -5648,7 +5643,7 @@ package body Exp_Ch7 is
-- <or>
-- Hook := Obj_Id'Unrestricted_Access;
- if Ekind_In (Obj_Id, E_Constant, E_Variable)
+ if Ekind (Obj_Id) in E_Constant | E_Variable
and then Present (Last_Aggregate_Assignment (Obj_Id))
then
Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
@@ -5720,8 +5715,8 @@ package body Exp_Ch7 is
Blk_Decl : Node_Id := Empty;
Blk_Decls : List_Id := No_List;
Blk_Ins : Node_Id;
- Blk_Stmts : List_Id;
- Loc : Source_Ptr;
+ Blk_Stmts : List_Id := No_List;
+ Loc : Source_Ptr := No_Location;
Obj_Decl : Node_Id;
-- Start of processing for Process_Transients_In_Scope
@@ -5854,6 +5849,7 @@ package body Exp_Ch7 is
-- Construct all necessary circuitry to hook and finalize a
-- single transient object.
+ pragma Assert (Present (Blk_Stmts));
Process_Transient_In_Scope
(Obj_Decl => Obj_Decl,
Blk_Data => Blk_Data,
@@ -5875,6 +5871,9 @@ package body Exp_Ch7 is
if Present (Blk_Decl) then
+ pragma Assert (Present (Blk_Stmts));
+ pragma Assert (Loc /= No_Location);
+
-- Note that this Abort_Undefer does not require a extra block or
-- an AT_END handler because each finalization exception is caught
-- in its own corresponding finalization block. As a result, the
@@ -8285,12 +8284,12 @@ package body Exp_Ch7 is
Ref := Convert_Concurrent (Ref, Typ);
elsif Is_Private_Type (Typ)
- and then Present (Full_View (Typ))
- and then Is_Concurrent_Type (Full_View (Typ))
+ and then Present (Underlying_Type (Typ))
+ and then Is_Concurrent_Type (Underlying_Type (Typ))
then
- Utyp := Corresponding_Record_Type (Full_View (Typ));
+ Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
Atyp := Typ;
- Ref := Convert_Concurrent (Ref, Full_View (Typ));
+ Ref := Convert_Concurrent (Ref, Underlying_Type (Typ));
else
Utyp := Typ;
@@ -8427,6 +8426,15 @@ package body Exp_Ch7 is
end if;
end;
+ -- If the object is unanalyzed, set its expected type for use in
+ -- Convert_View in case an additional conversion is needed.
+
+ if No (Etype (Ref))
+ and then Nkind (Ref) /= N_Unchecked_Type_Conversion
+ then
+ Set_Etype (Ref, Typ);
+ end if;
+
Ref := Convert_View (Fin_Id, Ref);
end if;
@@ -8999,10 +9007,9 @@ package body Exp_Ch7 is
Par : Node_Id := Parent (N);
begin
- while not (Nkind_In (Par, N_Handled_Sequence_Of_Statements,
- N_Loop_Statement,
- N_Package_Specification)
- or else Nkind (Par) in N_Proper_Body)
+ while Nkind (Par) not in
+ N_Handled_Sequence_Of_Statements | N_Loop_Statement |
+ N_Package_Specification | N_Proper_Body
loop
pragma Assert (Present (Par));
Par := Parent (Par);
@@ -9089,12 +9096,12 @@ package body Exp_Ch7 is
-- Prevent the search from going too far because transient blocks
-- are bounded by packages and subprogram scopes.
- elsif Ekind_In (Scop, E_Entry,
- E_Entry_Family,
- E_Function,
- E_Package,
- E_Procedure,
- E_Subprogram_Body)
+ elsif Ekind (Scop) in E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Package
+ | E_Procedure
+ | E_Subprogram_Body
then
exit;
end if;
@@ -9385,7 +9392,7 @@ package body Exp_Ch7 is
Manage_SS =>
Uses_Sec_Stack (Curr_S)
and then Nkind (N) = N_Object_Declaration
- and then Ekind_In (Encl_S, E_Package, E_Package_Body)
+ and then Ekind (Encl_S) in E_Package | E_Package_Body
and then Is_Library_Level_Entity (Encl_S));
Pop_Scope;
diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads
index d13c6c5..235b75a 100644
--- a/gcc/ada/exp_ch7.ads
+++ b/gcc/ada/exp_ch7.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb
index dcb51ef6..630d62f 100644
--- a/gcc/ada/exp_ch8.adb
+++ b/gcc/ada/exp_ch8.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -125,7 +125,7 @@ package body Exp_Ch8 is
if Modify_Tree_For_C then
return True;
- elsif Nkind_In (Nam, N_Indexed_Component, N_Slice) then
+ elsif Nkind (Nam) in N_Indexed_Component | N_Slice then
if Is_Packed (Etype (Prefix (Nam))) then
return True;
@@ -209,10 +209,7 @@ package body Exp_Ch8 is
-- needing debug info if it comes from sources because the current
-- setting in Freeze_Entity occurs too late. ???
- if Comes_From_Source (Defining_Identifier (N)) then
- Set_Debug_Info_Needed (Defining_Identifier (N));
- end if;
-
+ Set_Debug_Info_Defining_Id (N);
Decl := Debug_Renaming_Declaration (N);
if Present (Decl) then
diff --git a/gcc/ada/exp_ch8.ads b/gcc/ada/exp_ch8.ads
index 4c2ec95..f3c5343 100644
--- a/gcc/ada/exp_ch8.ads
+++ b/gcc/ada/exp_ch8.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 64ac353..9cf90d1 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -23,8 +23,8 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
with Atree; use Atree;
+with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
@@ -53,9 +53,9 @@ with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch9; use Sem_Ch9;
with Sem_Ch11; use Sem_Ch11;
+with Sem_Ch13; use Sem_Ch13;
with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
-with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
@@ -435,6 +435,8 @@ package body Exp_Ch9 is
Conctyp : Entity_Id;
Lo : Node_Id;
Hi : Node_Id) return Boolean;
+ -- Determine whether an entry family is potentially large because one of
+ -- its bounds denotes a discrminant.
function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean;
-- Determine whether Id is a function or a procedure and is marked as a
@@ -586,7 +588,15 @@ package body Exp_Ch9 is
-- structure.
if Present (Index) then
- S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
+ S := Entry_Index_Type (Ent);
+
+ -- First make sure the index is in range if requested. The index type
+ -- has been directly set on the prefix, see Resolve_Entry.
+
+ if Do_Range_Check (Index) then
+ Generate_Range_Check
+ (Index, Etype (Prefix (Parent (Index))), CE_Range_Check_Failed);
+ end if;
Expr :=
Make_Op_Add (Sloc,
@@ -613,8 +623,7 @@ package body Exp_Ch9 is
Set_Intval (Num, Intval (Num) + 1);
elsif Ekind (Prev) = E_Entry_Family then
- S :=
- Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
+ S := Entry_Index_Type (Prev);
-- The need for the following full view retrieval stems from this
-- complex case of nested generics and tasking:
@@ -736,8 +745,9 @@ package body Exp_Ch9 is
Renamed_Formal :=
Make_Selected_Component (Loc,
Prefix =>
- Unchecked_Convert_To (Entry_Parameters_Type (Ent),
- Make_Identifier (Loc, Chars (Ptr))),
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (Entry_Parameters_Type (Ent),
+ Make_Identifier (Loc, Chars (Ptr)))),
Selector_Name => New_Occurrence_Of (Comp, Loc));
Decl :=
@@ -826,6 +836,16 @@ package body Exp_Ch9 is
Insert_Before (Last (Statements (Stats)), Call);
Analyze (Call);
+ -- Ada 2020 (AI12-0279)
+
+ if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat)))
+ and then RTE_Available (RE_Yield)
+ then
+ Insert_Action_After (Call,
+ Make_Procedure_Call_Statement (Loc,
+ New_Occurrence_Of (RTE (RE_Yield), Loc)));
+ end if;
+
-- If exception handlers are present, then append Complete_Rendezvous
-- calls to the handlers, and construct the required outer block. As
-- above, the Sloc is copied from the last statement in the sequence.
@@ -838,6 +858,17 @@ package body Exp_Ch9 is
(Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous);
Append (Call, Statements (Hand));
Analyze (Call);
+
+ -- Ada 2020 (AI12-0279)
+
+ if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat)))
+ and then RTE_Available (RE_Yield)
+ then
+ Insert_Action_After (Call,
+ Make_Procedure_Call_Statement (Loc,
+ New_Occurrence_Of (RTE (RE_Yield), Loc)));
+ end if;
+
Next (Hand);
end loop;
@@ -861,6 +892,16 @@ package body Exp_Ch9 is
-- We handle Abort_Signal to make sure that we properly catch the abort
-- case and wake up the caller.
+ Call :=
+ Make_Procedure_Call_Statement (Sloc (Stats),
+ Name => New_Occurrence_Of (
+ RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)),
+ Parameter_Associations => New_List (
+ Make_Function_Call (Sloc (Stats),
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Get_GNAT_Exception), Sloc (Stats)))));
+
Ohandle := Make_Others_Choice (Loc);
Set_All_Others (Ohandle);
@@ -869,15 +910,17 @@ package body Exp_Ch9 is
Make_Implicit_Exception_Handler (Loc,
Exception_Choices => New_List (Ohandle),
- Statements => New_List (
- Make_Procedure_Call_Statement (Sloc (Stats),
- Name => New_Occurrence_Of (
- RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)),
- Parameter_Associations => New_List (
- Make_Function_Call (Sloc (Stats),
- Name =>
- New_Occurrence_Of
- (RTE (RE_Get_GNAT_Exception), Sloc (Stats)))))))));
+ Statements => New_List (Call))));
+
+ -- Ada 2020 (AI12-0279)
+
+ if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat)))
+ and then RTE_Available (RE_Yield)
+ then
+ Insert_Action_After (Call,
+ Make_Procedure_Call_Statement (Loc,
+ New_Occurrence_Of (RTE (RE_Yield), Loc)));
+ end if;
Set_Parent (New_S, Astat); -- temp parent for Analyze call
Analyze_Exception_Handlers (Exception_Handlers (New_S));
@@ -928,6 +971,12 @@ package body Exp_Ch9 is
-- Start of processing for Build_Activation_Chain_Entity
begin
+ -- No action needed if the run-time has no tasking support
+
+ if Global_No_Tasking then
+ return;
+ end if;
+
-- Activation chain is never used for sequential elaboration policy, see
-- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
@@ -1127,9 +1176,9 @@ package body Exp_Ch9 is
Ren_Decl : Node_Id;
begin
- -- Nothing to do if there is no task hierarchy
+ -- No action needed if the run-time has no tasking support
- if Restriction_Active (No_Task_Hierarchy) then
+ if Global_No_Tasking then
return;
end if;
@@ -1166,24 +1215,21 @@ package body Exp_Ch9 is
if not Has_Master_Entity (Master_Scope)
or else No (Current_Entity_In_Scope (Name_Id))
then
+ declare
+ Ins_Nod : Node_Id;
+
begin
Set_Has_Master_Entity (Master_Scope);
+ Master_Decl := Build_Master_Declaration (Loc);
- -- Generate:
- -- _master : constant Integer := Current_Master.all;
+ -- Ensure that the master declaration is placed before its use
- Master_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uMaster),
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (Standard_Integer, Loc),
- Expression =>
- Make_Explicit_Dereference (Loc,
- New_Occurrence_Of (RTE (RE_Current_Master), Loc)));
+ Ins_Nod := Find_Hook_Context (Related_Node);
+ while not Is_List_Member (Ins_Nod) loop
+ Ins_Nod := Parent (Ins_Nod);
+ end loop;
- Insert_Action (Find_Hook_Context (Related_Node), Master_Decl);
+ Insert_Before (First (List_Containing (Ins_Nod)), Master_Decl);
Analyze (Master_Decl);
-- Mark the containing scope as a task master. Masters associated
@@ -1202,9 +1248,8 @@ package body Exp_Ch9 is
-- and the environment task is our effective master,
-- so nothing to mark.
- if Nkind_In (Par, N_Block_Statement,
- N_Subprogram_Body,
- N_Task_Body)
+ if Nkind (Par) in
+ N_Block_Statement | N_Subprogram_Body | N_Task_Body
then
Set_Is_Task_Master (Par);
exit;
@@ -1414,8 +1459,8 @@ package body Exp_Ch9 is
Prag := Pre_Post_Conditions (Items);
while Present (Prag) loop
- if Nam_In (Pragma_Name_Unmapped (Prag),
- Name_Postcondition, Name_Precondition)
+ if Pragma_Name_Unmapped (Prag) in Name_Postcondition
+ | Name_Precondition
and then Is_Checked (Prag)
then
Has_Pragma := True;
@@ -1677,7 +1722,7 @@ package body Exp_Ch9 is
Next (Comp);
end loop;
- Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
+ Typ := Entry_Index_Type (Ent);
Hi := Type_High_Bound (Typ);
Lo := Type_Low_Bound (Typ);
Large := Is_Potentially_Large_Family
@@ -1695,6 +1740,65 @@ package body Exp_Ch9 is
return Ecount;
end Build_Entry_Count_Expression;
+ ------------------------------
+ -- Build_Master_Declaration --
+ ------------------------------
+
+ function Build_Master_Declaration (Loc : Source_Ptr) return Node_Id is
+ Master_Decl : Node_Id;
+
+ begin
+ -- Generate a dummy master if tasks or tasking hierarchies are
+ -- prohibited.
+
+ -- _Master : constant Master_Id := 3;
+
+ if not Tasking_Allowed
+ or else Restrictions.Set (No_Task_Hierarchy)
+ or else not RTE_Available (RE_Current_Master)
+ then
+ declare
+ Expr : Node_Id;
+
+ begin
+ -- RE_Library_Task_Level is not always available in configurable
+ -- RunTime
+
+ if not RTE_Available (RE_Library_Task_Level) then
+ Expr := Make_Integer_Literal (Loc, Uint_3);
+ else
+ Expr := New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc);
+ end if;
+
+ Master_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uMaster),
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Integer, Loc),
+ Expression => Expr);
+ end;
+
+ -- Generate:
+ -- _master : constant Integer := Current_Master.all;
+
+ else
+ Master_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uMaster),
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Integer, Loc),
+ Expression =>
+ Make_Explicit_Dereference (Loc,
+ New_Occurrence_Of (RTE (RE_Current_Master), Loc)));
+ end if;
+
+ return Master_Decl;
+ end Build_Master_Declaration;
+
---------------------------
-- Build_Parameter_Block --
---------------------------
@@ -2128,7 +2232,7 @@ package body Exp_Ch9 is
if Present (First_Formal (Iface_Op))
and then Is_Controlling_Formal (First_Formal (Iface_Op))
then
- Iface_Op_Param := Next (Iface_Op_Param);
+ Next (Iface_Op_Param);
end if;
Wrapper_Param := First (Wrapper_Params);
@@ -2213,7 +2317,7 @@ package body Exp_Ch9 is
if Is_Private_Primitive_Subprogram (Subp_Id)
and then not Has_Controlling_Result (Subp_Id)
then
- Formal := Next (Formal);
+ Next (Formal);
end if;
while Present (Formal) loop
@@ -2546,7 +2650,7 @@ package body Exp_Ch9 is
Lo : Node_Id;
Hi : Node_Id;
Decls : List_Id := New_List;
- Ret : Node_Id;
+ Ret : Node_Id := Empty;
Spec : Node_Id;
Siz : Node_Id := Empty;
@@ -2677,7 +2781,7 @@ package body Exp_Ch9 is
Add_If_Clause (Make_Integer_Literal (Loc, 1));
elsif Ekind (Ent) = E_Entry_Family then
- E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
+ E_Typ := Entry_Index_Type (Ent);
Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ));
Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ));
Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False));
@@ -2692,16 +2796,21 @@ package body Exp_Ch9 is
Make_Simple_Return_Statement (Loc,
Expression => Make_Integer_Literal (Loc, 1));
- elsif Nkind (Ret) = N_If_Statement then
+ else
+ pragma Assert (Present (Ret));
- -- Ranges are in increasing order, so last one doesn't need guard
+ if Nkind (Ret) = N_If_Statement then
- declare
- Nod : constant Node_Id := Last (Elsif_Parts (Ret));
- begin
- Remove (Nod);
- Set_Else_Statements (Ret, Then_Statements (Nod));
- end;
+ -- Ranges are in increasing order, so last one doesn't need
+ -- guard.
+
+ declare
+ Nod : constant Node_Id := Last (Elsif_Parts (Ret));
+ begin
+ Remove (Nod);
+ Set_Else_Statements (Ret, Then_Statements (Nod));
+ end;
+ end if;
end if;
end if;
@@ -3075,10 +3184,8 @@ package body Exp_Ch9 is
and then ((Nkind (N) = N_Simple_Return_Statement
and then N /= Last (Stmts))
or else Nkind (N) = N_Extended_Return_Statement
- or else (Nkind_In (N, N_Raise_Constraint_Error,
- N_Raise_Program_Error,
- N_Raise_Statement,
- N_Raise_Storage_Error)
+ or else (Nkind (N) in
+ N_Raise_xxx_Error | N_Raise_Statement
and then Comes_From_Source (N)))
then
Wrap_Statement (N);
@@ -3340,12 +3447,40 @@ package body Exp_Ch9 is
Par : Node_Id;
begin
+ -- No action needed if the run-time has no tasking support
+
+ if Global_No_Tasking then
+ return;
+ end if;
+
if Is_Itype (Obj_Or_Typ) then
Par := Associated_Node_For_Itype (Obj_Or_Typ);
else
Par := Parent (Obj_Or_Typ);
end if;
+ -- For transient scopes check if the master entity is already defined
+
+ if Is_Type (Obj_Or_Typ)
+ and then Ekind (Scope (Obj_Or_Typ)) = E_Block
+ and then Is_Internal (Scope (Obj_Or_Typ))
+ then
+ declare
+ Master_Scope : constant Entity_Id :=
+ Find_Master_Scope (Obj_Or_Typ);
+ begin
+ if Has_Master_Entity (Master_Scope)
+ or else Is_Finalizer (Master_Scope)
+ then
+ return;
+ end if;
+
+ if Present (Current_Entity_In_Scope (Name_uMaster)) then
+ return;
+ end if;
+ end;
+ end if;
+
-- When creating a master for a record component which is either a task
-- or access-to-task, the enclosing record is the master scope and the
-- proper insertion point is the component list.
@@ -3363,31 +3498,16 @@ package body Exp_Ch9 is
Find_Enclosing_Context (Par, Context, Context_Id, Decls);
end if;
- -- Nothing to do if the context already has a master
-
- if Has_Master_Entity (Context_Id) then
- return;
-
- -- Nothing to do if tasks or tasking hierarchies are prohibited
+ -- Nothing to do if the context already has a master; internally built
+ -- finalizers don't need a master.
- elsif Restriction_Active (No_Tasking)
- or else Restriction_Active (No_Task_Hierarchy)
+ if Has_Master_Entity (Context_Id)
+ or else Is_Finalizer (Context_Id)
then
return;
end if;
- -- Create a master, generate:
- -- _Master : constant Master_Id := Current_Master.all;
-
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uMaster),
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (RTE (RE_Master_Id), Loc),
- Expression =>
- Make_Explicit_Dereference (Loc,
- New_Occurrence_Of (RTE (RE_Current_Master), Loc)));
+ Decl := Build_Master_Declaration (Loc);
-- The master is inserted at the start of the declarative list of the
-- context.
@@ -3414,9 +3534,8 @@ package body Exp_Ch9 is
while Present (Context)
and then Nkind (Context) /= N_Compilation_Unit
loop
- if Nkind_In (Context, N_Block_Statement,
- N_Subprogram_Body,
- N_Task_Body)
+ if Nkind (Context) in
+ N_Block_Statement | N_Subprogram_Body | N_Task_Body
then
Set_Is_Task_Master (Context);
exit;
@@ -3443,11 +3562,9 @@ package body Exp_Ch9 is
Master_Id : Entity_Id;
begin
- -- Nothing to do if tasks or tasking hierarchies are prohibited
+ -- No action needed if the run-time has no tasking support
- if Restriction_Active (No_Tasking)
- or else Restriction_Active (No_Task_Hierarchy)
- then
+ if Global_No_Tasking then
return;
end if;
@@ -3455,18 +3572,53 @@ package body Exp_Ch9 is
if Present (Ins_Nod) then
Context := Ins_Nod;
+
elsif Is_Itype (Ptr_Typ) then
Context := Associated_Node_For_Itype (Ptr_Typ);
+
+ -- When the context references a discriminant or a component of a
+ -- private type and we are processing declarations in the private
+ -- part of the enclosing package, we must insert the master renaming
+ -- before the full declaration of the private type; otherwise the
+ -- master renaming would be inserted in the public part of the
+ -- package (and hence before the declaration of _master).
+
+ if In_Private_Part (Current_Scope) then
+ declare
+ Ctx : Node_Id := Context;
+
+ begin
+ if Nkind (Context) = N_Discriminant_Specification then
+ Ctx := Parent (Ctx);
+ else
+ while Nkind (Ctx) in
+ N_Component_Declaration | N_Component_List
+ loop
+ Ctx := Parent (Ctx);
+ end loop;
+ end if;
+
+ if Nkind (Ctx) in N_Private_Type_Declaration
+ | N_Private_Extension_Declaration
+ then
+ Context := Parent (Full_View (Defining_Identifier (Ctx)));
+ end if;
+ end;
+ end if;
+
else
Context := Parent (Ptr_Typ);
end if;
-- Generate:
-- <Ptr_Typ>M : Master_Id renames _Master;
+ -- and add a numeric suffix to the name to ensure that it is
+ -- unique in case other access types in nested constructs
+ -- are homonyms of this one.
Master_Id :=
Make_Defining_Identifier (Loc,
- New_External_Name (Chars (Ptr_Typ), 'M'));
+ New_External_Name (Chars (Ptr_Typ), 'M', -1));
Master_Decl :=
Make_Object_Renaming_Declaration (Loc,
@@ -3481,177 +3633,6 @@ package body Exp_Ch9 is
Set_Master_Id (Ptr_Typ, Master_Id);
end Build_Master_Renaming;
- -----------------------------------------
- -- Build_Private_Protected_Declaration --
- -----------------------------------------
-
- function Build_Private_Protected_Declaration
- (N : Node_Id) return Entity_Id
- is
- procedure Analyze_Pragmas (From : Node_Id);
- -- Analyze all pragmas which follow arbitrary node From
-
- procedure Move_Pragmas (From : Node_Id; To : Node_Id);
- -- Find all suitable source pragmas at the top of subprogram body From's
- -- declarations and insert them after arbitrary node To.
- --
- -- Very similar to Move_Pragmas in sem_ch6 ???
-
- ---------------------
- -- Analyze_Pragmas --
- ---------------------
-
- procedure Analyze_Pragmas (From : Node_Id) is
- Decl : Node_Id;
-
- begin
- Decl := Next (From);
- while Present (Decl) loop
- if Nkind (Decl) = N_Pragma then
- Analyze_Pragma (Decl);
-
- -- No candidate pragmas are available for analysis
-
- else
- exit;
- end if;
-
- Next (Decl);
- end loop;
- end Analyze_Pragmas;
-
- ------------------
- -- Move_Pragmas --
- ------------------
-
- procedure Move_Pragmas (From : Node_Id; To : Node_Id) is
- Decl : Node_Id;
- Insert_Nod : Node_Id;
- Next_Decl : Node_Id;
-
- begin
- pragma Assert (Nkind (From) = N_Subprogram_Body);
-
- -- The pragmas are moved in an order-preserving fashion
-
- Insert_Nod := To;
-
- -- Inspect the declarations of the subprogram body and relocate all
- -- candidate pragmas.
-
- Decl := First (Declarations (From));
- while Present (Decl) loop
-
- -- Preserve the following declaration for iteration purposes, due
- -- to possible relocation of a pragma.
-
- Next_Decl := Next (Decl);
-
- -- We add an exception here for Unreferenced pragmas since the
- -- internally generated spec gets analyzed within
- -- Build_Private_Protected_Declaration and will lead to spurious
- -- warnings due to the way references are checked.
-
- if Nkind (Decl) = N_Pragma
- and then Pragma_Name_Unmapped (Decl) /= Name_Unreferenced
- then
- Remove (Decl);
- Insert_After (Insert_Nod, Decl);
- Insert_Nod := Decl;
-
- -- Skip internally generated code
-
- elsif not Comes_From_Source (Decl) then
- null;
-
- -- No candidate pragmas are available for relocation
-
- else
- exit;
- end if;
-
- Decl := Next_Decl;
- end loop;
- end Move_Pragmas;
-
- -- Local variables
-
- Body_Id : constant Entity_Id := Defining_Entity (N);
- Loc : constant Source_Ptr := Sloc (N);
- Decl : Node_Id;
- Formal : Entity_Id;
- Formals : List_Id;
- Spec : Node_Id;
- Spec_Id : Entity_Id;
-
- -- Start of processing for Build_Private_Protected_Declaration
-
- begin
- Formal := First_Formal (Body_Id);
-
- -- The protected operation always has at least one formal, namely the
- -- object itself, but it is only placed in the parameter list if
- -- expansion is enabled.
-
- if Present (Formal) or else Expander_Active then
- Formals := Copy_Parameter_List (Body_Id);
- else
- Formals := No_List;
- end if;
-
- Spec_Id :=
- Make_Defining_Identifier (Sloc (Body_Id),
- Chars => Chars (Body_Id));
-
- -- Indicate that the entity comes from source, to ensure that cross-
- -- reference information is properly generated. The body itself is
- -- rewritten during expansion, and the body entity will not appear in
- -- calls to the operation.
-
- Set_Comes_From_Source (Spec_Id, True);
-
- if Nkind (Specification (N)) = N_Procedure_Specification then
- Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Spec_Id,
- Parameter_Specifications => Formals);
- else
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => Spec_Id,
- Parameter_Specifications => Formals,
- Result_Definition =>
- New_Occurrence_Of (Etype (Body_Id), Loc));
- end if;
-
- Decl := Make_Subprogram_Declaration (Loc, Specification => Spec);
- Set_Corresponding_Body (Decl, Body_Id);
- Set_Corresponding_Spec (N, Spec_Id);
-
- Insert_Before (N, Decl);
-
- -- Associate all aspects and pragmas of the body with the spec. This
- -- ensures that these annotations apply to the initial declaration of
- -- the subprogram body.
-
- Move_Aspects (From => N, To => Decl);
- Move_Pragmas (From => N, To => Decl);
-
- Analyze (Decl);
-
- -- The analysis of the spec may generate pragmas which require manual
- -- analysis. Since the generation of the spec and the relocation of the
- -- annotations is driven by the expansion of the stand-alone body, the
- -- pragmas will not be analyzed in a timely manner. Do this now.
-
- Analyze_Pragmas (Decl);
-
- Set_Convention (Spec_Id, Convention_Protected);
- Set_Has_Completion (Spec_Id);
-
- return Spec_Id;
- end Build_Private_Protected_Declaration;
-
---------------------------
-- Build_Protected_Entry --
---------------------------
@@ -4001,6 +3982,13 @@ package body Exp_Ch9 is
Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id));
+ -- It seems we should set Has_Nested_Subprogram here, but instead we
+ -- currently set it in Expand_N_Protected_Body, because the entity
+ -- created here isn't the one that Corresponding_Spec of the body
+ -- will later be set to, and that's the entity where it's needed. ???
+
+ Set_Has_Nested_Subprogram (New_Id, Has_Nested_Subprogram (Def_Id));
+
if Nkind (Specification (Decl)) = N_Procedure_Specification then
New_Spec :=
Make_Procedure_Specification (Loc,
@@ -4514,12 +4502,6 @@ package body Exp_Ch9 is
Ent_Acc := Entry_Parameters_Type (Ent);
Conctyp := Etype (Concval);
- -- If prefix is an access type, dereference to obtain the task type
-
- if Is_Access_Type (Conctyp) then
- Conctyp := Designated_Type (Conctyp);
- end if;
-
-- Special case for protected subprogram calls
if Is_Protected_Type (Conctyp)
@@ -4963,9 +4945,10 @@ package body Exp_Ch9 is
Chain := Activation_Chain_Entity (Owner);
-- Nothing to do when there are no tasks to activate. This is indicated
- -- by a missing activation chain entity.
+ -- by a missing activation chain entity; also skip generating it when
+ -- it is a ghost entity.
- if No (Chain) then
+ if No (Chain) or else Is_Ignored_Ghost_Entity (Chain) then
return;
end if;
@@ -5255,23 +5238,21 @@ package body Exp_Ch9 is
Efam_Type := Make_Temporary (Loc, 'F');
declare
- Bas : Entity_Id :=
- Base_Type
- (Etype (Discrete_Subtype_Definition (Parent (Efam))));
-
- Bas_Decl : Node_Id := Empty;
- Lo, Hi : Node_Id;
+ Eityp : constant Entity_Id := Entry_Index_Type (Efam);
+ Lo : constant Node_Id := Type_Low_Bound (Eityp);
+ Hi : constant Node_Id := Type_High_Bound (Eityp);
+ Bdecl : Node_Id;
+ Bityp : Entity_Id;
begin
- Get_Index_Bounds
- (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi);
+ Bityp := Base_Type (Eityp);
- if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then
- Bas := Make_Temporary (Loc, 'B');
+ if Is_Potentially_Large_Family (Bityp, Conctyp, Lo, Hi) then
+ Bityp := Make_Temporary (Loc, 'B');
- Bas_Decl :=
+ Bdecl :=
Make_Subtype_Declaration (Loc,
- Defining_Identifier => Bas,
+ Defining_Identifier => Bityp,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
@@ -5284,9 +5265,9 @@ package body Exp_Ch9 is
Make_Integer_Literal
(Loc, Entry_Family_Bound - 1)))));
- Insert_After (Current_Node, Bas_Decl);
- Current_Node := Bas_Decl;
- Analyze (Bas_Decl);
+ Insert_After (Current_Node, Bdecl);
+ Current_Node := Bdecl;
+ Analyze (Bdecl);
end if;
Efam_Decl :=
@@ -5295,7 +5276,7 @@ package body Exp_Ch9 is
Type_Definition =>
Make_Unconstrained_Array_Definition (Loc,
Subtype_Marks =>
- (New_List (New_Occurrence_Of (Bas, Loc))),
+ (New_List (New_Occurrence_Of (Bityp, Loc))),
Component_Definition =>
Make_Component_Definition (Loc,
@@ -5324,10 +5305,8 @@ package body Exp_Ch9 is
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
- New_Occurrence_Of
- (Etype (Discrete_Subtype_Definition
- (Parent (Efam))), Loc)))))));
-
+ New_Occurrence_Of (Entry_Index_Type (Efam),
+ Loc)))))));
end if;
Next_Entity (Efam);
@@ -5592,7 +5571,7 @@ package body Exp_Ch9 is
-- _object : prot_typVP := prot_typV (_O);
-- subtype Jnn is <Type of Index> range Low .. High;
- if Nkind_In (Decl, N_Full_Type_Declaration, N_Object_Declaration) then
+ if Nkind (Decl) in N_Full_Type_Declaration | N_Object_Declaration then
Set_Debug_Info_Needed (Defining_Identifier (Decl));
-- Declaration for the Protection object, discriminals, privals, and
@@ -5691,7 +5670,14 @@ package body Exp_Ch9 is
-- using the index subtype which may mention a discriminant.
if Present (Index) then
- S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
+ S := Entry_Index_Type (Ent);
+
+ -- First make sure the index is in range if requested. The index type
+ -- is the pristine Entry_Index_Type of the entry.
+
+ if Do_Range_Check (Index) then
+ Generate_Range_Check (Index, S, CE_Range_Check_Failed);
+ end if;
Expr :=
Make_Op_Add (Sloc,
@@ -5721,7 +5707,7 @@ package body Exp_Ch9 is
Set_Intval (Num, Intval (Num) + 1);
elsif Ekind (Prev) = E_Entry_Family then
- S := Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
+ S := Entry_Index_Type (Prev);
Lo := Type_Low_Bound (S);
Hi := Type_High_Bound (S);
@@ -6006,9 +5992,10 @@ package body Exp_Ch9 is
Renamed_Formal :=
Make_Selected_Component (Loc,
Prefix =>
- Unchecked_Convert_To (
- Entry_Parameters_Type (Ent),
- New_Occurrence_Of (Ann, Loc)),
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (
+ Entry_Parameters_Type (Ent),
+ New_Occurrence_Of (Ann, Loc))),
Selector_Name =>
New_Occurrence_Of (Comp, Loc));
@@ -6129,12 +6116,12 @@ package body Exp_Ch9 is
-- If so, barrier may not be properly synchronized.
function Is_Pure_Barrier (N : Node_Id) return Traverse_Result;
- -- Check whether N follows the Pure_Barriers restriction. Return OK if
+ -- Check whether N meets the Pure_Barriers restriction. Return OK if
-- so.
- function Is_Simple_Barrier_Name (N : Node_Id) return Boolean;
- -- Check whether entity name N denotes a component of the protected
- -- object. This is used to check the Simple_Barrier restriction.
+ function Is_Simple_Barrier (N : Node_Id) return Boolean;
+ -- Check whether N meets the Simple_Barriers restriction. Return OK if
+ -- so.
----------------------
-- Is_Global_Entity --
@@ -6167,7 +6154,7 @@ package body Exp_Ch9 is
-- this safe. This is a common (if dubious) idiom.
elsif S = Scope (Prot)
- and then Ekind_In (S, E_Package, E_Generic_Package)
+ and then Is_Package_Or_Generic_Package (S)
and then Nkind (Parent (E)) = N_Object_Declaration
and then Nkind (Parent (Parent (E))) = N_Package_Body
then
@@ -6186,14 +6173,25 @@ package body Exp_Ch9 is
procedure Check_Unprotected_Barrier is
new Traverse_Proc (Is_Global_Entity);
- ----------------------------
- -- Is_Simple_Barrier_Name --
- ----------------------------
+ -----------------------
+ -- Is_Simple_Barrier --
+ -----------------------
- function Is_Simple_Barrier_Name (N : Node_Id) return Boolean is
+ function Is_Simple_Barrier (N : Node_Id) return Boolean is
Renamed : Node_Id;
begin
+ if Is_Static_Expression (N) then
+ return True;
+ elsif Ada_Version >= Ada_2020
+ and then Nkind (N) in N_Selected_Component | N_Indexed_Component
+ and then Statically_Names_Object (N)
+ then
+ -- Restriction relaxed in Ada2020 to allow statically named
+ -- subcomponents.
+ return Is_Simple_Barrier (Prefix (N));
+ end if;
+
-- Check if the name is a component of the protected object. If
-- the expander is active, the component has been transformed into a
-- renaming of _object.all.component. Original_Node is needed in case
@@ -6216,10 +6214,12 @@ package body Exp_Ch9 is
Present (Renamed)
and then Nkind (Renamed) = N_Selected_Component
and then Chars (Prefix (Prefix (Renamed))) = Name_uObject;
+ elsif not Is_Entity_Name (N) then
+ return False;
else
return Is_Protected_Component (Entity (N));
end if;
- end Is_Simple_Barrier_Name;
+ end Is_Simple_Barrier;
---------------------
-- Is_Pure_Barrier --
@@ -6231,28 +6231,37 @@ package body Exp_Ch9 is
when N_Expanded_Name
| N_Identifier
=>
+
+ -- Because of N_Expanded_Name case, return Skip instead of OK.
+
if No (Entity (N)) then
return Abandon;
- elsif Is_Universal_Numeric_Type (Entity (N)) then
- return OK;
+ elsif Is_Numeric_Type (Entity (N)) then
+ return Skip;
end if;
case Ekind (Entity (N)) is
when E_Constant
| E_Discriminant
- | E_Enumeration_Literal
+ =>
+ return Skip;
+
+ when E_Enumeration_Literal
| E_Named_Integer
| E_Named_Real
=>
- return OK;
+ if not Is_OK_Static_Expression (N) then
+ return Abandon;
+ end if;
+ return Skip;
when E_Component =>
- return OK;
+ return Skip;
when E_Variable =>
- if Is_Simple_Barrier_Name (N) then
- return OK;
+ if Is_Simple_Barrier (N) then
+ return Skip;
end if;
when E_Function =>
@@ -6263,7 +6272,7 @@ package body Exp_Ch9 is
if Is_RTE (Entity (N), RE_Protected_Count)
or else Is_RTE (Entity (N), RE_Protected_Count_Entry)
then
- return OK;
+ return Skip;
end if;
when others =>
@@ -6290,23 +6299,49 @@ package body Exp_Ch9 is
return OK;
end if;
- when N_Short_Circuit =>
+ when N_Short_Circuit
+ | N_If_Expression
+ | N_Case_Expression
+ =>
return OK;
- when N_Indexed_Component
- | N_Selected_Component
- =>
- if not Is_Access_Type (Etype (Prefix (N))) then
- return OK;
+ when N_Indexed_Component | N_Selected_Component =>
+ if Statically_Names_Object (N) then
+ return Is_Pure_Barrier (Prefix (N));
+ else
+ return Abandon;
+ end if;
+
+ when N_Case_Expression_Alternative =>
+ -- do not traverse Discrete_Choices subtree
+ if Is_Pure_Barrier (Expression (N)) /= Abandon then
+ return Skip;
+ end if;
+
+ when N_Expression_With_Actions =>
+ -- this may occur in the case of a Count attribute reference
+ if Original_Node (N) /= N
+ and then Is_Pure_Barrier (Original_Node (N)) /= Abandon
+ then
+ return Skip;
+ end if;
+
+ when N_Membership_Test =>
+ if Is_Pure_Barrier (Left_Opnd (N)) /= Abandon
+ and then All_Membership_Choices_Static (N)
+ then
+ return Skip;
end if;
when N_Type_Conversion =>
- -- Conversions to Universal_Integer will not raise constraint
- -- errors.
+ -- Conversions to Universal_Integer do not raise constraint
+ -- errors. Likewise if the expression's type is statically
+ -- compatible with the target's type.
- if Cannot_Raise_Constraint_Error (N)
- or else Etype (N) = Universal_Integer
+ if Etype (N) = Universal_Integer
+ or else Subtypes_Statically_Compatible
+ (Etype (Expression (N)), Etype (N))
then
return OK;
end if;
@@ -6337,6 +6372,12 @@ package body Exp_Ch9 is
return;
end if;
+ -- Prevent cascaded errors
+
+ if Nkind (Cond) = N_Error then
+ return;
+ end if;
+
-- The body of the entry barrier must be analyzed in the context of the
-- protected object, but its scope is external to it, just as any other
-- unprotected version of a protected operation. The specification has
@@ -6366,22 +6407,25 @@ package body Exp_Ch9 is
Analyze_And_Resolve (Cond, Any_Boolean);
end if;
- -- Check Pure_Barriers restriction
+ -- Check Simple_Barriers and Pure_Barriers restrictions.
+ -- Note that it is safe to be calling Check_Restriction from here, even
+ -- though this is part of the expander, since Expand_Entry_Barrier is
+ -- called from Sem_Ch9 even in -gnatc mode.
- if Check_Pure_Barriers (Cond) = Abandon then
- Check_Restriction (Pure_Barriers, Cond);
+ if not Is_Simple_Barrier (Cond) then
+ -- flag restriction violation
+ Check_Restriction (Simple_Barriers, Cond);
end if;
- -- The Ravenscar profile restricts barriers to simple variables declared
- -- within the protected object. We also allow Boolean constants, since
- -- these appear in several published examples and are also allowed by
- -- other compilers.
+ if Check_Pure_Barriers (Cond) = Abandon then
+ -- flag restriction violation
+ Check_Restriction (Pure_Barriers, Cond);
- -- Note that after analysis variables in this context will be replaced
- -- by the corresponding prival, that is to say a renaming of a selected
- -- component of the form _Object.Var. If expansion is disabled, as
- -- within a generic, we check that the entity appears in the current
- -- scope.
+ -- Emit warning if barrier contains global entities and is thus
+ -- potentially unsynchronized (if Pure_Barriers restrictions
+ -- are met then no need to check for this).
+ Check_Unprotected_Barrier (Cond);
+ end if;
if Is_Entity_Name (Cond) then
Cond_Id := Entity (Cond);
@@ -6402,25 +6446,12 @@ package body Exp_Ch9 is
Set_Declarations (Func_Body, Empty_List);
end if;
- if Cond_Id = Standard_False or else Cond_Id = Standard_True then
- return;
-
- elsif Is_Simple_Barrier_Name (Cond) then
- return;
- end if;
+ -- Note that after analysis variables in this context will be
+ -- replaced by the corresponding prival, that is to say a renaming
+ -- of a selected component of the form _Object.Var. If expansion is
+ -- disabled, as within a generic, we check that the entity appears in
+ -- the current scope.
end if;
-
- -- It is not a boolean variable or literal, so check the restriction.
- -- Note that it is safe to be calling Check_Restriction from here, even
- -- though this is part of the expander, since Expand_Entry_Barrier is
- -- called from Sem_Ch9 even in -gnatc mode.
-
- Check_Restriction (Simple_Barriers, Cond);
-
- -- Emit warning if barrier contains global entities and is thus
- -- potentially unsynchronized.
-
- Check_Unprotected_Barrier (Cond);
end Expand_Entry_Barrier;
------------------------------
@@ -6611,6 +6642,16 @@ package body Exp_Ch9 is
Analyze (N);
+ -- Ada 2020 (AI12-0279)
+
+ if Has_Yield_Aspect (Eent)
+ and then RTE_Available (RE_Yield)
+ then
+ Insert_Action_After (N,
+ Make_Procedure_Call_Statement (Loc,
+ New_Occurrence_Of (RTE (RE_Yield), Loc)));
+ end if;
+
-- Discard Entry_Address that was created for it, so it will not be
-- emitted if this accept statement is in the statement part of a
-- delay alternative.
@@ -6647,6 +6688,7 @@ package body Exp_Ch9 is
-- must be properly set.
Set_Parent (Block, Parent (N));
+ Set_Parent (Blkent, Block);
-- Prepend call to Accept_Call to main statement sequence If the
-- accept has exception handlers, the statement sequence is wrapped
@@ -7084,8 +7126,8 @@ package body Exp_Ch9 is
if Nkind (Ecall) = N_Block_Statement then
Ecall := First (Statements (Handled_Statement_Sequence (Ecall)));
- while not Nkind_In (Ecall, N_Procedure_Call_Statement,
- N_Entry_Call_Statement)
+ while Nkind (Ecall) not in
+ N_Procedure_Call_Statement | N_Entry_Call_Statement
loop
Next (Ecall);
end loop;
@@ -7098,9 +7140,8 @@ package body Exp_Ch9 is
if Ada_Version >= Ada_2005
and then
(No (Original_Node (Ecall))
- or else not Nkind_In (Original_Node (Ecall),
- N_Delay_Relative_Statement,
- N_Delay_Until_Statement))
+ or else Nkind (Original_Node (Ecall)) not in
+ N_Delay_Relative_Statement | N_Delay_Until_Statement)
then
Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals);
@@ -8089,7 +8130,7 @@ package body Exp_Ch9 is
-- <else-statements>
-- end if;
- N_Stats := New_Copy_List_Tree (Statements (Alt));
+ N_Stats := New_Copy_Separate_List (Statements (Alt));
Prepend_To (N_Stats,
Make_Implicit_If_Statement (N,
@@ -8133,7 +8174,7 @@ package body Exp_Ch9 is
-- <dispatching-call>;
-- <triggering-statements>
- Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt));
+ Lim_Typ_Stmts := New_Copy_Separate_List (Statements (Alt));
Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk));
-- Generate:
@@ -8599,6 +8640,7 @@ package body Exp_Ch9 is
Disp_Op_Body : Node_Id;
New_Op_Body : Node_Id;
Op_Body : Node_Id;
+ Op_Decl : Node_Id;
Op_Id : Entity_Id;
function Build_Dispatching_Subprogram_Body
@@ -8735,51 +8777,68 @@ package body Exp_Ch9 is
Current_Node := New_Op_Body;
Analyze (New_Op_Body);
- -- Build the corresponding protected operation. It may
- -- appear that this is needed only if this is a visible
- -- operation of the type, or if it is an interrupt handler,
- -- and this was the strategy used previously in GNAT.
-
- -- However, the operation may be exported through a 'Access
- -- to an external caller. This is the common idiom in code
- -- that uses the Ada 2005 Timing_Events package. As a result
- -- we need to produce the protected body for both visible
- -- and private operations, as well as operations that only
- -- have a body in the source, and for which we create a
- -- declaration in the protected body itself.
-
- if Present (Corresponding_Spec (Op_Body)) then
- if Lock_Free_Active then
- New_Op_Body :=
- Build_Lock_Free_Protected_Subprogram_Body
- (Op_Body, Pid, Specification (New_Op_Body));
- else
- New_Op_Body :=
- Build_Protected_Subprogram_Body
- (Op_Body, Pid, Specification (New_Op_Body));
- end if;
-
- Insert_After (Current_Node, New_Op_Body);
- Analyze (New_Op_Body);
-
- Current_Node := New_Op_Body;
-
- -- Generate an overriding primitive operation body for
- -- this subprogram if the protected type implements an
- -- interface.
+ -- When the original protected body has nested subprograms,
+ -- the new body also has them, so set the flag accordingly
+ -- and reset the scopes of the top-level nested subprograms
+ -- and other declaration entities so that they now refer to
+ -- the new body's entity. (It would preferable to do this
+ -- within Build_Protected_Sub_Specification, which is called
+ -- from Build_Unprotected_Subprogram_Body, but the needed
+ -- subprogram entity isn't available via Corresponding_Spec
+ -- until after the above Analyze call.)
+
+ if Has_Nested_Subprogram (Corresponding_Spec (Op_Body)) then
+ Set_Has_Nested_Subprogram
+ (Corresponding_Spec (New_Op_Body));
+
+ Reset_Scopes_To
+ (New_Op_Body, Corresponding_Spec (New_Op_Body));
+ end if;
- if Ada_Version >= Ada_2005
- and then
- Present (Interfaces (Corresponding_Record_Type (Pid)))
- then
- Disp_Op_Body :=
- Build_Dispatching_Subprogram_Body
- (Op_Body, Pid, New_Op_Body);
+ -- Build the corresponding protected operation. This is
+ -- needed only if this is a public or private operation of
+ -- the type.
- Insert_After (Current_Node, Disp_Op_Body);
- Analyze (Disp_Op_Body);
+ -- Why do we need to test for Corresponding_Spec being
+ -- present here when it's assumed to be set further above
+ -- in the Is_Eliminated test???
- Current_Node := Disp_Op_Body;
+ if Present (Corresponding_Spec (Op_Body)) then
+ Op_Decl :=
+ Unit_Declaration_Node (Corresponding_Spec (Op_Body));
+
+ if Nkind (Parent (Op_Decl)) = N_Protected_Definition then
+ if Lock_Free_Active then
+ New_Op_Body :=
+ Build_Lock_Free_Protected_Subprogram_Body
+ (Op_Body, Pid, Specification (New_Op_Body));
+ else
+ New_Op_Body :=
+ Build_Protected_Subprogram_Body (
+ Op_Body, Pid, Specification (New_Op_Body));
+ end if;
+
+ Insert_After (Current_Node, New_Op_Body);
+ Analyze (New_Op_Body);
+ Current_Node := New_Op_Body;
+
+ -- Generate an overriding primitive operation body for
+ -- this subprogram if the protected type implements
+ -- an interface.
+
+ if Ada_Version >= Ada_2005
+ and then Present (Interfaces (
+ Corresponding_Record_Type (Pid)))
+ then
+ Disp_Op_Body :=
+ Build_Dispatching_Subprogram_Body (
+ Op_Body, Pid, New_Op_Body);
+
+ Insert_After (Current_Node, Disp_Op_Body);
+ Analyze (Disp_Op_Body);
+
+ Current_Node := Disp_Op_Body;
+ end if;
end if;
end if;
end if;
@@ -10044,8 +10103,7 @@ package body Exp_Ch9 is
Acc_Ent := N;
while Present (Acc_Ent)
- and then not Nkind_In (Acc_Ent, N_Accept_Statement,
- N_Entry_Body)
+ and then Nkind (Acc_Ent) not in N_Accept_Statement | N_Entry_Body
loop
Acc_Ent := Parent (Acc_Ent);
end loop;
@@ -10209,8 +10267,7 @@ package body Exp_Ch9 is
declare
Elmt : Elmt_Id;
- Op : Entity_Id;
- pragma Warnings (Off, Op);
+ Op : Entity_Id := Empty;
begin
Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ)));
@@ -10220,6 +10277,8 @@ package body Exp_Ch9 is
Next_Elmt (Elmt);
end loop;
+ pragma Assert (Present (Op));
+
return
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Op, Loc),
@@ -10497,16 +10556,6 @@ package body Exp_Ch9 is
Extract_Entry (N, Concval, Ename, Index);
Conc_Typ := Etype (Concval);
- -- If the prefix is an access to class-wide type, dereference to get
- -- object and entry type.
-
- if Is_Access_Type (Conc_Typ) then
- Conc_Typ := Designated_Type (Conc_Typ);
- Rewrite (Concval,
- Make_Explicit_Dereference (Loc, Relocate_Node (Concval)));
- Analyze_And_Resolve (Concval, Conc_Typ);
- end if;
-
-- Examine the scope stack in order to find nearest enclosing protected
-- or task type. This will constitute our invocation source.
@@ -10630,7 +10679,7 @@ package body Exp_Ch9 is
Num_Alts : Nat;
Num_Accept : Nat := 0;
Proc : Node_Id;
- Time_Type : Entity_Id;
+ Time_Type : Entity_Id := Empty;
Select_Call : Node_Id;
Qnam : constant Entity_Id :=
@@ -10918,7 +10967,23 @@ package body Exp_Ch9 is
-- Accept with no body (followed by trailing statements)
else
- Alt_Stats := Empty_List;
+ declare
+ Entry_Id : constant Entity_Id :=
+ Entity (Entry_Direct_Name (Accept_Statement (Alt)));
+ begin
+ -- Ada 2020 (AI12-0279)
+
+ if Has_Yield_Aspect (Entry_Id)
+ and then RTE_Available (RE_Yield)
+ then
+ Alt_Stats :=
+ New_List (
+ Make_Procedure_Call_Statement (Sloc (Proc),
+ New_Occurrence_Of (RTE (RE_Yield), Sloc (Proc))));
+ else
+ Alt_Stats := Empty_List;
+ end if;
+ end;
end if;
Ensure_Statement_Present (Sloc (Astmt), Alt);
@@ -11132,6 +11197,7 @@ package body Exp_Ch9 is
then
null;
else
+ -- Move this check to sem???
Error_Msg_NE (
"& is not a time type (RM 9.6(6))",
Expression (Delay_Statement (Alt)), Time_Type);
@@ -11251,6 +11317,8 @@ package body Exp_Ch9 is
Delay_Min :=
Make_Defining_Identifier (Loc, New_External_Name ('D', 3));
+ pragma Assert (Present (Time_Type));
+
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Delay_Val,
@@ -12449,7 +12517,7 @@ package body Exp_Ch9 is
begin
Ent := First_Entity (Tasktyp);
while Present (Ent) loop
- if Ekind_In (Ent, E_Entry, E_Entry_Family) then
+ if Ekind (Ent) in E_Entry | E_Entry_Family then
Build_Contract_Wrapper (Ent, N);
end if;
@@ -12572,8 +12640,6 @@ package body Exp_Ch9 is
-- global references if within an instantiation.
procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
-
Actuals : List_Id;
Blk_Typ : Entity_Id;
Call : Node_Id;
@@ -12596,6 +12662,7 @@ package body Exp_Ch9 is
Index : Node_Id;
Is_Disp_Select : Boolean;
Lim_Typ_Stmts : List_Id;
+ Loc : constant Source_Ptr := Sloc (D_Stat);
N_Stats : List_Id;
Obj : Entity_Id;
Param : Node_Id;
@@ -12640,8 +12707,8 @@ package body Exp_Ch9 is
if Nkind (E_Call) = N_Block_Statement then
E_Call := First (Statements (Handled_Statement_Sequence (E_Call)));
- while not Nkind_In (E_Call, N_Procedure_Call_Statement,
- N_Entry_Call_Statement)
+ while Nkind (E_Call) not in
+ N_Procedure_Call_Statement | N_Entry_Call_Statement
loop
Next (E_Call);
end loop;
@@ -13344,12 +13411,12 @@ package body Exp_Ch9 is
Context := Parent (N);
while Present (Context) loop
- if Nkind_In (Context, N_Entry_Body,
- N_Extended_Return_Statement,
- N_Package_Body,
- N_Package_Declaration,
- N_Subprogram_Body,
- N_Task_Body)
+ if Nkind (Context) in N_Entry_Body
+ | N_Extended_Return_Statement
+ | N_Package_Body
+ | N_Package_Declaration
+ | N_Subprogram_Body
+ | N_Task_Body
then
exit;
@@ -13400,6 +13467,10 @@ package body Exp_Ch9 is
if Nkind (Context) = N_Block_Statement then
Context_Id := Entity (Identifier (Context));
+ if No (Declarations (Context)) then
+ Set_Declarations (Context, New_List);
+ end if;
+
elsif Nkind (Context) = N_Entry_Body then
Context_Id := Defining_Identifier (Context);
@@ -13448,8 +13519,7 @@ package body Exp_Ch9 is
if Ada_Version >= Ada_2005 then
while Is_Internal (S) loop
if Nkind (Parent (S)) = N_Block_Statement
- and then
- Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement
+ and then Has_Master_Entity (S)
then
exit;
@@ -13475,7 +13545,7 @@ package body Exp_Ch9 is
begin
First_Op := First (D);
while Present (First_Op)
- and then not Nkind_In (First_Op, N_Subprogram_Body, N_Entry_Body)
+ and then Nkind (First_Op) not in N_Subprogram_Body | N_Entry_Body
loop
Next (First_Op);
end loop;
@@ -13953,8 +14023,8 @@ package body Exp_Ch9 is
-- of this type should have been removed during semantic analysis.
Pdec := Parent (Ptyp);
- while not Nkind_In (Pdec, N_Protected_Type_Declaration,
- N_Single_Protected_Declaration)
+ while Nkind (Pdec) not in
+ N_Protected_Type_Declaration | N_Single_Protected_Declaration
loop
Next (Pdec);
end loop;
@@ -14385,8 +14455,8 @@ package body Exp_Ch9 is
-- this type should have been removed during semantic analysis.
Tdec := Parent (Ttyp);
- while not Nkind_In (Tdec, N_Task_Type_Declaration,
- N_Single_Task_Declaration)
+ while Nkind (Tdec) not in
+ N_Task_Type_Declaration | N_Single_Task_Declaration
loop
Next (Tdec);
end loop;
@@ -14735,8 +14805,8 @@ package body Exp_Ch9 is
Next_Op := Next (N);
while Present (Next_Op)
- and then not Nkind_In (Next_Op,
- N_Subprogram_Body, N_Entry_Body, N_Expression_Function)
+ and then Nkind (Next_Op) not in
+ N_Subprogram_Body | N_Entry_Body | N_Expression_Function
loop
Next (Next_Op);
end loop;
@@ -14754,14 +14824,13 @@ package body Exp_Ch9 is
begin
Stmt := First (Stats);
while Nkind (Stmt) /= N_Empty
- and then (Nkind_In (Stmt, N_Null_Statement, N_Label)
+ and then (Nkind (Stmt) in N_Null_Statement | N_Label
or else
(Nkind (Stmt) = N_Pragma
and then
- Nam_In (Pragma_Name_Unmapped (Stmt),
- Name_Unreferenced,
- Name_Unmodified,
- Name_Warnings)))
+ Pragma_Name_Unmapped (Stmt) in Name_Unreferenced
+ | Name_Unmodified
+ | Name_Warnings))
loop
Next (Stmt);
end loop;
diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads
index 1232ef2..59930a6 100644
--- a/gcc/ada/exp_ch9.ads
+++ b/gcc/ada/exp_ch9.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -55,6 +55,12 @@ package Exp_Ch9 is
-- interface, ensure that the designated type has a _master and generate
-- a renaming of the said master to service the access type.
+ function Build_Master_Declaration (Loc : Source_Ptr) return Node_Id;
+ -- For targets supporting tasks, generate:
+ -- _Master : constant Integer := Current_Master.all;
+ -- For targets where tasks or tasking hierarchies are prohibited, generate:
+ -- _Master : constant Master_Id := 3;
+
procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id);
-- Given the name of an object or a type which is either a task, contains
-- tasks or designates tasks, create a _master in the appropriate scope
@@ -72,17 +78,6 @@ package Exp_Ch9 is
-- where _master denotes the task master of the enclosing context. Ins_Nod
-- is used to provide a specific insertion node for the renaming.
- function Build_Private_Protected_Declaration (N : Node_Id) return Entity_Id;
- -- A subprogram body without a previous spec that appears in a protected
- -- body must be expanded separately to create a subprogram declaration
- -- for it, in order to resolve internal calls to it from other protected
- -- operations. It would seem that no locking version of the operation is
- -- needed, but in fact, in Ada 2005 the subprogram may be used in a call-
- -- back, and therefore a protected version of the operation must be
- -- generated as well.
- --
- -- Possibly factor this with Exp_Dist.Copy_Specification ???
-
function Build_Protected_Sub_Specification
(N : Node_Id;
Prot_Typ : Entity_Id;
diff --git a/gcc/ada/exp_code.adb b/gcc/ada/exp_code.adb
index ba150f5..4f4f763 100644
--- a/gcc/ada/exp_code.adb
+++ b/gcc/ada/exp_code.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_code.ads b/gcc/ada/exp_code.ads
index f0b0111..80f6535 100644
--- a/gcc/ada/exp_code.ads
+++ b/gcc/ada/exp_code.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb
index 5f65098..b973fb6 100644
--- a/gcc/ada/exp_dbug.adb
+++ b/gcc/ada/exp_dbug.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -424,7 +424,7 @@ package body Exp_Dbug is
-- anyway, so the renaming entity will be available in
-- debuggers.
- exit when not Ekind_In (Sel_Id, E_Component, E_Discriminant);
+ exit when Ekind (Sel_Id) not in E_Component | E_Discriminant;
First_Bit := Normalized_First_Bit (Sel_Id);
Enable :=
@@ -839,11 +839,11 @@ package body Exp_Dbug is
-- Case of interface name being used
- if Ekind_In (E, E_Constant,
- E_Exception,
- E_Function,
- E_Procedure,
- E_Variable)
+ if Ekind (E) in E_Constant
+ | E_Exception
+ | E_Function
+ | E_Procedure
+ | E_Variable
and then Present (Interface_Name (E))
and then No (Address_Clause (E))
and then not Has_Suffix
@@ -874,7 +874,7 @@ package body Exp_Dbug is
if Is_Generic_Instance (E)
and then Is_Subprogram (E)
and then not Is_Compilation_Unit (Scope (E))
- and then Ekind_In (Scope (E), E_Package, E_Package_Body)
+ and then Ekind (Scope (E)) in E_Package | E_Package_Body
and then Present (Related_Instance (Scope (E)))
then
E := Related_Instance (Scope (E));
diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads
index f2e2e60..1461f6d 100644
--- a/gcc/ada/exp_dbug.ads
+++ b/gcc/ada/exp_dbug.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 4663a08..1a41d79 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -389,8 +389,8 @@ package body Exp_Disp is
-- Handle full type declarations and derivations of library level
-- tagged types
- elsif Nkind_In (D, N_Full_Type_Declaration,
- N_Derived_Type_Definition)
+ elsif Nkind (D) in
+ N_Full_Type_Declaration | N_Derived_Type_Definition
and then Is_Library_Level_Tagged_Type (Defining_Entity (D))
and then Ekind (Defining_Entity (D)) /= E_Record_Subtype
and then not Is_Private_Type (Defining_Entity (D))
@@ -643,28 +643,31 @@ package body Exp_Disp is
elsif TSS_Name = TSS_Deep_Finalize then
return Uint_9;
+ elsif TSS_Name = TSS_Put_Image then
+ return Uint_10;
+
-- In VM targets unconditionally allow obtaining the position associated
-- with predefined interface primitives since in these platforms any
-- tagged type has these primitives.
elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then
if Chars (E) = Name_uDisp_Asynchronous_Select then
- return Uint_10;
+ return Uint_11;
elsif Chars (E) = Name_uDisp_Conditional_Select then
- return Uint_11;
+ return Uint_12;
elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
- return Uint_12;
+ return Uint_13;
elsif Chars (E) = Name_uDisp_Get_Task_Id then
- return Uint_13;
+ return Uint_14;
elsif Chars (E) = Name_uDisp_Requeue then
- return Uint_14;
+ return Uint_15;
elsif Chars (E) = Name_uDisp_Timed_Select then
- return Uint_15;
+ return Uint_16;
end if;
end if;
@@ -1020,9 +1023,9 @@ package body Exp_Disp is
-- list including the creation of a new set of matching entities.
declare
- Old_Formal : Entity_Id := First_Formal (Subp);
- New_Formal : Entity_Id;
- Extra : Entity_Id := Empty;
+ Old_Formal : Entity_Id := First_Formal (Subp);
+ New_Formal : Entity_Id;
+ Last_Formal : Entity_Id := Empty;
begin
if Present (Old_Formal) then
@@ -1046,7 +1049,7 @@ package body Exp_Disp is
-- errors when the itype is the completion of a type derived
-- from a private type.
- Extra := New_Formal;
+ Last_Formal := New_Formal;
Next_Formal (Old_Formal);
exit when No (Old_Formal);
@@ -1056,17 +1059,56 @@ package body Exp_Disp is
end loop;
Unlink_Next_Entity (New_Formal);
- Set_Last_Entity (Subp_Typ, Extra);
+ Set_Last_Entity (Subp_Typ, Last_Formal);
end if;
-- Now that the explicit formals have been duplicated, any extra
- -- formals needed by the subprogram must be created.
+ -- formals needed by the subprogram must be duplicated; we know
+ -- that extra formals are available because they were added when
+ -- the tagged type was frozen (see Expand_Freeze_Record_Type).
- if Present (Extra) then
- Set_Extra_Formal (Extra, Empty);
- end if;
+ pragma Assert (Is_Frozen (Typ));
- Create_Extra_Formals (Subp_Typ);
+ -- Warning: The addition of the extra formals cannot be performed
+ -- here invoking Create_Extra_Formals since we must ensure that all
+ -- the extra formals of the pointer type and the target subprogram
+ -- match (and for functions that return a tagged type the profile of
+ -- the built subprogram type always returns a class-wide type, which
+ -- may affect the addition of some extra formals).
+
+ if Present (Last_Formal)
+ and then Present (Extra_Formal (Last_Formal))
+ then
+ Old_Formal := Extra_Formal (Last_Formal);
+ New_Formal := New_Copy (Old_Formal);
+ Set_Scope (New_Formal, Subp_Typ);
+
+ Set_Extra_Formal (Last_Formal, New_Formal);
+ Set_Extra_Formals (Subp_Typ, New_Formal);
+
+ if Ekind (Subp) = E_Function
+ and then Present (Extra_Accessibility_Of_Result (Subp))
+ and then Extra_Accessibility_Of_Result (Subp) = Old_Formal
+ then
+ Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal);
+ end if;
+
+ Old_Formal := Extra_Formal (Old_Formal);
+ while Present (Old_Formal) loop
+ Set_Extra_Formal (New_Formal, New_Copy (Old_Formal));
+ New_Formal := Extra_Formal (New_Formal);
+ Set_Scope (New_Formal, Subp_Typ);
+
+ if Ekind (Subp) = E_Function
+ and then Present (Extra_Accessibility_Of_Result (Subp))
+ and then Extra_Accessibility_Of_Result (Subp) = Old_Formal
+ then
+ Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal);
+ end if;
+
+ Old_Formal := Extra_Formal (Old_Formal);
+ end loop;
+ end if;
end;
-- Complete description of pointer type, including size information, as
@@ -1111,6 +1153,14 @@ package body Exp_Disp is
then
Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
+ elsif Is_Access_Type (Ctrl_Typ) then
+ Controlling_Tag :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Explicit_Dereference (Loc,
+ Duplicate_Subexpr_Move_Checks (Ctrl_Arg)),
+ Selector_Name => New_Occurrence_Of (DTC_Entity (Subp), Loc));
+
else
Controlling_Tag :=
Make_Selected_Component (Loc,
@@ -1173,9 +1223,8 @@ package body Exp_Disp is
-- the corresponding object or parameter declaration
elsif Nkind (Controlling_Tag) = N_Identifier
- and then Nkind_In (Parent (Entity (Controlling_Tag)),
- N_Object_Declaration,
- N_Parameter_Specification)
+ and then Nkind (Parent (Entity (Controlling_Tag))) in
+ N_Object_Declaration | N_Parameter_Specification
then
Set_SCIL_Controlling_Tag (SCIL_Node,
Parent (Entity (Controlling_Tag)));
@@ -1185,9 +1234,8 @@ package body Exp_Disp is
elsif Nkind (Controlling_Tag) = N_Explicit_Dereference
and then Nkind (Prefix (Controlling_Tag)) = N_Identifier
- and then Nkind_In (Parent (Entity (Prefix (Controlling_Tag))),
- N_Object_Declaration,
- N_Parameter_Specification)
+ and then Nkind (Parent (Entity (Prefix (Controlling_Tag)))) in
+ N_Object_Declaration | N_Parameter_Specification
then
Set_SCIL_Controlling_Tag (SCIL_Node,
Parent (Entity (Prefix (Controlling_Tag))));
@@ -2134,6 +2182,11 @@ package body Exp_Disp is
end loop;
Thunk_Id := Make_Temporary (Loc, 'T');
+
+ -- Note: any change to this symbol name needs to be coordinated
+ -- with GNATcoverage, as that tool relies on it to identify
+ -- thunks and exclude them from source coverage analysis.
+
Set_Ekind (Thunk_Id, Ekind (Prim));
Set_Is_Thunk (Thunk_Id);
Set_Convention (Thunk_Id, Convention (Prim));
@@ -3828,6 +3881,7 @@ package body Exp_Disp is
-- tagged type, when one of its primitive operations has a type in its
-- profile whose full view has not been analyzed yet. More complex cases
-- involve composite types that have one private unfrozen subcomponent.
+ -- Move this check to sem???
procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
-- Export the dispatch table DT of tagged type Typ. Required to generate
@@ -4301,6 +4355,7 @@ package body Exp_Disp is
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => OSD,
+ Constant_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
@@ -4338,7 +4393,7 @@ package body Exp_Disp is
Attribute_Name => Name_Alignment)));
-- In secondary dispatch tables the Typeinfo component contains
- -- the address of the Object Specific Data (see a-tags.ads)
+ -- the address of the Object Specific Data (see a-tags.ads).
Append_To (DT_Aggr_List,
Make_Attribute_Reference (Loc,
@@ -4680,16 +4735,16 @@ package body Exp_Disp is
end if;
-- Ensure that the value of Max_Predef_Prims defined in a-tags is
- -- correct. Valid values are 9 under configurable runtime or 15
+ -- correct. Valid values are 10 under configurable runtime or 16
-- with full runtime.
if RTE_Available (RE_Interface_Data) then
- if Max_Predef_Prims /= 15 then
+ if Max_Predef_Prims /= 16 then
Error_Msg_N ("run-time library configuration error", Typ);
goto Leave;
end if;
else
- if Max_Predef_Prims /= 9 then
+ if Max_Predef_Prims /= 10 then
Error_Msg_N ("run-time library configuration error", Typ);
Error_Msg_CRT ("tagged types", Typ);
goto Leave;
@@ -8142,6 +8197,7 @@ package body Exp_Disp is
-- We exclude Input and Output stream operations because
-- Limited_Controlled inherits useless Input and Output stream
-- operations from Root_Controlled, which can never be overridden.
+ -- Move this check to sem???
if not Is_TSS (Prim, TSS_Stream_Input)
and then
@@ -8504,7 +8560,7 @@ package body Exp_Disp is
-- Propagate the value to the wrapped subprogram (if one is present)
- if Ekind_In (Prim, E_Function, E_Procedure)
+ if Ekind (Prim) in E_Function | E_Procedure
and then Is_Primitive_Wrapper (Prim)
and then Present (Wrapped_Entity (Prim))
and then Is_Dispatching_Operation (Wrapped_Entity (Prim))
@@ -8537,7 +8593,7 @@ package body Exp_Disp is
-- Propagate the value to the wrapped subprogram (if one is present)
- if Ekind_In (Prim, E_Function, E_Procedure)
+ if Ekind (Prim) in E_Function | E_Procedure
and then Is_Primitive_Wrapper (Prim)
and then Present (Wrapped_Entity (Prim))
and then Is_Dispatching_Operation (Wrapped_Entity (Prim))
@@ -8674,7 +8730,7 @@ package body Exp_Disp is
-- If the DTC_Entity attribute is already set we can also output
-- the name of the interface covered by this primitive (if any).
- if Ekind_In (Alias (Prim), E_Function, E_Procedure)
+ if Ekind (Alias (Prim)) in E_Function | E_Procedure
and then Present (DTC_Entity (Alias (Prim)))
and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
then
diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads
index 5c490df..fb1de72 100644
--- a/gcc/ada/exp_disp.ads
+++ b/gcc/ada/exp_disp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -77,37 +77,40 @@ package Exp_Disp is
-- TSS_Deep_Finalize (9) - implementation of the finalization
-- operation Finalize for any non-limited tagged type.
- -- _Disp_Asynchronous_Select (10) - used in the expansion of ATC with
+ -- Put_Image (10) - implementation of Put_Image attribute for any
+ -- tagged type.
+
+ -- _Disp_Asynchronous_Select (11) - used in the expansion of ATC with
-- dispatching triggers. Null implementation for limited interfaces,
-- full body generation for types that implement limited interfaces,
-- not generated for the rest of the cases. See Expand_N_Asynchronous_
-- Select in Exp_Ch9 for more information.
- -- _Disp_Conditional_Select (11) - used in the expansion of conditional
+ -- _Disp_Conditional_Select (12) - used in the expansion of conditional
-- selects with dispatching triggers. Null implementation for limited
-- interfaces, full body generation for types that implement limited
-- interfaces, not generated for the rest of the cases. See Expand_N_
-- Conditional_Entry_Call in Exp_Ch9 for more information.
- -- _Disp_Get_Prim_Op_Kind (12) - helper routine used in the expansion
+ -- _Disp_Get_Prim_Op_Kind (13) - helper routine used in the expansion
-- of ATC with dispatching triggers. Null implementation for limited
-- interfaces, full body generation for types that implement limited
-- interfaces, not generated for the rest of the cases.
- -- _Disp_Get_Task_Id (13) - helper routine used in the expansion of
+ -- _Disp_Get_Task_Id (14) - helper routine used in the expansion of
-- Abort, attributes 'Callable and 'Terminated for task interface
-- class-wide types. Full body generation for task types, null
-- implementation for limited interfaces, not generated for the rest
-- of the cases. See Expand_N_Attribute_Reference in Exp_Attr and
-- Expand_N_Abort_Statement in Exp_Ch9 for more information.
- -- _Disp_Requeue (14) - used in the expansion of dispatching requeue
+ -- _Disp_Requeue (15) - used in the expansion of dispatching requeue
-- statements. Null implementation is provided for protected, task
-- and synchronized interfaces. Protected and task types implementing
-- concurrent interfaces receive full bodies. See Expand_N_Requeue_
-- Statement in Exp_Ch9 for more information.
- -- _Disp_Timed_Select (15) - used in the expansion of timed selects
+ -- _Disp_Timed_Select (16) - used in the expansion of timed selects
-- with dispatching triggers. Null implementation for limited
-- interfaces, full body generation for types that implement limited
-- interfaces, not generated for the rest of the cases. See Expand_N_
@@ -139,11 +142,13 @@ package Exp_Disp is
-- Update the value of constant Max_Predef_Prims in a-tags.ads to
-- indicate the new number of PPOs.
+ -- Update Exp_Disp.Default_Prim_Op_Position.
+
-- Introduce a new predefined name for the new PPO in Snames.ads and
-- Snames.adb.
-- Categorize the new PPO name as predefined by adding an entry in
- -- Is_Predefined_Dispatching_Operation in Exp_Disp.
+ -- Is_Predefined_Dispatching_Operation in Sem_Util and Exp_Cg.
-- Generate the specification of the new PPO in Make_Predefined_
-- Primitive_Spec in Exp_Ch3.adb. The Is_Internal flag of the defining
@@ -156,17 +161,9 @@ package Exp_Disp is
-- If the new PPO requires a thunk, add an entry in Freeze_Subprogram
-- in Exp_Ch6.adb.
- -- When generating calls to a PPO, use Find_Prim_Op from Exp_Util.ads
+ -- When generating calls to a PPO, use Find_Prim_Op from exp_util.ads
-- to retrieve the entity of the operation directly.
- -- Number of predefined primitive operations added by the Expander
- -- for a tagged type. If more predefined primitive operations are
- -- added, the following items must be changed:
-
- -- Ada.Tags.Max_Predef_Prims - indirect use
- -- Exp_Disp.Default_Prim_Op_Position - indirect use
- -- Exp_Disp.Set_All_DT_Position - direct use
-
procedure Apply_Tag_Checks (Call_Node : Node_Id);
-- Generate checks required on dispatching calls
diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb
index 89218c4..1618fe6 100644
--- a/gcc/ada/exp_dist.adb
+++ b/gcc/ada/exp_dist.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_dist.ads b/gcc/ada/exp_dist.ads
index 84cf810..8951667 100644
--- a/gcc/ada/exp_dist.ads
+++ b/gcc/ada/exp_dist.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb
index badca7d..d956278 100644
--- a/gcc/ada/exp_fixd.adb
+++ b/gcc/ada/exp_fixd.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -56,8 +56,8 @@ package body Exp_Fixd is
-- set the Etype values correctly. In addition, setting the Etype ensures
-- that the analyzer does not try to redetermine the type when the node
-- is analyzed (which would be wrong, since in the case where we set the
- -- Treat_Fixed_As_Integer or Conversion_OK flags, it would think it was
- -- still dealing with a normal fixed-point operation and mess it up).
+ -- Conversion_OK flag, it would think it was still dealing with a normal
+ -- fixed-point operation and mess it up).
function Build_Conversion
(N : Node_Id;
@@ -79,12 +79,13 @@ package body Exp_Fixd is
-- expressions, using the source location from Sloc (N). The operands are
-- either both Universal_Real, in which case Build_Divide differs from
-- Make_Op_Divide only in that the Etype of the resulting node is set (to
- -- Universal_Real), or they can be integer types. In this case the integer
- -- types need not be the same, and Build_Divide converts the operand with
- -- the smaller sized type to match the type of the other operand and sets
- -- this as the result type. The Rounded_Result flag of the result in this
- -- case is set from the Rounded_Result flag of node N. On return, the
- -- resulting node is analyzed, and has its Etype set.
+ -- Universal_Real), or they can be integer or fixed-point types. In this
+ -- case the types need not be the same, and Build_Divide chooses a type
+ -- long enough to hold both operands (i.e. the size of the longer of the
+ -- two operand types), and both operands are converted to this type. The
+ -- Etype of the result is also set to this value. The Rounded_Result flag
+ -- of the result in this case is set from the Rounded_Result flag of node
+ -- N. On return, the resulting node is analyzed and has its Etype set.
function Build_Double_Divide
(N : Node_Id;
@@ -111,13 +112,13 @@ package body Exp_Fixd is
-- expressions, using the source location from Sloc (N). The operands are
-- either both Universal_Real, in which case Build_Multiply differs from
-- Make_Op_Multiply only in that the Etype of the resulting node is set (to
- -- Universal_Real), or they can be integer types. In this case the integer
- -- types need not be the same, and Build_Multiply chooses a type long
- -- enough to hold the product (i.e. twice the size of the longer of the two
- -- operand types), and both operands are converted to this type. The Etype
- -- of the result is also set to this value. However, the result can never
- -- overflow Integer_64, so this is the largest type that is ever generated.
- -- On return, the resulting node is analyzed and has its Etype set.
+ -- Universal_Real), or they can be integer or fixed-point types. In this
+ -- case the types need not be the same, and Build_Multiply chooses a type
+ -- long enough to hold the product (i.e. twice the size of the longer of
+ -- the two operand types), and both operands are converted to this type.
+ -- The Etype of the result is also set to this value. However, the result
+ -- can never overflow Integer_64, so this is the largest type that is ever
+ -- generated. On return, the resulting node is analyzed and has Etype set.
function Build_Rem (N : Node_Id; L, R : Node_Id) return Node_Id;
-- Builds an N_Op_Rem node from the given left and right operand
@@ -261,7 +262,8 @@ package body Exp_Fixd is
-- Remove inner conversion if both inner and outer conversions are
-- to integer types, since the inner one serves no purpose (except
-- perhaps to set rounding, so we preserve the Rounded_Result flag)
- -- and also we preserve the range check flag on the inner operand
+ -- and also preserve the Conversion_OK and Do_Range_Check flags of
+ -- the inner conversion.
if Is_Integer_Type (Typ)
and then Is_Integer_Type (Etype (Expr))
@@ -272,6 +274,7 @@ package body Exp_Fixd is
Subtype_Mark => New_Occurrence_Of (Typ, Loc),
Expression => Expression (Expr));
Set_Rounded_Result (Result, Rounded_Result_Set (Expr));
+ Set_Conversion_OK (Result, Conversion_OK (Expr));
Rcheck := Rcheck or Do_Range_Check (Expr);
-- For all other cases, a simple type conversion will work
@@ -317,6 +320,9 @@ package body Exp_Fixd is
Loc : constant Source_Ptr := Sloc (N);
Left_Type : constant Entity_Id := Base_Type (Etype (L));
Right_Type : constant Entity_Id := Base_Type (Etype (R));
+ Left_Size : Int;
+ Right_Size : Int;
+ Rsize : Int;
Result_Type : Entity_Id;
Rnode : Node_Id;
@@ -341,33 +347,61 @@ package body Exp_Fixd is
return L;
end if;
- -- If left and right types are the same, no conversion needed
+ -- First figure out the effective sizes of the operands. Normally
+ -- the effective size of an operand is the RM_Size of the operand.
+ -- But a special case arises with operands whose size is known at
+ -- compile time. In this case, we can use the actual value of the
+ -- operand to get its size if it would fit signed in 8 or 16 bits.
+
+ Left_Size := UI_To_Int (RM_Size (Left_Type));
+
+ if Compile_Time_Known_Value (L) then
+ declare
+ Val : constant Uint := Expr_Value (L);
+ begin
+ if Val < Int'(2 ** 7) then
+ Left_Size := 8;
+ elsif Val < Int'(2 ** 15) then
+ Left_Size := 16;
+ end if;
+ end;
+ end if;
+
+ Right_Size := UI_To_Int (RM_Size (Right_Type));
+
+ if Compile_Time_Known_Value (R) then
+ declare
+ Val : constant Uint := Expr_Value (R);
+ begin
+ if Val <= Int'(2 ** 7) then
+ Right_Size := 8;
+ elsif Val <= Int'(2 ** 15) then
+ Right_Size := 16;
+ end if;
+ end;
+ end if;
+
+ -- Do the operation using the longer of the two sizes
- if Left_Type = Right_Type then
- Result_Type := Left_Type;
- Rnode :=
- Make_Op_Divide (Loc,
- Left_Opnd => L,
- Right_Opnd => R);
+ Rsize := Int'Max (Left_Size, Right_Size);
- -- Use left type if it is the larger of the two
+ if Rsize <= 8 then
+ Result_Type := Standard_Integer_8;
- elsif Esize (Left_Type) >= Esize (Right_Type) then
- Result_Type := Left_Type;
- Rnode :=
- Make_Op_Divide (Loc,
- Left_Opnd => L,
- Right_Opnd => Build_Conversion (N, Left_Type, R));
+ elsif Rsize <= 16 then
+ Result_Type := Standard_Integer_16;
- -- Otherwise right type is larger of the two, us it
+ elsif Rsize <= 32 then
+ Result_Type := Standard_Integer_32;
else
- Result_Type := Right_Type;
- Rnode :=
- Make_Op_Divide (Loc,
- Left_Opnd => Build_Conversion (N, Right_Type, L),
- Right_Opnd => R);
+ Result_Type := Standard_Integer_64;
end if;
+
+ Rnode :=
+ Make_Op_Divide (Loc,
+ Left_Opnd => Build_Conversion (N, Result_Type, L),
+ Right_Opnd => Build_Conversion (N, Result_Type, R));
end if;
-- We now have a divide node built with Result_Type set. First
@@ -375,14 +409,6 @@ package body Exp_Fixd is
Set_Etype (Rnode, Base_Type (Result_Type));
- -- Set Treat_Fixed_As_Integer if operation on fixed-point type
- -- since this is a literal arithmetic operation, to be performed
- -- by Gigi without any consideration of small values.
-
- if Is_Fixed_Point_Type (Result_Type) then
- Set_Treat_Fixed_As_Integer (Rnode);
- end if;
-
-- The result is rounded if the target of the operation is decimal
-- and Rounded_Result is set, or if the target of the operation
-- is an integer type.
@@ -393,6 +419,17 @@ package body Exp_Fixd is
Set_Rounded_Result (Rnode);
end if;
+ -- One more check. We did the divide operation using the longer of
+ -- the two sizes, which is reasonable. However, in the case where the
+ -- two types have unequal sizes, it is impossible for the result of
+ -- a divide operation to be larger than the dividend, so we can put
+ -- a conversion round the result to keep the evolving operation size
+ -- as small as possible.
+
+ if not Is_Floating_Point_Type (Left_Type) then
+ Rnode := Build_Conversion (N, Left_Type, Rnode);
+ end if;
+
return Rnode;
end Build_Divide;
@@ -696,14 +733,6 @@ package body Exp_Fixd is
Set_Etype (Rnode, Base_Type (Result_Type));
- -- Set Treat_Fixed_As_Integer if operation on fixed-point type
- -- since this is a literal arithmetic operation, to be performed
- -- by Gigi without any consideration of small values.
-
- if Is_Fixed_Point_Type (Result_Type) then
- Set_Treat_Fixed_As_Integer (Rnode);
- end if;
-
return Rnode;
end Build_Multiply;
@@ -752,14 +781,6 @@ package body Exp_Fixd is
Set_Etype (Rnode, Base_Type (Result_Type));
- -- Set Treat_Fixed_As_Integer if operation on fixed-point type
- -- since this is a literal arithmetic operation, to be performed
- -- by Gigi without any consideration of small values.
-
- if Is_Fixed_Point_Type (Result_Type) then
- Set_Treat_Fixed_As_Integer (Rnode);
- end if;
-
-- One more check. We did the rem operation using the larger of the
-- two types, which is reasonable. However, in the case where the
-- two types have unequal sizes, it is impossible for the result of
@@ -2387,9 +2408,7 @@ package body Exp_Fixd is
-- We really need to set Analyzed here because we may be creating a
-- very strange beast, namely an integer literal typed as fixed-point
- -- and the analyzer won't like that. Probably we should allow the
- -- Treat_Fixed_As_Integer flag to appear on integer literal nodes
- -- and teach the analyzer how to handle them ???
+ -- and the analyzer won't like that.
Set_Analyzed (L);
return L;
diff --git a/gcc/ada/exp_fixd.ads b/gcc/ada/exp_fixd.ads
index 9f34467..bebba8e 100644
--- a/gcc/ada/exp_fixd.ads
+++ b/gcc/ada/exp_fixd.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index a47de2f..41e4b1b 100644
--- a/gcc/ada/exp_imgv.adb
+++ b/gcc/ada/exp_imgv.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,6 +27,7 @@ with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks;
with Einfo; use Einfo;
+with Exp_Put_Image;
with Exp_Util; use Exp_Util;
with Lib; use Lib;
with Namet; use Namet;
@@ -58,7 +59,7 @@ package body Exp_Imgv is
Pref : Entity_Id;
Attr_Name : Name_Id;
Str_Typ : Entity_Id);
- -- AI12-00124: Rewrite attribute 'Image when it is applied to an object
+ -- AI12-0124: Rewrite attribute 'Image when it is applied to an object
-- reference as an attribute applied to a type. N denotes the node to be
-- rewritten, Pref denotes the prefix of the 'Image attribute, and Name
-- and Str_Typ specify which specific string type and 'Image attribute to
@@ -263,7 +264,7 @@ package body Exp_Imgv is
-- tv = Long_Long_Integer?(Expr) [convert with no scaling]
-- pm = typ'Scale (typ = subtype of expression)
- -- For enumeration types other than those declared packages Standard
+ -- For enumeration types other than those declared in package Standard
-- or System, Snn, Pnn, are expanded as above, but the call looks like:
-- Image_Enumeration_NN (rt'Pos (X), Snn, Pnn, typS, typI'Address)
@@ -474,23 +475,32 @@ package body Exp_Imgv is
if Is_Object_Image (Pref) then
Rewrite_Object_Image (N, Pref, Name_Image, Standard_String);
return;
+ end if;
+
+ Ptyp := Entity (Pref);
+
+ -- Ada 2020 allows 'Image on private types, so we need to fetch the
+ -- underlying type.
+
+ if Ada_Version >= Ada_2020 then
+ Rtyp := Underlying_Type (Root_Type (Ptyp));
+ else
+ Rtyp := Root_Type (Ptyp);
+ end if;
-- Enable speed-optimized expansion of user-defined enumeration types
-- if we are compiling with optimizations enabled and enumeration type
-- literals are generated. Otherwise the call will be expanded into a
-- call to the runtime library.
- elsif Optimization_Level > 0
+ if Optimization_Level > 0
and then not Global_Discard_Names
- and then Is_User_Defined_Enumeration_Type (Root_Type (Entity (Pref)))
+ and then Is_User_Defined_Enumeration_Type (Rtyp)
then
Expand_User_Defined_Enumeration_Image;
return;
end if;
- Ptyp := Entity (Pref);
- Rtyp := Root_Type (Ptyp);
-
-- Build declarations of Snn and Pnn to be inserted
Ins_List := New_List (
@@ -523,7 +533,15 @@ package body Exp_Imgv is
Enum_Case := False;
- if Rtyp = Standard_Boolean then
+ -- If this is a case where Image should be transformed using Put_Image,
+ -- then do so. See Exp_Put_Image for details.
+
+ if Exp_Put_Image.Image_Should_Call_Put_Image (N) then
+ Rewrite (N, Exp_Put_Image.Build_Image_Call (N));
+ Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
+ return;
+
+ elsif Rtyp = Standard_Boolean then
Imid := RE_Image_Boolean;
Tent := Rtyp;
@@ -586,8 +604,10 @@ package body Exp_Imgv is
-- Only other possibility is user-defined enumeration type
else
+ pragma Assert (Is_Enumeration_Type (Rtyp));
+
if Discard_Names (First_Subtype (Ptyp))
- or else No (Lit_Strings (Root_Type (Ptyp)))
+ or else No (Lit_Strings (Rtyp))
then
-- When pragma Discard_Names applies to the first subtype, build
-- (Pref'Pos (Expr))'Img.
@@ -633,14 +653,50 @@ package body Exp_Imgv is
-- Build first argument for call
if Enum_Case then
- Arg_List := New_List (
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Pos,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Expressions => New_List (Expr)));
+ declare
+ T : Entity_Id;
+ begin
+ -- In Ada 2020 we need the underlying type here, because 'Image is
+ -- allowed on private types.
+
+ if Ada_Version >= Ada_2020 then
+ T := Rtyp;
+ else
+ T := Ptyp;
+ end if;
+
+ Arg_List := New_List (
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Pos,
+ Prefix => New_Occurrence_Of (T, Loc),
+ Expressions => New_List (Expr)));
+ end;
+
+ -- AI12-0020: Ada 2020 allows 'Image for all types, including private
+ -- types. If the full type is not a fixed-point type, then it is enough
+ -- to set the Conversion_OK flag. However, that would not work for
+ -- fixed-point types, because that flag changes the run-time semantics
+ -- of fixed-point type conversions; therefore, we must first convert to
+ -- Rtyp, and then to Tent.
else
- Arg_List := New_List (Convert_To (Tent, Expr));
+ declare
+ Conv : Node_Id;
+ begin
+ if Ada_Version >= Ada_2020
+ and then Is_Private_Type (Etype (Expr))
+ then
+ if Is_Fixed_Point_Type (Rtyp) then
+ Conv := Convert_To (Tent, OK_Convert_To (Rtyp, Expr));
+ else
+ Conv := OK_Convert_To (Tent, Expr);
+ end if;
+ else
+ Conv := Convert_To (Tent, Expr);
+ end if;
+
+ Arg_List := New_List (Conv);
+ end;
end if;
-- Append Snn, Pnn arguments
@@ -746,7 +802,7 @@ package body Exp_Imgv is
-- btyp (Value_xx (X))
- -- where btyp is he base type of the prefix
+ -- where btyp is the base type of the prefix
-- For types whose root type is Character
-- xx = Character
diff --git a/gcc/ada/exp_imgv.ads b/gcc/ada/exp_imgv.ads
index abb8067..dea323f 100644
--- a/gcc/ada/exp_imgv.ads
+++ b/gcc/ada/exp_imgv.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index 78555bf..04ad92b 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -138,7 +138,7 @@ package body Exp_Intr is
Ent : Entity_Id := Current_Scope;
begin
while Present (Ent) loop
- exit when not Ekind_In (Ent, E_Block, E_Loop);
+ exit when Ekind (Ent) not in E_Block | E_Loop;
Ent := Scope (Ent);
end loop;
@@ -430,28 +430,21 @@ package body Exp_Intr is
-- the tag in the table of ancestor tags.
elsif not Is_Interface (Result_Typ) then
- declare
- Obj_Tag_Node : Node_Id := New_Copy_Tree (Tag_Arg);
- CW_Test_Node : Node_Id;
-
- begin
- Build_CW_Membership (Loc,
- Obj_Tag_Node => Obj_Tag_Node,
- Typ_Tag_Node =>
- New_Occurrence_Of (
- Node (First_Elmt (Access_Disp_Table (
- Root_Type (Result_Typ)))), Loc),
- Related_Nod => N,
- New_Node => CW_Test_Node);
-
- Insert_Action (N,
- Make_Implicit_If_Statement (N,
- Condition =>
- Make_Op_Not (Loc, CW_Test_Node),
- Then_Statements =>
- New_List (Make_Raise_Statement (Loc,
- New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
- end;
+ Insert_Action (N,
+ Make_Implicit_If_Statement (N,
+ Condition =>
+ Make_Op_Not (Loc,
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (RE_CW_Membership), Loc),
+ Parameter_Associations => New_List (
+ New_Copy_Tree (Tag_Arg),
+ New_Occurrence_Of (
+ Node (First_Elmt (Access_Disp_Table (
+ Root_Type (Result_Typ)))), Loc)))),
+ Then_Statements =>
+ New_List (
+ Make_Raise_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
-- Call IW_Membership test if the Result_Type is an abstract interface
-- to look for the tag in the table of interface tags.
@@ -634,9 +627,9 @@ package body Exp_Intr is
elsif Nam = Name_Generic_Dispatching_Constructor then
Expand_Dispatching_Constructor_Call (N);
- elsif Nam_In (Nam, Name_Import_Address,
- Name_Import_Largest_Value,
- Name_Import_Value)
+ elsif Nam in Name_Import_Address
+ | Name_Import_Largest_Value
+ | Name_Import_Value
then
Expand_Import_Call (N);
@@ -670,19 +663,19 @@ package body Exp_Intr is
elsif Nam = Name_To_Pointer then
Expand_To_Pointer (N);
- elsif Nam_In (Nam, Name_File,
- Name_Line,
- Name_Source_Location,
- Name_Enclosing_Entity,
- Name_Compilation_ISO_Date,
- Name_Compilation_Date,
- Name_Compilation_Time)
+ elsif Nam in Name_File
+ | Name_Line
+ | Name_Source_Location
+ | Name_Enclosing_Entity
+ | Name_Compilation_ISO_Date
+ | Name_Compilation_Date
+ | Name_Compilation_Time
then
Expand_Source_Info (N, Nam);
- -- If we have a renaming, expand the call to the original operation,
- -- which must itself be intrinsic, since renaming requires matching
- -- conventions and this has already been checked.
+ -- If we have a renaming, expand the call to the original operation,
+ -- which must itself be intrinsic, since renaming requires matching
+ -- conventions and this has already been checked.
elsif Present (Alias (E)) then
Expand_Intrinsic_Call (N, Alias (E));
@@ -690,10 +683,10 @@ package body Exp_Intr is
elsif Nkind (N) in N_Binary_Op then
Expand_Binary_Operator_Call (N);
- -- The only other case is where an external name was specified, since
- -- this is the only way that an otherwise unrecognized name could
- -- escape the checking in Sem_Prag. Nothing needs to be done in such
- -- a case, since we pass such a call to the back end unchanged.
+ -- The only other case is where an external name was specified, since
+ -- this is the only way that an otherwise unrecognized name could
+ -- escape the checking in Sem_Prag. Nothing needs to be done in such
+ -- a case, since we pass such a call to the back end unchanged.
else
null;
diff --git a/gcc/ada/exp_intr.ads b/gcc/ada/exp_intr.ads
index f564a9d..9399ec7 100644
--- a/gcc/ada/exp_intr.ads
+++ b/gcc/ada/exp_intr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb
index 7dcf241..b95bd32 100644
--- a/gcc/ada/exp_pakd.adb
+++ b/gcc/ada/exp_pakd.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -469,7 +469,7 @@ package body Exp_Pakd is
or else
(Nkind (Aexp) = N_Indexed_Component
and then Is_Entity_Name (Prefix (Aexp)))
- or else Nkind_In (Aexp, N_Explicit_Dereference, N_Function_Call)
+ or else Nkind (Aexp) in N_Explicit_Dereference | N_Function_Call
then
Set_Analyzed (Aexp);
end if;
@@ -501,8 +501,9 @@ package body Exp_Pakd is
-- packed array type. It creates the type and installs it as required.
procedure Set_PB_Type;
- -- Sets PB_Type to Packed_Bytes{1,2,4} as required by the alignment
- -- requirements (see documentation in the spec of this package).
+ -- Set PB_Type to [Rev_]Packed_Bytes{1,2,4} as required by the alignment
+ -- and the scalar storage order requirements (see documentation in the
+ -- spec of this package).
-----------------
-- Install_PAT --
@@ -580,14 +581,6 @@ package body Exp_Pakd is
Set_Is_Volatile_Full_Access (PAT, Is_Volatile_Full_Access (Typ));
Set_Treat_As_Volatile (PAT, Treat_As_Volatile (Typ));
- -- For a non-bit-packed array, propagate reverse storage order
- -- flag from original base type to packed array base type.
-
- if not Is_Bit_Packed_Array (Typ) then
- Set_Reverse_Storage_Order
- (Etype (PAT), Reverse_Storage_Order (Base_Type (Typ)));
- end if;
-
-- We definitely do not want to delay freezing for packed array
-- types. This is of particular importance for the itypes that are
-- generated for record components depending on discriminants where
@@ -616,16 +609,36 @@ package body Exp_Pakd is
or else Alignment (Typ) = 1
or else Component_Alignment (Typ) = Calign_Storage_Unit
then
- PB_Type := RTE (RE_Packed_Bytes1);
+ if Reverse_Storage_Order (Typ) then
+ PB_Type := RTE (RE_Rev_Packed_Bytes1);
+ else
+ PB_Type := RTE (RE_Packed_Bytes1);
+ end if;
elsif Csize mod 4 /= 0
or else Alignment (Typ) = 2
then
- PB_Type := RTE (RE_Packed_Bytes2);
+ if Reverse_Storage_Order (Typ) then
+ PB_Type := RTE (RE_Rev_Packed_Bytes2);
+ else
+ PB_Type := RTE (RE_Packed_Bytes2);
+ end if;
else
- PB_Type := RTE (RE_Packed_Bytes4);
+ if Reverse_Storage_Order (Typ) then
+ PB_Type := RTE (RE_Rev_Packed_Bytes4);
+ else
+ PB_Type := RTE (RE_Packed_Bytes4);
+ end if;
end if;
+
+ -- The Rev_Packed_Bytes{1,2,4} types cannot be directly declared with
+ -- the reverse scalar storage order in System.Unsigned_Types because
+ -- their component type is aliased and the combination would then be
+ -- flagged as illegal by the compiler. Moreover changing the compiler
+ -- would not address the bootstrap path issue with earlier versions.
+
+ Set_Reverse_Storage_Order (PB_Type, Reverse_Storage_Order (Typ));
end Set_PB_Type;
-- Start of processing for Create_Packed_Array_Impl_Type
@@ -797,6 +810,10 @@ package body Exp_Pakd is
end;
Install_PAT;
+
+ -- Propagate the reverse storage order flag to the base type
+
+ Set_Reverse_Storage_Order (Etype (PAT), Reverse_Storage_Order (Typ));
return;
-- Case of bit-packing required for unconstrained array. We create
@@ -1520,12 +1537,12 @@ package body Exp_Pakd is
Get_Base_And_Bit_Offset (Prefix (N), Base, Offset);
Rewrite (N,
- Unchecked_Convert_To (Universal_Integer,
+ Unchecked_Convert_To (Standard_Natural,
Make_Op_Mod (Loc,
Left_Opnd => Offset,
Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit))));
- Analyze_And_Resolve (N, Universal_Integer);
+ Analyze_And_Resolve (N, Standard_Natural);
end Expand_Packed_Bit_Reference;
------------------------------------
diff --git a/gcc/ada/exp_pakd.ads b/gcc/ada/exp_pakd.ads
index cb6197d..33726ba 100644
--- a/gcc/ada/exp_pakd.ads
+++ b/gcc/ada/exp_pakd.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -86,6 +86,15 @@ package Exp_Pakd is
-- Packed_Bytes{1,2,4} type is made on the basis of alignment needs as
-- described above for the unconstrained case.
+ -- When the packed array (sub)type is specified to have the reverse scalar
+ -- storage order, the Packed_Bytes{1,2,4} references above are replaced
+ -- with Rev_Packed_Bytes{1,2,4}. This is necessary because, although the
+ -- component type is Packed_Byte and therefore endian neutral, the scalar
+ -- storage order of the new type must be compatible with that of an outer
+ -- composite type, if this composite type contains a component whose type
+ -- is the packed array (sub)type and which does not start or does not end
+ -- on a storage unit boundary.
+
-- When a variable of packed array type is allocated, gigi will allocate
-- the amount of space indicated by the corresponding packed array type.
-- However, we do NOT attempt to rewrite the types of any references or
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
index 79797fd..e978595 100644
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -61,9 +61,7 @@ package body Exp_Prag is
-- Local Subprograms --
-----------------------
- function Arg1 (N : Node_Id) return Node_Id;
- function Arg2 (N : Node_Id) return Node_Id;
- function Arg3 (N : Node_Id) return Node_Id;
+ function Arg_N (N : Node_Id; Arg_Number : Positive) return Node_Id;
-- Obtain specified pragma argument expression
procedure Expand_Pragma_Abort_Defer (N : Node_Id);
@@ -84,13 +82,24 @@ package body Exp_Prag is
-- these cases we want no initialization to occur, but we have already done
-- the initialization by the time we see the pragma, so we have to undo it.
- ----------
- -- Arg1 --
- ----------
+ -----------
+ -- Arg_N --
+ -----------
- function Arg1 (N : Node_Id) return Node_Id is
- Arg : constant Node_Id := First (Pragma_Argument_Associations (N));
+ function Arg_N (N : Node_Id; Arg_Number : Positive) return Node_Id is
+ Arg : Node_Id := First (Pragma_Argument_Associations (N));
begin
+ if No (Arg) then
+ return Empty;
+ end if;
+
+ for J in 2 .. Arg_Number loop
+ Next (Arg);
+ if No (Arg) then
+ return Empty;
+ end if;
+ end loop;
+
if Present (Arg)
and then Nkind (Arg) = N_Pragma_Argument_Association
then
@@ -98,66 +107,7 @@ package body Exp_Prag is
else
return Arg;
end if;
- end Arg1;
-
- ----------
- -- Arg2 --
- ----------
-
- function Arg2 (N : Node_Id) return Node_Id is
- Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
-
- begin
- if No (Arg1) then
- return Empty;
-
- else
- declare
- Arg : constant Node_Id := Next (Arg1);
- begin
- if Present (Arg)
- and then Nkind (Arg) = N_Pragma_Argument_Association
- then
- return Expression (Arg);
- else
- return Arg;
- end if;
- end;
- end if;
- end Arg2;
-
- ----------
- -- Arg3 --
- ----------
-
- function Arg3 (N : Node_Id) return Node_Id is
- Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
-
- begin
- if No (Arg1) then
- return Empty;
-
- else
- declare
- Arg : Node_Id := Next (Arg1);
- begin
- if No (Arg) then
- return Empty;
-
- else
- Next (Arg);
-
- if Present (Arg)
- and then Nkind (Arg) = N_Pragma_Argument_Association
- then
- return Expression (Arg);
- else
- return Arg;
- end if;
- end if;
- end;
- end if;
- end Arg3;
+ end Arg_N;
---------------------
-- Expand_N_Pragma --
@@ -317,8 +267,8 @@ package body Exp_Prag is
--------------------------
procedure Expand_Pragma_Check (N : Node_Id) is
- Cond : constant Node_Id := Arg2 (N);
- Nam : constant Name_Id := Chars (Arg1 (N));
+ Cond : constant Node_Id := Arg_N (N, 2);
+ Nam : constant Name_Id := Chars (Arg_N (N, 1));
Msg : Node_Id;
Loc : constant Source_Ptr := Sloc (First_Node (Cond));
@@ -477,7 +427,7 @@ package body Exp_Prag is
if ((Debug_Flag_Dot_G
or else Restriction_Active (No_Exception_Propagation))
and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N)))
- or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N)))
+ or else (Opt.Exception_Locations_Suppressed and then No (Arg_N (N, 3)))
then
Rewrite (N,
Make_If_Statement (Loc,
@@ -491,8 +441,8 @@ package body Exp_Prag is
else
-- If we have a message given, use it
- if Present (Arg3 (N)) then
- Msg := Get_Pragma_Arg (Arg3 (N));
+ if Present (Arg_N (N, 3)) then
+ Msg := Get_Pragma_Arg (Arg_N (N, 3));
-- Here we have no string, so prepare one
@@ -520,7 +470,7 @@ package body Exp_Prag is
-- that the failure is not at the point of occurrence of the
-- pragma, unlike the other Check cases.
- elsif Nam_In (Nam, Name_Precondition, Name_Postcondition) then
+ elsif Nam in Name_Precondition | Name_Postcondition then
Get_Name_String (Nam);
Insert_Str_In_Name_Buffer ("failed ", 1);
Add_Str_To_Name_Buffer (" from ");
@@ -615,8 +565,8 @@ package body Exp_Prag is
procedure Expand_Pragma_Common_Object (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Internal : constant Node_Id := Arg1 (N);
- External : constant Node_Id := Arg2 (N);
+ Internal : constant Node_Id := Arg_N (N, 1);
+ External : constant Node_Id := Arg_N (N, 2);
Psect : Node_Id;
-- Psect value upper cased as string literal
@@ -1380,11 +1330,11 @@ package body Exp_Prag is
if Relaxed_RM_Semantics
and then List_Length (Pragma_Argument_Associations (N)) = 2
and then Pragma_Name (N) = Name_Import
- and then Nkind (Arg2 (N)) = N_String_Literal
+ and then Nkind (Arg_N (N, 2)) = N_String_Literal
then
- Def_Id := Entity (Arg1 (N));
+ Def_Id := Entity (Arg_N (N, 1));
else
- Def_Id := Entity (Arg2 (N));
+ Def_Id := Entity (Arg_N (N, 2));
end if;
-- Variable case (we have to undo any initialization already done)
@@ -1401,7 +1351,7 @@ package body Exp_Prag is
declare
Loc : constant Source_Ptr := Sloc (N);
- Rtti_Name : constant Node_Id := Arg3 (N);
+ Rtti_Name : constant Node_Id := Arg_N (N, 3);
Dum : constant Entity_Id := Make_Temporary (Loc, 'D');
Exdata : List_Id;
Lang_Char : Node_Id;
@@ -2219,7 +2169,9 @@ package body Exp_Prag is
(Make_Function_Call
(Loc, New_Occurrence_Of (RTE (RE_Clock), Loc)))),
Right_Opnd =>
- Unchecked_Convert_To (Standard_Duration, Arg1 (N)))))));
+ Unchecked_Convert_To (
+ Standard_Duration,
+ Arg_N (N, 1)))))));
Analyze (N);
end if;
@@ -2230,7 +2182,7 @@ package body Exp_Prag is
-------------------------------------------
procedure Expand_Pragma_Suppress_Initialization (N : Node_Id) is
- Def_Id : constant Entity_Id := Entity (Arg1 (N));
+ Def_Id : constant Entity_Id := Entity (Arg_N (N, 1));
begin
-- Variable case (we have to undo any initialization already done)
diff --git a/gcc/ada/exp_prag.ads b/gcc/ada/exp_prag.ads
index 746508b..9957b21 100644
--- a/gcc/ada/exp_prag.ads
+++ b/gcc/ada/exp_prag.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
new file mode 100644
index 0000000..80b49a7
--- /dev/null
+++ b/gcc/ada/exp_put_image.adb
@@ -0,0 +1,1041 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- E X P _ P U T _ I M A G E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT 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 distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util;
+with Debug; use Debug;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Rtsfind; use Rtsfind;
+with Sem_Aux; use Sem_Aux;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Stand;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
+
+package body Exp_Put_Image is
+
+ Tagged_Put_Image_Enabled : Boolean renames Debug_Flag_Underscore_Z;
+ -- ???Set True to enable Put_Image for at least some tagged types
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Build_Put_Image_Proc
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Decl : out Node_Id;
+ Pnam : Entity_Id;
+ Stms : List_Id);
+ -- Build an array or record Put_Image procedure. Stms is the list of
+ -- statements for the body and Pnam is the name of the constructed
+ -- procedure. (The declaration list is always null.)
+
+ function Make_Put_Image_Name
+ (Loc : Source_Ptr; Typ : Entity_Id) return Entity_Id;
+ -- Return the entity that identifies the Put_Image subprogram for Typ. This
+ -- procedure deals with the difference between tagged types (where a single
+ -- subprogram associated with the type is generated) and all other cases
+ -- (where a subprogram is generated at the point of the attribute
+ -- reference). The Loc parameter is used as the Sloc of the created entity.
+
+ function Put_Image_Base_Type (E : Entity_Id) return Entity_Id;
+ -- Returns the base type, except for an array type whose whose first
+ -- subtype is constrained, in which case it returns the first subtype.
+
+ -------------------------------------
+ -- Build_Array_Put_Image_Procedure --
+ -------------------------------------
+
+ procedure Build_Array_Put_Image_Procedure
+ (Nod : Node_Id;
+ Typ : Entity_Id;
+ Decl : out Node_Id;
+ Pnam : out Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Nod);
+
+ function Wrap_In_Loop
+ (Stms : List_Id;
+ Dim : Pos;
+ Index_Subtype : Entity_Id;
+ Between_Proc : RE_Id) return Node_Id;
+ -- Wrap Stms in a loop and if statement of the form:
+ --
+ -- if V'First (Dim) <= V'Last (Dim) then -- nonempty range?
+ -- declare
+ -- LDim : Index_Type_For_Dim := V'First (Dim);
+ -- begin
+ -- loop
+ -- Stms;
+ -- exit when LDim = V'Last (Dim);
+ -- Between_Proc (S);
+ -- LDim := Index_Type_For_Dim'Succ (LDim);
+ -- end loop;
+ -- end;
+ -- end if;
+ --
+ -- This is called once per dimension, from inner to outer.
+
+ function Wrap_In_Loop
+ (Stms : List_Id;
+ Dim : Pos;
+ Index_Subtype : Entity_Id;
+ Between_Proc : RE_Id) return Node_Id
+ is
+ Index : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars => New_External_Name ('L', Dim));
+ Decl : constant Node_Id :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Index,
+ Object_Definition =>
+ New_Occurrence_Of (Index_Subtype, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Attribute_Name => Name_First,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Dim))));
+ Loop_Stm : constant Node_Id :=
+ Make_Implicit_Loop_Statement (Nod, Statements => Stms);
+ Exit_Stm : constant Node_Id :=
+ Make_Exit_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => New_Occurrence_Of (Index, Loc),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_V),
+ Attribute_Name => Name_Last,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Dim)))));
+ Increment : constant Node_Id :=
+ Make_Increment (Loc, Index, Index_Subtype);
+ Between : constant Node_Id :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (Between_Proc), Loc),
+ Parameter_Associations => New_List
+ (Make_Identifier (Loc, Name_S)));
+ Block : constant Node_Id :=
+ Make_Block_Statement (Loc,
+ Declarations => New_List (Decl),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Loop_Stm)));
+ begin
+ Append_To (Stms, Exit_Stm);
+ Append_To (Stms, Between);
+ Append_To (Stms, Increment);
+ -- Note that we're appending to the Stms list passed in
+
+ return
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Le (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Attribute_Name => Name_First,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Dim))),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Attribute_Name => Name_Last,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Dim)))),
+ Then_Statements => New_List (Block));
+ end Wrap_In_Loop;
+
+ Ndim : constant Pos := Number_Dimensions (Typ);
+ Ctyp : constant Entity_Id := Component_Type (Typ);
+
+ Stm : Node_Id;
+ Exl : constant List_Id := New_List;
+ PI_Entity : Entity_Id;
+
+ Indices : array (1 .. Ndim) of Entity_Id;
+
+ -- Start of processing for Build_Array_Put_Image_Procedure
+
+ begin
+ Pnam :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_TSS_Name_Local (Typ, TSS_Put_Image));
+
+ -- Get the Indices
+
+ declare
+ Index_Subtype : Node_Id := First_Index (Typ);
+ begin
+ for Dim in 1 .. Ndim loop
+ Indices (Dim) := Etype (Index_Subtype);
+ Next_Index (Index_Subtype);
+ end loop;
+ pragma Assert (No (Index_Subtype));
+ end;
+
+ -- Build the inner attribute call
+
+ for Dim in 1 .. Ndim loop
+ Append_To (Exl, Make_Identifier (Loc, New_External_Name ('L', Dim)));
+ end loop;
+
+ Stm :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Put_Image_Base_Type (Ctyp), Loc),
+ Attribute_Name => Name_Put_Image,
+ Expressions => New_List (
+ Make_Identifier (Loc, Name_S),
+ Make_Indexed_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Expressions => Exl)));
+
+ -- The corresponding attribute for the component type of the array might
+ -- be user-defined, and frozen after the array type. In that case,
+ -- freeze the Put_Image attribute of the component type, whose
+ -- declaration could not generate any additional freezing actions in any
+ -- case.
+
+ PI_Entity := TSS (Base_Type (Ctyp), TSS_Put_Image);
+
+ if Present (PI_Entity) and then not Is_Frozen (PI_Entity) then
+ Set_Is_Frozen (PI_Entity);
+ end if;
+
+ -- Loop through the dimensions, innermost first, generating a loop for
+ -- each dimension.
+
+ declare
+ Stms : List_Id := New_List (Stm);
+ begin
+ for Dim in reverse 1 .. Ndim loop
+ declare
+ New_Stms : constant List_Id := New_List;
+ Between_Proc : RE_Id;
+ begin
+ -- For a one-dimensional array of elementary type, use
+ -- RE_Simple_Array_Between. The same applies to the last
+ -- dimension of a multidimensional array.
+
+ if Is_Elementary_Type (Ctyp) and then Dim = Ndim then
+ Between_Proc := RE_Simple_Array_Between;
+ else
+ Between_Proc := RE_Array_Between;
+ end if;
+
+ Append_To (New_Stms,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Array_Before), Loc),
+ Parameter_Associations => New_List
+ (Make_Identifier (Loc, Name_S))));
+
+ Append_To
+ (New_Stms,
+ Wrap_In_Loop (Stms, Dim, Indices (Dim), Between_Proc));
+
+ Append_To (New_Stms,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Array_After), Loc),
+ Parameter_Associations => New_List
+ (Make_Identifier (Loc, Name_S))));
+
+ Stms := New_Stms;
+ end;
+ end loop;
+
+ Build_Put_Image_Proc (Loc, Typ, Decl, Pnam, Stms);
+ end;
+ end Build_Array_Put_Image_Procedure;
+
+ -------------------------------------
+ -- Build_Elementary_Put_Image_Call --
+ -------------------------------------
+
+ function Build_Elementary_Put_Image_Call (N : Node_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (N);
+ P_Type : constant Entity_Id := Entity (Prefix (N));
+ U_Type : constant Entity_Id := Underlying_Type (P_Type);
+ FST : constant Entity_Id := First_Subtype (U_Type);
+ Sink : constant Node_Id := First (Expressions (N));
+ Item : constant Node_Id := Next (Sink);
+ P_Size : constant Uint := Esize (FST);
+ Lib_RE : RE_Id;
+
+ begin
+ if Is_Signed_Integer_Type (U_Type) then
+ if P_Size <= Standard_Integer_Size then
+ Lib_RE := RE_Put_Image_Integer;
+ else
+ pragma Assert (P_Size <= Standard_Long_Long_Integer_Size);
+ Lib_RE := RE_Put_Image_Long_Long_Integer;
+ end if;
+
+ elsif Is_Modular_Integer_Type (U_Type) then
+ if P_Size <= Standard_Integer_Size then -- Yes, Integer
+ Lib_RE := RE_Put_Image_Unsigned;
+ else
+ pragma Assert (P_Size <= Standard_Long_Long_Integer_Size);
+ Lib_RE := RE_Put_Image_Long_Long_Unsigned;
+ end if;
+
+ elsif Is_Access_Type (U_Type) then
+ if Is_Access_Protected_Subprogram_Type (U_Type) then
+ Lib_RE := RE_Put_Image_Access_Prot_Subp;
+ elsif Is_Access_Subprogram_Type (U_Type) then
+ Lib_RE := RE_Put_Image_Access_Subp;
+ elsif P_Size = System_Address_Size then
+ Lib_RE := RE_Put_Image_Thin_Pointer;
+ else
+ pragma Assert (P_Size = 2 * System_Address_Size);
+ Lib_RE := RE_Put_Image_Fat_Pointer;
+ end if;
+
+ else
+ pragma Assert
+ (Is_Enumeration_Type (U_Type) or else Is_Real_Type (U_Type));
+
+ -- For other elementary types, generate:
+ --
+ -- Put_Wide_Wide_String (Sink, U_Type'Wide_Wide_Image (Item));
+ --
+ -- It would be more elegant to do it the other way around (define
+ -- '[[Wide_]Wide_]Image in terms of 'Put_Image). But this is easier
+ -- to implement, because we already have support for
+ -- 'Wide_Wide_Image. Furthermore, we don't want to remove the
+ -- existing support for '[[Wide_]Wide_]Image, because we don't
+ -- currently plan to support 'Put_Image on restricted runtimes.
+
+ -- We can't do this:
+ --
+ -- Put_UTF_8 (Sink, U_Type'Image (Item));
+ --
+ -- because we need to generate UTF-8, but 'Image for enumeration
+ -- types uses the character encoding of the source file.
+ --
+ -- Note that this is putting a leading space for reals.
+
+ declare
+ Image : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (U_Type, Loc),
+ Attribute_Name => Name_Wide_Wide_Image,
+ Expressions => New_List (Relocate_Node (Item)));
+ Put_Call : constant Node_Id :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Put_Wide_Wide_String), Loc),
+ Parameter_Associations => New_List
+ (Relocate_Node (Sink), Image));
+ begin
+ return Put_Call;
+ end;
+ end if;
+
+ -- Unchecked-convert parameter to the required type (i.e. the type of
+ -- the corresponding parameter), and call the appropriate routine.
+ -- We could use a normal type conversion for scalars, but the
+ -- "unchecked" is needed for access and private types.
+
+ declare
+ Libent : constant Entity_Id := RTE (Lib_RE);
+ begin
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Libent, Loc),
+ Parameter_Associations => New_List (
+ Relocate_Node (Sink),
+ Unchecked_Convert_To
+ (Etype (Next_Formal (First_Formal (Libent))),
+ Relocate_Node (Item))));
+ end;
+ end Build_Elementary_Put_Image_Call;
+
+ -------------------------------------
+ -- Build_String_Put_Image_Call --
+ -------------------------------------
+
+ function Build_String_Put_Image_Call (N : Node_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (N);
+ P_Type : constant Entity_Id := Entity (Prefix (N));
+ U_Type : constant Entity_Id := Underlying_Type (P_Type);
+ R : constant Entity_Id := Root_Type (U_Type);
+ Sink : constant Node_Id := First (Expressions (N));
+ Item : constant Node_Id := Next (Sink);
+ Lib_RE : RE_Id;
+ use Stand;
+ begin
+ if R = Standard_String then
+ Lib_RE := RE_Put_Image_String;
+ elsif R = Standard_Wide_String then
+ Lib_RE := RE_Put_Image_Wide_String;
+ elsif R = Standard_Wide_Wide_String then
+ Lib_RE := RE_Put_Image_Wide_Wide_String;
+ else
+ raise Program_Error;
+ end if;
+
+ -- Convert parameter to the required type (i.e. the type of the
+ -- corresponding parameter), and call the appropriate routine.
+ -- We set the Conversion_OK flag in case the type is private.
+
+ declare
+ Libent : constant Entity_Id := RTE (Lib_RE);
+ Conv : constant Node_Id :=
+ OK_Convert_To
+ (Etype (Next_Formal (First_Formal (Libent))),
+ Relocate_Node (Item));
+ begin
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Libent, Loc),
+ Parameter_Associations => New_List (
+ Relocate_Node (Sink),
+ Conv));
+ end;
+ end Build_String_Put_Image_Call;
+
+ ------------------------------------
+ -- Build_Protected_Put_Image_Call --
+ ------------------------------------
+
+ -- For "Protected_Type'Put_Image (S, Protected_Object)", build:
+ --
+ -- Put_Image_Protected (S);
+ --
+ -- The protected object is not passed.
+
+ function Build_Protected_Put_Image_Call (N : Node_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (N);
+ Sink : constant Node_Id := First (Expressions (N));
+ Lib_RE : constant RE_Id := RE_Put_Image_Protected;
+ Libent : constant Entity_Id := RTE (Lib_RE);
+ begin
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Libent, Loc),
+ Parameter_Associations => New_List (
+ Relocate_Node (Sink)));
+ end Build_Protected_Put_Image_Call;
+
+ ------------------------------------
+ -- Build_Task_Put_Image_Call --
+ ------------------------------------
+
+ -- For "Task_Type'Put_Image (S, Task_Object)", build:
+ --
+ -- Put_Image_Task (S, Task_Object'Identity);
+ --
+ -- The task object is not passed; its Task_Id is.
+
+ function Build_Task_Put_Image_Call (N : Node_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (N);
+ Sink : constant Node_Id := First (Expressions (N));
+ Item : constant Node_Id := Next (Sink);
+ Lib_RE : constant RE_Id := RE_Put_Image_Task;
+ Libent : constant Entity_Id := RTE (Lib_RE);
+
+ Task_Id : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Item),
+ Attribute_Name => Name_Identity,
+ Expressions => No_List);
+
+ begin
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Libent, Loc),
+ Parameter_Associations => New_List (
+ Relocate_Node (Sink),
+ Task_Id));
+ end Build_Task_Put_Image_Call;
+
+ --------------------------------------
+ -- Build_Record_Put_Image_Procedure --
+ --------------------------------------
+
+ -- The form of the record Put_Image procedure is as shown by the
+ -- following example:
+
+ -- procedure Put_Image (S : in out Sink'Class; V : Typ) is
+ -- begin
+ -- Component_Type'Put_Image (S, V.component);
+ -- Component_Type'Put_Image (S, V.component);
+ -- ...
+ -- Component_Type'Put_Image (S, V.component);
+ --
+ -- case V.discriminant is
+ -- when choices =>
+ -- Component_Type'Put_Image (S, V.component);
+ -- Component_Type'Put_Image (S, V.component);
+ -- ...
+ -- Component_Type'Put_Image (S, V.component);
+ --
+ -- when choices =>
+ -- Component_Type'Put_Image (S, V.component);
+ -- Component_Type'Put_Image (S, V.component);
+ -- ...
+ -- Component_Type'Put_Image (S, V.component);
+ -- ...
+ -- end case;
+ -- end Put_Image;
+
+ procedure Build_Record_Put_Image_Procedure
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Decl : out Node_Id;
+ Pnam : out Entity_Id)
+ is
+ Btyp : constant Entity_Id := Base_Type (Typ);
+ pragma Assert (not Is_Unchecked_Union (Btyp));
+
+ First_Time : Boolean := True;
+
+ function Make_Component_List_Attributes (CL : Node_Id) return List_Id;
+ -- Returns a sequence of Component_Type'Put_Image attribute_references
+ -- to process the components that are referenced in the given component
+ -- list. Called for the main component list, and then recursively for
+ -- variants.
+
+ function Make_Component_Attributes (Clist : List_Id) return List_Id;
+ -- Given Clist, a component items list, construct series of
+ -- Component_Type'Put_Image attribute_references for componentwise
+ -- processing of the corresponding components. Called for the
+ -- discriminants, and then from Make_Component_List_Attributes for each
+ -- list (including in variants).
+
+ procedure Append_Component_Attr (Clist : List_Id; C : Entity_Id);
+ -- Given C, the entity for a discriminant or component, build a call to
+ -- Component_Type'Put_Image for the corresponding component value, and
+ -- append it onto Clist. Called from Make_Component_Attributes.
+
+ function Make_Component_Name (C : Entity_Id) return Node_Id;
+ -- Create a call that prints "Comp_Name => "
+
+ ------------------------------------
+ -- Make_Component_List_Attributes --
+ ------------------------------------
+
+ function Make_Component_List_Attributes (CL : Node_Id) return List_Id is
+ CI : constant List_Id := Component_Items (CL);
+ VP : constant Node_Id := Variant_Part (CL);
+
+ Result : List_Id;
+ Alts : List_Id;
+ V : Node_Id;
+ DC : Node_Id;
+ DCH : List_Id;
+ D_Ref : Node_Id;
+
+ begin
+ Result := Make_Component_Attributes (CI);
+
+ if Present (VP) then
+ Alts := New_List;
+
+ V := First_Non_Pragma (Variants (VP));
+ while Present (V) loop
+ DCH := New_List;
+
+ DC := First (Discrete_Choices (V));
+ while Present (DC) loop
+ Append_To (DCH, New_Copy_Tree (DC));
+ Next (DC);
+ end loop;
+
+ Append_To (Alts,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices => DCH,
+ Statements =>
+ Make_Component_List_Attributes (Component_List (V))));
+ Next_Non_Pragma (V);
+ end loop;
+
+ -- Note: in the following, we use New_Occurrence_Of for the
+ -- selector, since there are cases in which we make a reference
+ -- to a hidden discriminant that is not visible.
+
+ D_Ref :=
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Selector_Name =>
+ New_Occurrence_Of (Entity (Name (VP)), Loc));
+
+ Append_To (Result,
+ Make_Case_Statement (Loc,
+ Expression => D_Ref,
+ Alternatives => Alts));
+ end if;
+
+ return Result;
+ end Make_Component_List_Attributes;
+
+ --------------------------------
+ -- Append_Component_Attr --
+ --------------------------------
+
+ procedure Append_Component_Attr (Clist : List_Id; C : Entity_Id) is
+ Component_Typ : constant Entity_Id := Put_Image_Base_Type (Etype (C));
+ begin
+ if Ekind (C) /= E_Void then
+ Append_To (Clist,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Component_Typ, Loc),
+ Attribute_Name => Name_Put_Image,
+ Expressions => New_List (
+ Make_Identifier (Loc, Name_S),
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Selector_Name => New_Occurrence_Of (C, Loc)))));
+ end if;
+ end Append_Component_Attr;
+
+ -------------------------------
+ -- Make_Component_Attributes --
+ -------------------------------
+
+ function Make_Component_Attributes (Clist : List_Id) return List_Id is
+ Item : Node_Id;
+ Result : List_Id;
+
+ begin
+ Result := New_List;
+
+ if Present (Clist) then
+ Item := First (Clist);
+
+ -- Loop through components, skipping all internal components,
+ -- which are not part of the value (e.g. _Tag), except that we
+ -- don't skip the _Parent, since we do want to process that
+ -- recursively. If _Parent is an interface type, being abstract
+ -- with no components there is no need to handle it.
+
+ while Present (Item) loop
+ if Nkind (Item) in
+ N_Component_Declaration | N_Discriminant_Specification
+ and then
+ ((Chars (Defining_Identifier (Item)) = Name_uParent
+ and then not Is_Interface
+ (Etype (Defining_Identifier (Item))))
+ or else
+ not Is_Internal_Name (Chars (Defining_Identifier (Item))))
+ then
+ if First_Time then
+ First_Time := False;
+ else
+ Append_To (Result,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Record_Between), Loc),
+ Parameter_Associations => New_List
+ (Make_Identifier (Loc, Name_S))));
+ end if;
+
+ Append_To (Result, Make_Component_Name (Item));
+ Append_Component_Attr (Result, Defining_Identifier (Item));
+ end if;
+
+ Next (Item);
+ end loop;
+ end if;
+
+ return Result;
+ end Make_Component_Attributes;
+
+ -------------------------
+ -- Make_Component_Name --
+ -------------------------
+
+ function Make_Component_Name (C : Entity_Id) return Node_Id is
+ Name : constant Name_Id := Chars (Defining_Identifier (C));
+ begin
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Put_UTF_8), Loc),
+ Parameter_Associations => New_List
+ (Make_Identifier (Loc, Name_S),
+ Make_String_Literal (Loc, Get_Name_String (Name) & " => ")));
+ end Make_Component_Name;
+
+ Stms : constant List_Id := New_List;
+ Rdef : Node_Id;
+ Type_Decl : constant Node_Id :=
+ Declaration_Node (Base_Type (Underlying_Type (Btyp)));
+
+ -- Start of processing for Build_Record_Put_Image_Procedure
+
+ begin
+ Append_To (Stms,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Record_Before), Loc),
+ Parameter_Associations => New_List
+ (Make_Identifier (Loc, Name_S))));
+
+ -- Generate Put_Images for the discriminants of the type
+
+ Append_List_To (Stms,
+ Make_Component_Attributes (Discriminant_Specifications (Type_Decl)));
+
+ Rdef := Type_Definition (Type_Decl);
+
+ -- In the record extension case, the components we want, including the
+ -- _Parent component representing the parent type, are to be found in
+ -- the extension. We will process the _Parent component using the type
+ -- of the parent.
+
+ if Nkind (Rdef) = N_Derived_Type_Definition then
+ Rdef := Record_Extension_Part (Rdef);
+ end if;
+
+ if Present (Component_List (Rdef)) then
+ Append_List_To (Stms,
+ Make_Component_List_Attributes (Component_List (Rdef)));
+ end if;
+
+ Append_To (Stms,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Record_After), Loc),
+ Parameter_Associations => New_List
+ (Make_Identifier (Loc, Name_S))));
+
+ Pnam := Make_Put_Image_Name (Loc, Btyp);
+ Build_Put_Image_Proc (Loc, Btyp, Decl, Pnam, Stms);
+ end Build_Record_Put_Image_Procedure;
+
+ -------------------------------
+ -- Build_Put_Image_Profile --
+ -------------------------------
+
+ function Build_Put_Image_Profile
+ (Loc : Source_Ptr; Typ : Entity_Id) return List_Id
+ is
+ begin
+ return New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
+ In_Present => True,
+ Out_Present => True,
+ Parameter_Type =>
+ New_Occurrence_Of (Class_Wide_Type (RTE (RE_Sink)), Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
+ Parameter_Type => New_Occurrence_Of (Typ, Loc)));
+ end Build_Put_Image_Profile;
+
+ --------------------------
+ -- Build_Put_Image_Proc --
+ --------------------------
+
+ procedure Build_Put_Image_Proc
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Decl : out Node_Id;
+ Pnam : Entity_Id;
+ Stms : List_Id)
+ is
+ Spec : constant Node_Id :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Pnam,
+ Parameter_Specifications => Build_Put_Image_Profile (Loc, Typ));
+ begin
+ Decl :=
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stms));
+ end Build_Put_Image_Proc;
+
+ ------------------------------------
+ -- Build_Unknown_Put_Image_Call --
+ ------------------------------------
+
+ function Build_Unknown_Put_Image_Call (N : Node_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (N);
+ Sink : constant Node_Id := First (Expressions (N));
+ Lib_RE : constant RE_Id := RE_Put_Image_Unknown;
+ Libent : constant Entity_Id := RTE (Lib_RE);
+ begin
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Libent, Loc),
+ Parameter_Associations => New_List (
+ Relocate_Node (Sink),
+ Make_String_Literal (Loc,
+ Exp_Util.Fully_Qualified_Name_String (
+ Entity (Prefix (N)), Append_NUL => False))));
+ end Build_Unknown_Put_Image_Call;
+
+ ----------------------
+ -- Enable_Put_Image --
+ ----------------------
+
+ function Enable_Put_Image (Typ : Entity_Id) return Boolean is
+ begin
+ -- There's a bit of a chicken&egg problem. The compiler is likely to
+ -- have trouble if we refer to the Put_Image of Sink itself, because
+ -- Sink is part of the parameter profile:
+ --
+ -- function Sink'Put_Image (S : in out Sink'Class; V : T);
+ --
+ -- Likewise, the Ada.Strings.Text_Output package, where Sink is
+ -- declared, depends on various other packages, so if we refer to
+ -- Put_Image of types declared in those other packages, we could create
+ -- cyclic dependencies. Therefore, we disable Put_Image for some
+ -- types. It's not clear exactly what types should be disabled. Scalar
+ -- types are OK, even if predefined, because calls to Put_Image of
+ -- scalar types are expanded inline. We certainly want to be able to use
+ -- Integer'Put_Image, for example.
+
+ -- ???Temporarily disable to work around bugs:
+ --
+ -- Put_Image does not work for Remote_Types. We check the containing
+ -- package, rather than the type itself, because we want to include
+ -- types in the private part of a Remote_Types package.
+ --
+ -- Put_Image on tagged types triggers some bugs.
+
+ if Is_Remote_Types (Scope (Typ))
+ or else (Is_Tagged_Type (Typ) and then In_Predefined_Unit (Typ))
+ or else (Is_Tagged_Type (Typ) and then not Tagged_Put_Image_Enabled)
+ then
+ return False;
+ end if;
+
+ -- End of workarounds.
+
+ -- No sense in generating code for Put_Image if there are errors. This
+ -- avoids certain cascade errors.
+
+ if Total_Errors_Detected > 0 then
+ return False;
+ end if;
+
+ -- If type Sink is unavailable in this runtime, disable Put_Image
+ -- altogether.
+
+ if No_Run_Time_Mode or else not RTE_Available (RE_Sink) then
+ return False;
+ end if;
+
+ -- ???Disable Put_Image on type Sink declared in
+ -- Ada.Strings.Text_Output. Note that we can't call Is_RTU on
+ -- Ada_Strings_Text_Output, because it's not known yet (we might be
+ -- compiling it). But this is insufficient to allow support for tagged
+ -- predefined types.
+
+ declare
+ Parent_Scope : constant Entity_Id := Scope (Scope (Typ));
+ begin
+ if Present (Parent_Scope)
+ and then Is_RTU (Parent_Scope, Ada_Strings)
+ and then Chars (Scope (Typ)) = Name_Find ("text_output")
+ then
+ return False;
+ end if;
+ end;
+
+ -- Disable for CPP types, because the components are unavailable on the
+ -- Ada side.
+
+ if Is_Tagged_Type (Typ)
+ and then Convention (Typ) = Convention_CPP
+ and then Is_CPP_Class (Root_Type (Typ))
+ then
+ return False;
+ end if;
+
+ -- Disable for unchecked unions, because there is no way to know the
+ -- discriminant value, and therefore no way to know which components
+ -- should be printed.
+
+ if Is_Unchecked_Union (Typ) then
+ return False;
+ end if;
+
+ return True;
+ end Enable_Put_Image;
+
+ ---------------------------------
+ -- Make_Put_Image_Name --
+ ---------------------------------
+
+ function Make_Put_Image_Name
+ (Loc : Source_Ptr; Typ : Entity_Id) return Entity_Id
+ is
+ Sname : Name_Id;
+ begin
+ -- For tagged types, we are dealing with a TSS associated with the
+ -- declaration, so we use the standard primitive function name. For
+ -- other types, generate a local TSS name since we are generating
+ -- the subprogram at the point of use.
+
+ if Is_Tagged_Type (Typ) then
+ Sname := Make_TSS_Name (Typ, TSS_Put_Image);
+ else
+ Sname := Make_TSS_Name_Local (Typ, TSS_Put_Image);
+ end if;
+
+ return Make_Defining_Identifier (Loc, Sname);
+ end Make_Put_Image_Name;
+
+ function Image_Should_Call_Put_Image (N : Node_Id) return Boolean is
+ begin
+ if Ada_Version < Ada_2020 then
+ return False;
+ end if;
+
+ -- In Ada 2020, T'Image calls T'Put_Image if there is an explicit
+ -- aspect_specification for Put_Image, or if U_Type'Image is illegal
+ -- in pre-2020 versions of Ada.
+
+ declare
+ U_Type : constant Entity_Id := Underlying_Type (Entity (Prefix (N)));
+ begin
+ if Present (TSS (U_Type, TSS_Put_Image)) then
+ return True;
+ end if;
+
+ return not Is_Scalar_Type (U_Type);
+ end;
+ end Image_Should_Call_Put_Image;
+
+ function Build_Image_Call (N : Node_Id) return Node_Id is
+ -- For T'Image (X) Generate an Expression_With_Actions node:
+ --
+ -- do
+ -- S : Buffer := New_Buffer;
+ -- U_Type'Put_Image (S, X);
+ -- Result : constant String := Get (S);
+ -- Destroy (S);
+ -- in Result end
+ --
+ -- where U_Type is the underlying type, as needed to bypass privacy.
+
+ Loc : constant Source_Ptr := Sloc (N);
+ U_Type : constant Entity_Id := Underlying_Type (Entity (Prefix (N)));
+ Sink_Entity : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S'));
+ Sink_Decl : constant Node_Id :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Sink_Entity,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Buffer), Loc),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (RE_New_Buffer), Loc),
+ Parameter_Associations => Empty_List));
+ Put_Im : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (U_Type, Loc),
+ Attribute_Name => Name_Put_Image,
+ Expressions => New_List (
+ New_Occurrence_Of (Sink_Entity, Loc),
+ New_Copy_Tree (First (Expressions (N)))));
+ Result_Entity : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('R'));
+ Result_Decl : constant Node_Id :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Result_Entity,
+ Object_Definition =>
+ New_Occurrence_Of (Stand.Standard_String, Loc),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Get), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Sink_Entity, Loc))));
+ Image : constant Node_Id :=
+ Make_Expression_With_Actions (Loc,
+ Actions => New_List (Sink_Decl, Put_Im, Result_Decl),
+ Expression => New_Occurrence_Of (Result_Entity, Loc));
+ begin
+ return Image;
+ end Build_Image_Call;
+
+ ------------------
+ -- Preload_Sink --
+ ------------------
+
+ procedure Preload_Sink (Compilation_Unit : Node_Id) is
+ begin
+ -- We can't call RTE (RE_Sink) for at least some predefined units,
+ -- because it would introduce cyclic dependences. The package where Sink
+ -- is declared, for example, and things it depends on.
+ --
+ -- It's only needed for tagged types, so don't do it unless Put_Image is
+ -- enabled for tagged types, and we've seen a tagged type. Note that
+ -- Tagged_Seen is set True by the parser if the "tagged" reserved word
+ -- is seen; this flag tells us whether we have any tagged types.
+ -- It's unfortunate to have this Tagged_Seen processing so scattered
+ -- about, but we need to know if there are tagged types where this is
+ -- called in Analyze_Compilation_Unit, before we have analyzed any type
+ -- declarations. This mechanism also prevents doing RTE (RE_Sink) when
+ -- compiling the compiler itself. Packages Ada.Strings.Text_Output and
+ -- friends are not included in the compiler.
+ --
+ -- Don't do it if type Sink is unavailable in the runtime.
+
+ if not In_Predefined_Unit (Compilation_Unit)
+ and then Tagged_Put_Image_Enabled
+ and then Tagged_Seen
+ and then not No_Run_Time_Mode
+ and then RTE_Available (RE_Sink)
+ then
+ declare
+ Ignore : constant Entity_Id := RTE (RE_Sink);
+ begin
+ null;
+ end;
+ end if;
+ end Preload_Sink;
+
+ -------------------------
+ -- Put_Image_Base_Type --
+ -------------------------
+
+ function Put_Image_Base_Type (E : Entity_Id) return Entity_Id is
+ begin
+ if Is_Array_Type (E) and then Is_First_Subtype (E) then
+ return E;
+ else
+ return Base_Type (E);
+ end if;
+ end Put_Image_Base_Type;
+
+end Exp_Put_Image;
diff --git a/gcc/ada/exp_put_image.ads b/gcc/ada/exp_put_image.ads
new file mode 100644
index 0000000..00b3371
--- /dev/null
+++ b/gcc/ada/exp_put_image.ads
@@ -0,0 +1,103 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- E X P _ P U T _ I M A G E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT 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 distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Types; use Types;
+
+package Exp_Put_Image is
+
+ -- Routines to build Put_Image calls. See Ada.Strings.Text_Output.Utils and
+ -- System.Put_Images for the run-time routines we are generating calls to.
+
+ -- For a call to T'Put_Image, if T is elementary, we expand the code
+ -- inline. If T is a tagged type, then Put_Image is a primitive procedure
+ -- of T, and can be dispatched to in the class-wide case. For untagged
+ -- composite types, we generate a procedure the first time we see a call,
+ -- and call it. Subsequent calls call the same procedure. Thus, if there
+ -- are calls to T'Put_Image in different units, there will be duplicates;
+ -- each unit will get a copy of the T'Put_Image procedure.
+
+ function Enable_Put_Image (Typ : Entity_Id) return Boolean;
+ -- True if the predefined Put_Image should be enabled for type T. Put_Image
+ -- is always enabled if there is a user-specified one.
+
+ function Build_Put_Image_Profile
+ (Loc : Source_Ptr; Typ : Entity_Id) return List_Id;
+ -- Builds the parameter profile for Put_Image. This is used for the tagged
+ -- case to build the spec for the primitive operation.
+
+ -- In the following Build_... routines, N is the attribute reference node,
+ -- from which the procedure to call and the parameters to pass can be
+ -- determined.
+
+ function Build_Elementary_Put_Image_Call (N : Node_Id) return Node_Id;
+ -- Builds a Put_Image call for an elementary type.
+
+ function Build_String_Put_Image_Call (N : Node_Id) return Node_Id;
+ -- Builds a Put_Image call for a standard string type.
+
+ function Build_Protected_Put_Image_Call (N : Node_Id) return Node_Id;
+ -- Builds a Put_Image call for a protected type.
+
+ function Build_Task_Put_Image_Call (N : Node_Id) return Node_Id;
+ -- Builds a Put_Image call for a task type.
+
+ -- The following routines build the Put_Image procedure for composite
+ -- types. Typ is the base type to which the procedure applies (i.e. the
+ -- base type of the Put_Image attribute prefix). The returned results are
+ -- the declaration and name (entity) of the procedure.
+
+ procedure Build_Array_Put_Image_Procedure
+ (Nod : Node_Id;
+ Typ : Entity_Id;
+ Decl : out Node_Id;
+ Pnam : out Entity_Id);
+ -- Nod provides the Sloc value for the generated code
+
+ procedure Build_Record_Put_Image_Procedure
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Decl : out Node_Id;
+ Pnam : out Entity_Id);
+ -- Loc is the location of the subprogram declaration
+
+ function Build_Unknown_Put_Image_Call (N : Node_Id) return Node_Id;
+ -- Build a call to Put_Image_Unknown
+
+ function Image_Should_Call_Put_Image (N : Node_Id) return Boolean;
+ -- True if T'Image should call T'Put_Image. N is the attribute_reference
+ -- T'Image.
+
+ function Build_Image_Call (N : Node_Id) return Node_Id;
+ -- N is a call to T'Image, and this translates it into the appropriate code
+ -- to call T'Put_Image into a buffer and then extract the string from the
+ -- buffer.
+
+ procedure Preload_Sink (Compilation_Unit : Node_Id);
+ -- Call RTE (RE_Sink) if necessary, to load the packages involved in
+ -- Put_Image. We need to do this explicitly, fairly early during
+ -- compilation, because otherwise it happens during freezing, which
+ -- triggers visibility bugs in generic instantiations.
+
+end Exp_Put_Image;
diff --git a/gcc/ada/exp_sel.adb b/gcc/ada/exp_sel.adb
index 9248faa..0fe9d3b 100644
--- a/gcc/ada/exp_sel.adb
+++ b/gcc/ada/exp_sel.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_sel.ads b/gcc/ada/exp_sel.ads
index 0f3324c..98ac647 100644
--- a/gcc/ada/exp_sel.ads
+++ b/gcc/ada/exp_sel.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_smem.adb b/gcc/ada/exp_smem.adb
index 8290d5e..fa4aeb6 100644
--- a/gcc/ada/exp_smem.adb
+++ b/gcc/ada/exp_smem.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -372,7 +372,7 @@ package body Exp_Smem is
return False;
else
- if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter) then
+ if Ekind (Formal) in E_Out_Parameter | E_In_Out_Parameter then
Insert_Node := Call;
return True;
else
@@ -454,7 +454,7 @@ package body Exp_Smem is
begin
while Next (Nod) /= After loop
- Nod := Next (Nod);
+ Next (Nod);
end loop;
return Nod;
@@ -477,7 +477,7 @@ package body Exp_Smem is
return False;
end if;
- elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component)
+ elsif Nkind (P) in N_Indexed_Component | N_Selected_Component
and then N = Prefix (P)
then
return On_Lhs_Of_Assignment (P);
diff --git a/gcc/ada/exp_smem.ads b/gcc/ada/exp_smem.ads
index 88983f0..26ea6da 100644
--- a/gcc/ada/exp_smem.ads
+++ b/gcc/ada/exp_smem.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb
index 28484aa..b400268 100644
--- a/gcc/ada/exp_spark.adb
+++ b/gcc/ada/exp_spark.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -36,7 +36,6 @@ with Nlists; use Nlists;
with Nmake; use Nmake;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
-with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
@@ -53,14 +52,16 @@ package body Exp_SPARK is
-----------------------
procedure Expand_SPARK_N_Attribute_Reference (N : Node_Id);
- -- Replace occurrences of System'To_Address by calls to
- -- System.Storage_Elements.To_Address
+ -- Perform attribute-reference-specific expansion
+
+ procedure Expand_SPARK_N_Delta_Aggregate (N : Node_Id);
+ -- Perform delta-aggregate-specific expansion
procedure Expand_SPARK_N_Freeze_Type (E : Entity_Id);
-- Build the DIC procedure of a type when needed, if not already done
procedure Expand_SPARK_N_Loop_Statement (N : Node_Id);
- -- Perform loop statement-specific expansion
+ -- Perform loop-statement-specific expansion
procedure Expand_SPARK_N_Object_Declaration (N : Node_Id);
-- Perform object-declaration-specific expansion
@@ -71,11 +72,8 @@ package body Exp_SPARK is
procedure Expand_SPARK_N_Op_Ne (N : Node_Id);
-- Rewrite operator /= based on operator = when defined explicitly
- procedure Expand_SPARK_N_Selected_Component (N : Node_Id);
- -- Insert explicit dereference if required
-
- procedure Expand_SPARK_N_Slice_Or_Indexed_Component (N : Node_Id);
- -- Insert explicit dereference if required
+ procedure Expand_SPARK_Delta_Or_Update (Typ : Entity_Id; Aggr : Node_Id);
+ -- Common expansion for attribute Update and delta aggregates
------------------
-- Expand_SPARK --
@@ -109,6 +107,9 @@ package body Exp_SPARK is
when N_Attribute_Reference =>
Expand_SPARK_N_Attribute_Reference (N);
+ when N_Delta_Aggregate =>
+ Expand_SPARK_N_Delta_Aggregate (N);
+
when N_Expanded_Name
| N_Identifier
=>
@@ -138,14 +139,6 @@ package body Exp_SPARK is
Expand_SPARK_N_Freeze_Type (Entity (N));
end if;
- when N_Indexed_Component
- | N_Slice
- =>
- Expand_SPARK_N_Slice_Or_Indexed_Component (N);
-
- when N_Selected_Component =>
- Expand_SPARK_N_Selected_Component (N);
-
-- In SPARK mode, no other constructs require expansion
when others =>
@@ -153,6 +146,185 @@ package body Exp_SPARK is
end case;
end Expand_SPARK;
+ ----------------------------------
+ -- Expand_SPARK_Delta_Or_Update --
+ ----------------------------------
+
+ procedure Expand_SPARK_Delta_Or_Update
+ (Typ : Entity_Id;
+ Aggr : Node_Id)
+ is
+ Assoc : Node_Id;
+ Comp : Node_Id;
+ Comp_Id : Entity_Id;
+ Comp_Type : Entity_Id;
+ Expr : Node_Id;
+ Index : Node_Id;
+ Index_Typ : Entity_Id;
+ New_Assoc : Node_Id;
+
+ begin
+ -- Apply scalar range checks on the updated components, if needed
+
+ if Is_Array_Type (Typ) then
+
+ -- Multidimensional arrays
+
+ if Present (Next_Index (First_Index (Typ))) then
+ Assoc := First (Component_Associations (Aggr));
+
+ while Present (Assoc) loop
+ Expr := Expression (Assoc);
+ Comp_Type := Component_Type (Typ);
+
+ if Is_Scalar_Type (Comp_Type) then
+ Apply_Scalar_Range_Check (Expr, Comp_Type);
+ end if;
+
+ -- The current association contains a sequence of indexes
+ -- denoting an element of a multidimensional array:
+ --
+ -- (Index_1, ..., Index_N)
+
+ Expr := First (Choices (Assoc));
+
+ pragma Assert (Nkind (Aggr) = N_Aggregate);
+
+ while Present (Expr) loop
+ Index := First (Expressions (Expr));
+ Index_Typ := First_Index (Typ);
+
+ while Present (Index_Typ) loop
+ Apply_Scalar_Range_Check (Index, Etype (Index_Typ));
+ Next (Index);
+ Next_Index (Index_Typ);
+ end loop;
+
+ Next (Expr);
+ end loop;
+
+ Next (Assoc);
+ end loop;
+
+ -- One-dimensional arrays
+
+ else
+ Assoc := First (Component_Associations (Aggr));
+
+ while Present (Assoc) loop
+ Expr := Expression (Assoc);
+ Comp_Type := Component_Type (Typ);
+
+ if Is_Scalar_Type (Comp_Type) then
+ Apply_Scalar_Range_Check (Expr, Comp_Type);
+ end if;
+
+ Index := First (Choices (Assoc));
+ Index_Typ := First_Index (Typ);
+
+ while Present (Index) loop
+ -- The index denotes a range of elements
+
+ if Nkind (Index) = N_Range then
+ Apply_Scalar_Range_Check
+ (Low_Bound (Index), Base_Type (Etype (Index_Typ)));
+ Apply_Scalar_Range_Check
+ (High_Bound (Index), Base_Type (Etype (Index_Typ)));
+
+ -- Otherwise the index denotes a single element
+
+ else
+ Apply_Scalar_Range_Check (Index, Etype (Index_Typ));
+ end if;
+
+ Next (Index);
+ end loop;
+
+ Next (Assoc);
+ end loop;
+ end if;
+
+ else pragma Assert (Is_Record_Type (Typ));
+
+ -- If the aggregate has multiple component choices, e.g.:
+ --
+ -- X'Update (A | B | C => 123)
+ --
+ -- then each component might be of a different type and might or
+ -- might not require a range check. We first rewrite associations
+ -- into single-component choices, e.g.:
+ --
+ -- X'Update (A => 123, B => 123, C => 123)
+ --
+ -- and then apply range checks to individual copies of the
+ -- expressions. We do the same for delta aggregates, accordingly.
+
+ -- Iterate over associations of the original aggregate
+
+ Assoc := First (Component_Associations (Aggr));
+
+ -- Rewrite into a new aggregate and decorate
+
+ case Nkind (Aggr) is
+ when N_Aggregate =>
+ Rewrite
+ (Aggr,
+ Make_Aggregate
+ (Sloc => Sloc (Aggr),
+ Component_Associations => New_List));
+
+ when N_Delta_Aggregate =>
+ Rewrite
+ (Aggr,
+ Make_Delta_Aggregate
+ (Sloc => Sloc (Aggr),
+ Expression => Expression (Aggr),
+ Component_Associations => New_List));
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ Set_Etype (Aggr, Typ);
+
+ -- Populate the new aggregate with component associations
+
+ while Present (Assoc) loop
+ Expr := Expression (Assoc);
+ Comp := First (Choices (Assoc));
+
+ while Present (Comp) loop
+ Comp_Id := Entity (Comp);
+ Comp_Type := Etype (Comp_Id);
+
+ New_Assoc :=
+ Make_Component_Association
+ (Sloc => Sloc (Assoc),
+ Choices =>
+ New_List
+ (New_Occurrence_Of (Comp_Id, Sloc (Comp))),
+ Expression => New_Copy_Tree (Expr));
+
+ -- New association must be attached to the aggregate before we
+ -- analyze it.
+
+ Append (New_Assoc, Component_Associations (Aggr));
+
+ Analyze_And_Resolve (Expression (New_Assoc), Comp_Type);
+
+ if Is_Scalar_Type (Comp_Type) then
+ Apply_Scalar_Range_Check
+ (Expression (New_Assoc), Comp_Type);
+ end if;
+
+ Next (Comp);
+ end loop;
+
+ Next (Assoc);
+ end loop;
+ end if;
+ end Expand_SPARK_Delta_Or_Update;
+
--------------------------------
-- Expand_SPARK_N_Freeze_Type --
--------------------------------
@@ -200,36 +372,6 @@ package body Exp_SPARK is
Parameter_Associations => New_List (Expr)));
Analyze_And_Resolve (N, Typ);
- -- Whenever possible, replace a prefix which is an enumeration literal
- -- by the corresponding literal value.
-
- elsif Attr_Id = Attribute_Enum_Rep then
- declare
- Exprs : constant List_Id := Expressions (N);
- begin
- if Is_Non_Empty_List (Exprs) then
- Expr := First (Exprs);
- else
- Expr := Prefix (N);
- end if;
-
- -- If the argument is a literal, expand it
-
- if Nkind (Expr) in N_Has_Entity
- and then
- (Ekind (Entity (Expr)) = E_Enumeration_Literal
- or else
- (Nkind (Expr) in N_Has_Entity
- and then Ekind (Entity (Expr)) = E_Constant
- and then Present (Renamed_Object (Entity (Expr)))
- and then Is_Entity_Name (Renamed_Object (Entity (Expr)))
- and then Ekind (Entity (Renamed_Object (Entity (Expr)))) =
- E_Enumeration_Literal))
- then
- Exp_Attr.Expand_N_Attribute_Reference (N);
- end if;
- end;
-
elsif Attr_Id = Attribute_Object_Size
or else Attr_Id = Attribute_Size
or else Attr_Id = Attribute_Value_Size
@@ -258,41 +400,23 @@ package body Exp_SPARK is
-- flag as the compiler assumes attributes always fit in this type.
-- Since in SPARK_Mode we do not take Storage_Error into account, we
-- cannot make this assumption and need to produce a check.
- -- ??? It should be enough to add this check for attributes 'Length
- -- and 'Range_Length when the type is as big as Long_Long_Integer.
+ -- ??? It should be enough to add this check for attributes
+ -- 'Length, 'Range_Length and 'Pos when the type is as big
+ -- as Long_Long_Integer.
declare
- Typ : Entity_Id := Empty;
+ Typ : Entity_Id;
begin
- if Attr_Id = Attribute_Range_Length then
+ if Attr_Id = Attribute_Range_Length
+ or else Attr_Id = Attribute_Pos
+ then
Typ := Etype (Prefix (N));
elsif Attr_Id = Attribute_Length then
- Typ := Etype (Prefix (N));
-
- declare
- Indx : Node_Id;
- J : Int;
-
- begin
- if Is_Access_Type (Typ) then
- Typ := Designated_Type (Typ);
- end if;
-
- if No (Expressions (N)) then
- J := 1;
- else
- J := UI_To_Int (Expr_Value (First (Expressions (N))));
- end if;
-
- Indx := First_Index (Typ);
- while J > 1 loop
- Next_Index (Indx);
- J := J - 1;
- end loop;
+ Typ := Get_Index_Subtype (N);
- Typ := Etype (Indx);
- end;
+ else
+ Typ := Empty;
end if;
Apply_Universal_Integer_Attribute_Checks (N);
@@ -300,6 +424,9 @@ package body Exp_SPARK is
if Present (Typ)
and then RM_Size (Typ) = RM_Size (Standard_Long_Long_Integer)
then
+ -- ??? This should rather be a range check, but this would
+ -- crash GNATprove which somehow recovers the proper kind
+ -- of check anyway.
Set_Do_Overflow_Check (N);
end if;
end;
@@ -317,9 +444,21 @@ package body Exp_SPARK is
Make_Explicit_Dereference (Loc, Relocate_Node (Pref)));
Analyze_And_Resolve (N, Standard_Boolean);
end if;
+
+ elsif Attr_Id = Attribute_Update then
+ Expand_SPARK_Delta_Or_Update (Typ, First (Expressions (N)));
end if;
end Expand_SPARK_N_Attribute_Reference;
+ ------------------------------------
+ -- Expand_SPARK_N_Delta_Aggregate --
+ ------------------------------------
+
+ procedure Expand_SPARK_N_Delta_Aggregate (N : Node_Id) is
+ begin
+ Expand_SPARK_Delta_Or_Update (Etype (N), N);
+ end Expand_SPARK_N_Delta_Aggregate;
+
-----------------------------------
-- Expand_SPARK_N_Loop_Statement --
-----------------------------------
@@ -500,7 +639,7 @@ package body Exp_SPARK is
begin
-- Replace a reference to a renaming with the actual renamed object
- if Ekind (Obj_Id) in Object_Kind then
+ if Is_Object (Obj_Id) then
Ren := Renamed_Object (Obj_Id);
if Present (Ren) then
@@ -533,40 +672,4 @@ package body Exp_SPARK is
end if;
end Expand_SPARK_Potential_Renaming;
- ---------------------------------------
- -- Expand_SPARK_N_Selected_Component --
- ---------------------------------------
-
- procedure Expand_SPARK_N_Selected_Component (N : Node_Id) is
- Pref : constant Node_Id := Prefix (N);
- Typ : constant Entity_Id := Underlying_Type (Etype (Pref));
-
- begin
- if Present (Typ) and then Is_Access_Type (Typ) then
-
- -- First set prefix type to proper access type, in case it currently
- -- has a private (non-access) view of this type.
-
- Set_Etype (Pref, Typ);
-
- Insert_Explicit_Dereference (Pref);
- Analyze_And_Resolve (Pref, Designated_Type (Typ));
- end if;
- end Expand_SPARK_N_Selected_Component;
-
- -----------------------------------------------
- -- Expand_SPARK_N_Slice_Or_Indexed_Component --
- -----------------------------------------------
-
- procedure Expand_SPARK_N_Slice_Or_Indexed_Component (N : Node_Id) is
- Pref : constant Node_Id := Prefix (N);
- Typ : constant Entity_Id := Etype (Pref);
-
- begin
- if Is_Access_Type (Typ) then
- Insert_Explicit_Dereference (Pref);
- Analyze_And_Resolve (Pref, Designated_Type (Typ));
- end if;
- end Expand_SPARK_N_Slice_Or_Indexed_Component;
-
end Exp_SPARK;
diff --git a/gcc/ada/exp_spark.ads b/gcc/ada/exp_spark.ads
index 36e98a1..67fa043 100644
--- a/gcc/ada/exp_spark.ads
+++ b/gcc/ada/exp_spark.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb
index 78f62a8..6cda955 100644
--- a/gcc/ada/exp_strm.adb
+++ b/gcc/ada/exp_strm.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -297,7 +297,7 @@ package body Exp_Strm is
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Output));
- Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
+ Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => False);
end Build_Array_Output_Procedure;
--------------------------------
@@ -420,7 +420,7 @@ package body Exp_Strm is
end loop;
Build_Stream_Procedure
- (Loc, Typ, Decl, Pnam, New_List (Stm), Nam = Name_Read);
+ (Loc, Typ, Decl, Pnam, New_List (Stm), Outp => Nam = Name_Read);
end Build_Array_Read_Write_Procedure;
---------------------------------
@@ -569,6 +569,9 @@ package body Exp_Strm is
elsif P_Size <= Standard_Short_Integer_Size then
Lib_RE := RE_I_SI;
+ elsif P_Size = 24 then
+ Lib_RE := RE_I_I24;
+
elsif P_Size <= Standard_Integer_Size then
Lib_RE := RE_I_I;
@@ -597,6 +600,9 @@ package body Exp_Strm is
elsif P_Size <= Standard_Short_Integer_Size then
Lib_RE := RE_I_SU;
+ elsif P_Size = 24 then
+ Lib_RE := RE_I_U24;
+
elsif P_Size <= Standard_Integer_Size then
Lib_RE := RE_I_U;
@@ -798,6 +804,8 @@ package body Exp_Strm is
Lib_RE := RE_W_SSI;
elsif P_Size <= Standard_Short_Integer_Size then
Lib_RE := RE_W_SI;
+ elsif P_Size = 24 then
+ Lib_RE := RE_W_I24;
elsif P_Size <= Standard_Integer_Size then
Lib_RE := RE_W_I;
elsif P_Size <= Standard_Long_Integer_Size then
@@ -822,6 +830,8 @@ package body Exp_Strm is
Lib_RE := RE_W_SSU;
elsif P_Size <= Standard_Short_Integer_Size then
Lib_RE := RE_W_SU;
+ elsif P_Size = 24 then
+ Lib_RE := RE_W_U24;
elsif P_Size <= Standard_Integer_Size then
Lib_RE := RE_W_U;
elsif P_Size <= Standard_Long_Integer_Size then
@@ -1119,25 +1129,20 @@ package body Exp_Strm is
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
- Fnam : out Entity_Id;
- Use_Underlying : Boolean := True)
+ Fnam : out Entity_Id)
is
- B_Typ : Entity_Id := Base_Type (Typ);
+ B_Typ : constant Entity_Id := Underlying_Type (Base_Type (Typ));
Cn : Name_Id;
Constr : List_Id;
Decls : List_Id;
Discr : Entity_Id;
- Discr_Elmt : Elmt_Id := No_Elmt;
+ Discr_Elmt : Elmt_Id := No_Elmt;
J : Pos;
Obj_Decl : Node_Id;
Odef : Node_Id;
Stms : List_Id;
begin
- if Use_Underlying then
- B_Typ := Underlying_Type (B_Typ);
- end if;
-
Decls := New_List;
Constr := New_List;
@@ -1325,7 +1330,7 @@ package body Exp_Strm is
Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output);
- Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
+ Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => False);
end Build_Record_Or_Elementary_Output_Procedure;
---------------------------------
@@ -1590,7 +1595,7 @@ package body Exp_Strm is
end if;
Build_Stream_Procedure
- (Loc, Typ, Decl, Pnam, Stms, Nam = Name_Read);
+ (Loc, Typ, Decl, Pnam, Stms, Outp => Nam = Name_Read);
end Build_Record_Read_Write_Procedure;
----------------------------------
diff --git a/gcc/ada/exp_strm.ads b/gcc/ada/exp_strm.ads
index 0c9b8a1..d77d756 100644
--- a/gcc/ada/exp_strm.ads
+++ b/gcc/ada/exp_strm.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -108,14 +108,11 @@ package Exp_Strm is
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
- Fnam : out Entity_Id;
- Use_Underlying : Boolean := True);
+ Fnam : out Entity_Id);
-- Build function for Input attribute for record type or for an elementary
-- type (the latter is used only in the case where a user-defined Read
-- routine is defined, since, in other cases, Input calls the appropriate
- -- runtime library routine directly). The flag Use_Underlying controls
- -- whether the base type or the underlying type of the base type of Typ is
- -- used during construction.
+ -- runtime library routine directly).
procedure Build_Record_Or_Elementary_Output_Procedure
(Loc : Source_Ptr;
diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb
index 8ef05e2..b640843 100644
--- a/gcc/ada/exp_tss.adb
+++ b/gcc/ada/exp_tss.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -147,27 +147,29 @@ package body Exp_Tss is
(Typ : Entity_Id;
Nam : TSS_Name_Type) return Entity_Id
is
- Btyp : Entity_Id := Typ;
+ Btyp : Entity_Id;
Proc : Entity_Id;
begin
- loop
- Btyp := Base_Type (Btyp);
- Proc := TSS (Btyp, Nam);
+ -- If Typ is a private type, look at the full view
- exit when Present (Proc)
- or else not Is_Derived_Type (Btyp);
+ if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
+ Btyp := Base_Type (Full_View (Typ));
+ else
+ Btyp := Base_Type (Typ);
+ end if;
- -- If Typ is a derived type, it may inherit attributes from some
- -- ancestor.
+ Proc := TSS (Btyp, Nam);
- Btyp := Etype (Btyp);
- end loop;
+ -- If Typ is a derived type, it may inherit attributes from an ancestor
- if No (Proc) then
+ if No (Proc) and then Is_Derived_Type (Btyp) then
+ Proc := Find_Inherited_TSS (Etype (Btyp), Nam);
+ end if;
- -- If nothing else, use the TSS of the root type
+ -- If nothing else, use the TSS of the root type
+ if No (Proc) then
Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam);
end if;
@@ -289,12 +291,12 @@ package body Exp_Tss is
then
exit;
- elsif Ekind_In (Etype (E1),
- E_Anonymous_Access_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type)
- and then Ekind_In (Etype (E2),
- E_Anonymous_Access_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type)
+ elsif Ekind (Etype (E1)) in
+ E_Anonymous_Access_Subprogram_Type |
+ E_Anonymous_Access_Protected_Subprogram_Type
+ and then Ekind (Etype (E2)) in
+ E_Anonymous_Access_Subprogram_Type |
+ E_Anonymous_Access_Protected_Subprogram_Type
and then not Conforming_Types
(Etype (E1), Etype (E2), Fully_Conformant)
then
diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads
index 91c0c67..59234ff 100644
--- a/gcc/ada/exp_tss.ads
+++ b/gcc/ada/exp_tss.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -94,6 +94,7 @@ package Exp_Tss is
TSS_Stream_Output : constant TNT := "SO"; -- Stream Output attribute
TSS_Stream_Read : constant TNT := "SR"; -- Stream Read attribute
TSS_Stream_Write : constant TNT := "SW"; -- Stream Write attribute
+ TSS_Put_Image : constant TNT := "PI"; -- Put_Image attribute
TSS_To_Any : constant TNT := "TA"; -- PolyORB/DSA To_Any
TSS_TypeCode : constant TNT := "TC"; -- PolyORB/DSA TypeCode
@@ -116,6 +117,7 @@ package Exp_Tss is
TSS_Stream_Output,
TSS_Stream_Read,
TSS_Stream_Write,
+ TSS_Put_Image,
TSS_To_Any,
TSS_TypeCode);
@@ -168,12 +170,9 @@ package Exp_Tss is
-- be explicitly frozen, so the N_Freeze_Entity node always exists).
function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id;
- -- Finds the TSS with the given name associated with the given type
- -- If no such TSS exists, then Empty is returned;
-
function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id;
- -- Finds the TSS with the given name associated with the given type. If
- -- no such TSS exists, then Empty is returned.
+ -- Finds the TSS with the given name associated with the given type.
+ -- If no such TSS exists, then Empty is returned.
function Same_TSS (E1, E2 : Entity_Id) return Boolean;
-- Returns True if E1 and E2 are the same kind of TSS, even if the names
diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb
index 1747281..29fe2e5 100644
--- a/gcc/ada/exp_unst.adb
+++ b/gcc/ada/exp_unst.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -251,18 +251,14 @@ package body Exp_Unst is
-----------------------
function Needs_Fat_Pointer (E : Entity_Id) return Boolean is
- Typ : Entity_Id;
- begin
- if Is_Formal (E) then
- Typ := Etype (E);
- if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
- Typ := Full_View (Typ);
- end if;
+ Typ : Entity_Id := Etype (E);
- return Is_Array_Type (Typ) and then not Is_Constrained (Typ);
- else
- return False;
+ begin
+ if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
+ Typ := Full_View (Typ);
end if;
+
+ return Is_Array_Type (Typ) and then not Is_Constrained (Typ);
end Needs_Fat_Pointer;
----------------
@@ -282,7 +278,7 @@ package body Exp_Unst is
-- has been scanned at this point, and thus has an entry in the
-- subprogram table.
- if E = Sub and then Convention (E) = Convention_Protected then
+ if E = Sub and then Present (Protected_Body_Subprogram (E)) then
E := Protected_Body_Subprogram (E);
end if;
@@ -550,8 +546,8 @@ package body Exp_Unst is
-- Attribute or indexed component case
- elsif Nkind_In (N, N_Attribute_Reference,
- N_Indexed_Component)
+ elsif Nkind (N) in
+ N_Attribute_Reference | N_Indexed_Component
then
Note_Uplevel_Bound (Prefix (N), Ref);
@@ -605,8 +601,8 @@ package body Exp_Unst is
-- Explicit dereference and selected component case
- elsif Nkind_In (N, N_Explicit_Dereference,
- N_Selected_Component)
+ elsif Nkind (N) in
+ N_Explicit_Dereference | N_Selected_Component
then
Note_Uplevel_Bound (Prefix (N), Ref);
@@ -790,7 +786,7 @@ package body Exp_Unst is
then
return;
- elsif Ekind_In (Callee, E_Entry, E_Entry_Family) then
+ elsif Ekind (Callee) in E_Entry | E_Entry_Family then
return;
end if;
@@ -841,9 +837,13 @@ package body Exp_Unst is
-- If we marked this reachable because it's in a synchronized
-- unit, we have to mark all enclosing subprograms as reachable
- -- as well.
+ -- as well. We do the same for subprograms with Address_Taken,
+ -- because otherwise we can run into problems with looking at
+ -- enclosing subprograms in Subps.Table due to their being
+ -- unreachable (the Subp_Index of unreachable subps is later
+ -- set to zero and their entry in Subps.Table is removed).
- if In_Synchronized_Unit (E) then
+ if In_Synchronized_Unit (E) or else Address_Taken (E) then
declare
S : Entity_Id := E;
@@ -1042,18 +1042,30 @@ package body Exp_Unst is
-- handled during full traversal. Note that if the
-- nominal subtype of the prefix is unconstrained,
-- the bound must be obtained from the object, not
- -- from the (possibly) uplevel reference.
+ -- from the (possibly) uplevel reference. We call
+ -- Get_Referenced_Object to deal with prefixes that
+ -- are object renamings (prefixes that are types
+ -- can be passed and will simply be returned). But
+ -- it's also legal to get the bounds from the type
+ -- of the prefix, so we have to handle both cases.
- if Is_Constrained (Etype (Prefix (N))) then
- declare
- DT : Boolean := False;
- begin
+ declare
+ DT : Boolean := False;
+
+ begin
+ if Is_Constrained
+ (Etype (Get_Referenced_Object (Prefix (N))))
+ then
Check_Static_Type
- (Etype (Prefix (N)), Empty, DT);
- end;
+ (Etype (Get_Referenced_Object (Prefix (N))),
+ Empty, DT);
+ end if;
- return OK;
- end if;
+ if Is_Constrained (Etype (Prefix (N))) then
+ Check_Static_Type
+ (Etype (Prefix (N)), Empty, DT);
+ end if;
+ end;
when others =>
null;
@@ -1259,9 +1271,9 @@ package body Exp_Unst is
-- references to global declarations.
and then
- (Ekind_In (Ent, E_Constant,
- E_Loop_Parameter,
- E_Variable)
+ (Ekind (Ent) in E_Constant
+ | E_Loop_Parameter
+ | E_Variable
-- Formals are interesting, but not if being used
-- as mere names of parameters for name notation
@@ -2068,7 +2080,7 @@ package body Exp_Unst is
-- or else 'Access for unconstrained array
if Needs_Fat_Pointer (Ent) then
- Attr := Name_Access;
+ Attr := Name_Unchecked_Access;
else
Attr := Name_Address;
end if;
@@ -2093,7 +2105,7 @@ package body Exp_Unst is
Comp := First_Component (STJ.ARECnT);
while Chars (Comp) /= Chars (Ent) loop
- Comp := Next_Component (Comp);
+ Next_Component (Comp);
end loop;
Rhs :=
@@ -2119,9 +2131,9 @@ package body Exp_Unst is
-- N_Loop_Parameter_Specification or to
-- an N_Iterator_Specification.
- if Nkind_In
- (Ins, N_Iterator_Specification,
- N_Loop_Parameter_Specification)
+ if Nkind (Ins) in
+ N_Iterator_Specification |
+ N_Loop_Parameter_Specification
then
-- Quantified expression are rewritten as
-- loops during expansion.
@@ -2354,9 +2366,8 @@ package body Exp_Unst is
-- processing this dereference
if Opt.Modify_Tree_For_C
- and then Nkind_In (Parent (UPJ.Ref),
- N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ and then Nkind (Parent (UPJ.Ref)) in
+ N_Type_Conversion | N_Unchecked_Type_Conversion
then
Force_Evaluation (UPJ.Ref, Mode => Strict);
end if;
@@ -2542,7 +2553,7 @@ package body Exp_Unst is
function Search_Subprograms (N : Node_Id) return Traverse_Result is
begin
- if Nkind_In (N, N_Subprogram_Body, N_Subprogram_Body_Stub) then
+ if Nkind (N) in N_Subprogram_Body | N_Subprogram_Body_Stub then
declare
Spec_Id : constant Entity_Id := Unique_Defining_Entity (N);
diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads
index a9077b2..c7cc6cb 100644
--- a/gcc/ada/exp_unst.ads
+++ b/gcc/ada/exp_unst.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 7bd90e7..0f8505f 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -224,6 +224,10 @@ package body Exp_Util is
-- level, and False otherwise. Nested_Constructs is True when any nested
-- packages declared in L must be processed, and False otherwise.
+ function Side_Effect_Free_Attribute (Name : Name_Id) return Boolean;
+ -- Return True if the evaluation of the given attribute is considered
+ -- side-effect free, independently of its prefix and expressions.
+
-------------------------------------
-- Activate_Atomic_Synchronization --
-------------------------------------
@@ -1292,6 +1296,7 @@ package body Exp_Util is
-- of the type. In the case of an inherited condition for an
-- overriding operation, both the operation and the function
-- are given by primitive wrappers.
+ -- Move this check to sem???
if Ekind (New_E) = E_Function
and then Is_Primitive_Wrapper (New_E)
@@ -1322,6 +1327,7 @@ package body Exp_Util is
-- Check that there are no calls left to abstract operations if
-- the current subprogram is not abstract.
+ -- Move this check to sem???
if Nkind (Parent (N)) = N_Function_Call
and then N = Name (Parent (N))
@@ -1634,43 +1640,6 @@ package body Exp_Util is
DIC_Proc : constant Entity_Id := DIC_Procedure (DIC_Typ);
Obj_Id : constant Entity_Id := First_Formal (DIC_Proc);
- procedure Preanalyze_Own_DIC_For_ASIS;
- -- Preanalyze the original DIC expression of an aspect or a source
- -- pragma for ASIS.
-
- ---------------------------------
- -- Preanalyze_Own_DIC_For_ASIS --
- ---------------------------------
-
- procedure Preanalyze_Own_DIC_For_ASIS is
- Expr : Node_Id := Empty;
-
- begin
- -- The DIC pragma is a source construct, preanalyze the original
- -- expression of the pragma.
-
- if Comes_From_Source (DIC_Prag) then
- Expr := DIC_Expr;
-
- -- Otherwise preanalyze the expression of the corresponding aspect
-
- elsif Present (DIC_Asp) then
- Expr := Expression (DIC_Asp);
- end if;
-
- -- The expression must be subjected to the same substitutions as
- -- the copy used in the generation of the runtime check.
-
- if Present (Expr) then
- Replace_Type_References
- (Expr => Expr,
- Typ => DIC_Typ,
- Obj_Id => Obj_Id);
-
- Preanalyze_Assert_Expression (Expr, Any_Boolean);
- end if;
- end Preanalyze_Own_DIC_For_ASIS;
-
-- Local variables
Typ_Decl : constant Node_Id := Declaration_Node (DIC_Typ);
@@ -1717,12 +1686,6 @@ package body Exp_Util is
Set_Entity (Identifier (DIC_Asp), New_Copy_Tree (Expr));
end if;
- -- Preanalyze the original DIC expression for ASIS
-
- if ASIS_Mode then
- Preanalyze_Own_DIC_For_ASIS;
- end if;
-
-- Once the DIC assertion expression is fully processed, add a check
-- to the statements of the DIC procedure.
@@ -1951,11 +1914,11 @@ package body Exp_Util is
Set_Corresponding_Spec (Proc_Body, Proc_Id);
-- The body should not be inserted into the tree when the context
- -- is ASIS or a generic unit because it is not part of the template.
+ -- is a generic unit because it is not part of the template.
-- Note that the body must still be generated in order to resolve the
-- DIC assertion expression.
- if ASIS_Mode or Inside_A_Generic then
+ if Inside_A_Generic then
null;
-- Semi-insert the body into the tree for GNATprove by setting its
@@ -2000,9 +1963,6 @@ package body Exp_Util is
CRec_Typ : Entity_Id;
-- The corresponding record type of Full_Typ
- Full_Base : Entity_Id;
- -- The base type of Full_Typ
-
Full_Typ : Entity_Id;
-- The full view of working type
@@ -2012,6 +1972,9 @@ package body Exp_Util is
Priv_Typ : Entity_Id;
-- The partial view of working type
+ UFull_Typ : Entity_Id;
+ -- The underlying full view of Full_Typ
+
Work_Typ : Entity_Id;
-- The working type
@@ -2102,13 +2065,13 @@ package body Exp_Util is
-- Obtain all views of the input type
- Get_Views (Work_Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
+ Get_Views (Work_Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ);
- -- Associate the DIC procedure and various relevant flags with all views
+ -- Associate the DIC procedure and various flags with all views
Propagate_DIC_Attributes (Priv_Typ, From_Typ => Work_Typ);
Propagate_DIC_Attributes (Full_Typ, From_Typ => Work_Typ);
- Propagate_DIC_Attributes (Full_Base, From_Typ => Work_Typ);
+ Propagate_DIC_Attributes (UFull_Typ, From_Typ => Work_Typ);
Propagate_DIC_Attributes (CRec_Typ, From_Typ => Work_Typ);
-- The declaration of the DIC procedure must be inserted after the
@@ -2158,9 +2121,9 @@ package body Exp_Util is
New_Occurrence_Of (Work_Typ, Loc)))));
-- The declaration should not be inserted into the tree when the context
- -- is ASIS or a generic unit because it is not part of the template.
+ -- is a generic unit because it is not part of the template.
- if ASIS_Mode or Inside_A_Generic then
+ if Inside_A_Generic then
null;
-- Semi-insert the declaration into the tree for GNATprove by setting
@@ -2335,9 +2298,8 @@ package body Exp_Util is
-- Generate:
-- <Comp_Typ>Invariant (_object (<Indices>));
- -- Note that the invariant procedure may have a null body if
- -- assertions are disabled or Assertion_Policy Ignore is in
- -- effect.
+ -- The invariant procedure has a null body if assertions are
+ -- disabled or Assertion_Policy Ignore is in effect.
if not Has_Null_Body (Proc_Id) then
Append_New_To (Comp_Checks,
@@ -2775,7 +2737,6 @@ package body Exp_Util is
Checks : in out List_Id;
Priv_Item : Node_Id := Empty)
is
- ASIS_Expr : Node_Id;
Expr : Node_Id;
Prag : Node_Id;
Prag_Asp : Node_Id;
@@ -2854,23 +2815,6 @@ package body Exp_Util is
Set_Entity (Identifier (Prag_Asp), New_Copy_Tree (Expr));
end if;
- -- Analyze the original invariant expression for ASIS
-
- if ASIS_Mode then
- ASIS_Expr := Empty;
-
- if Comes_From_Source (Prag) then
- ASIS_Expr := Prag_Expr;
- elsif Present (Prag_Asp) then
- ASIS_Expr := Expression (Prag_Asp);
- end if;
-
- if Present (ASIS_Expr) then
- Replace_Type_References (ASIS_Expr, T, Obj_Id);
- Preanalyze_Assert_Expression (ASIS_Expr, Any_Boolean);
- end if;
- end if;
-
Add_Invariant_Check (Prag, Expr, Checks);
end if;
@@ -3069,7 +3013,7 @@ package body Exp_Util is
if Produced_Component_Check and then Has_Unchecked_Union (T) then
Error_Msg_NE
("invariants cannot be checked on components of "
- & "unchecked_union type &?", Comp_Id, T);
+ & "unchecked_union type &??", Comp_Id, T);
end if;
end Process_Record_Component;
@@ -3144,11 +3088,18 @@ package body Exp_Util is
begin
Work_Typ := Typ;
+ -- Do not process the underlying full view of a private type. There is
+ -- no way to get back to the partial view, plus the body will be built
+ -- by the full view or the base type.
+
+ if Is_Underlying_Full_View (Work_Typ) then
+ return;
+
-- The input type denotes the implementation base type of a constrained
-- array type. Work with the first subtype as all invariant pragmas are
-- on its rep item chain.
- if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
+ elsif Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
Work_Typ := First_Subtype (Work_Typ);
-- The input type denotes the corresponding record type of a protected
@@ -3428,11 +3379,11 @@ package body Exp_Util is
Set_Corresponding_Spec (Proc_Body, Proc_Id);
-- The body should not be inserted into the tree when the context is
- -- ASIS or a generic unit because it is not part of the template. Note
+ -- a generic unit because it is not part of the template. Note
-- that the body must still be generated in order to resolve the
-- invariants.
- if ASIS_Mode or Inside_A_Generic then
+ if Inside_A_Generic then
null;
-- Semi-insert the body into the tree for GNATprove by setting its
@@ -3477,9 +3428,6 @@ package body Exp_Util is
CRec_Typ : Entity_Id;
-- The corresponding record type of Full_Typ
- Full_Base : Entity_Id;
- -- The base type of Full_Typ
-
Full_Typ : Entity_Id;
-- The full view of working type
@@ -3492,6 +3440,9 @@ package body Exp_Util is
Priv_Typ : Entity_Id;
-- The partial view of working type
+ UFull_Typ : Entity_Id;
+ -- The underlying full view of Full_Typ
+
Work_Typ : Entity_Id;
-- The working type
@@ -3577,13 +3528,13 @@ package body Exp_Util is
-- Obtain all views of the input type
- Get_Views (Work_Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
+ Get_Views (Work_Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ);
- -- Associate the invariant procedure with all views
+ -- Associate the invariant procedure and various flags with all views
Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Work_Typ);
Propagate_Invariant_Attributes (Full_Typ, From_Typ => Work_Typ);
- Propagate_Invariant_Attributes (Full_Base, From_Typ => Work_Typ);
+ Propagate_Invariant_Attributes (UFull_Typ, From_Typ => Work_Typ);
Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Work_Typ);
-- The declaration of the invariant procedure is inserted after the
@@ -3663,9 +3614,9 @@ package body Exp_Util is
Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)))));
-- The declaration should not be inserted into the tree when the context
- -- is ASIS or a generic unit because it is not part of the template.
+ -- is a generic unit because it is not part of the template.
- if ASIS_Mode or Inside_A_Generic then
+ if Inside_A_Generic then
null;
-- Semi-insert the declaration into the tree for GNATprove by setting
@@ -4967,11 +4918,16 @@ package body Exp_Util is
procedure Evaluate_Name (Nam : Node_Id) is
begin
- -- For an attribute reference or an indexed component, evaluate the
- -- prefix, which is itself a name, recursively, and then force the
- -- evaluation of all the subscripts (or attribute expressions).
-
case Nkind (Nam) is
+ -- For an aggregate, force its evaluation
+
+ when N_Aggregate =>
+ Force_Evaluation (Nam);
+
+ -- For an attribute reference or an indexed component, evaluate the
+ -- prefix, which is itself a name, recursively, and then force the
+ -- evaluation of all the subscripts (or attribute expressions).
+
when N_Attribute_Reference
| N_Indexed_Component
=>
@@ -5002,21 +4958,17 @@ package body Exp_Util is
when N_Explicit_Dereference =>
Force_Evaluation (Prefix (Nam));
- -- For a function call, we evaluate the call
+ -- For a function call, we evaluate the call; same for an operator
- when N_Function_Call =>
+ when N_Function_Call
+ | N_Op
+ =>
Force_Evaluation (Nam);
- -- For a qualified expression, we evaluate the underlying object
- -- name if any, otherwise we force the evaluation of the underlying
- -- expression.
+ -- For a qualified expression, we evaluate the expression
when N_Qualified_Expression =>
- if Is_Object_Reference (Expression (Nam)) then
- Evaluate_Name (Expression (Nam));
- else
- Force_Evaluation (Expression (Nam));
- end if;
+ Evaluate_Name (Expression (Nam));
-- For a selected component, we simply evaluate the prefix
@@ -5038,9 +4990,11 @@ package body Exp_Util is
when N_Type_Conversion =>
Evaluate_Name (Expression (Nam));
- -- The remaining cases are direct name, operator symbol and character
- -- literal. In all these cases, we do nothing, since we want to
- -- reevaluate each time the renamed object is used.
+ -- The remaining cases are direct name and character literal. In all
+ -- these cases, we do nothing, since we want to reevaluate each time
+ -- the renamed object is used. ??? There are more remaining cases, at
+ -- least in the GNATprove_Mode, where this routine is called in more
+ -- contexts than in GNAT.
when others =>
null;
@@ -5110,7 +5064,7 @@ package body Exp_Util is
-----------------------------------------
procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is
- pragma Assert (Nkind_In (N, N_Case_Statement_Alternative, N_Variant));
+ pragma Assert (Nkind (N) in N_Case_Statement_Alternative | N_Variant);
Choices : constant List_Id := Discrete_Choices (N);
@@ -5888,7 +5842,7 @@ package body Exp_Util is
begin
S := Scop;
while Present (S) loop
- if Ekind_In (S, E_Entry, E_Entry_Family, E_Function, E_Procedure)
+ if Ekind (S) in E_Entry | E_Entry_Family | E_Function | E_Procedure
and then Present (Protection_Object (S))
then
return Protection_Object (S);
@@ -5966,8 +5920,8 @@ package body Exp_Util is
Par := N;
Top := N;
while Present (Par) loop
- if Nkind_In (Original_Node (Par), N_Case_Expression,
- N_If_Expression)
+ if Nkind (Original_Node (Par)) in
+ N_Case_Expression | N_If_Expression
then
Top := Par;
@@ -5988,13 +5942,13 @@ package body Exp_Util is
Par := Top;
while Present (Par) loop
if Is_List_Member (Par)
- and then not Nkind_In (Par, N_Component_Association,
- N_Discriminant_Association,
- N_Parameter_Association,
- N_Pragma_Argument_Association)
- and then not Nkind_In (Parent (Par), N_Function_Call,
- N_Procedure_Call_Statement,
- N_Entry_Call_Statement)
+ and then Nkind (Par) not in N_Component_Association
+ | N_Discriminant_Association
+ | N_Parameter_Association
+ | N_Pragma_Argument_Association
+ and then Nkind (Parent (Par)) not in N_Function_Call
+ | N_Procedure_Call_Statement
+ | N_Entry_Call_Statement
then
return Par;
@@ -6017,7 +5971,7 @@ package body Exp_Util is
-- Keep climbing past various operators
if Nkind (Parent (Par)) in N_Op
- or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else)
+ or else Nkind (Parent (Par)) in N_And_Then | N_Or_Else
then
Par := Parent (Par);
else
@@ -6055,11 +6009,11 @@ package body Exp_Util is
while Present (Par) loop
if Par = Wrapped_Node
- or else Nkind_In (Par, N_Assignment_Statement,
- N_Object_Declaration,
- N_Pragma,
- N_Procedure_Call_Statement,
- N_Simple_Return_Statement)
+ or else Nkind (Par) in N_Assignment_Statement
+ | N_Object_Declaration
+ | N_Pragma
+ | N_Procedure_Call_Statement
+ | N_Simple_Return_Statement
then
return Par;
@@ -6322,10 +6276,9 @@ package body Exp_Util is
-- Deal with conversions, qualifications, and expressions with
-- actions.
- while Nkind_In (Cond,
- N_Type_Conversion,
- N_Qualified_Expression,
- N_Expression_With_Actions)
+ while Nkind (Cond) in N_Type_Conversion
+ | N_Qualified_Expression
+ | N_Expression_With_Actions
loop
Cond := Expression (Cond);
end loop;
@@ -6335,7 +6288,7 @@ package body Exp_Util is
-- Deal with AND THEN and AND cases
- if Nkind_In (Cond, N_And_Then, N_Op_And) then
+ if Nkind (Cond) in N_And_Then | N_Op_And then
-- Don't ever try to invert a condition that is of the form of an
-- AND or AND THEN (since we are not doing sufficiently general
@@ -6411,10 +6364,9 @@ package body Exp_Util is
return;
- elsif Nkind_In (Cond,
- N_Type_Conversion,
- N_Qualified_Expression,
- N_Expression_With_Actions)
+ elsif Nkind (Cond) in N_Type_Conversion
+ | N_Qualified_Expression
+ | N_Expression_With_Actions
then
Cond := Expression (Cond);
@@ -6442,7 +6394,7 @@ package body Exp_Util is
-- Immediate return, nothing doing, if this is not an object
- if Ekind (Ent) not in Object_Kind then
+ if not Is_Object (Ent) then
return;
end if;
@@ -6464,7 +6416,7 @@ package body Exp_Util is
if Loc < Sloc (CV) then
return;
- -- After end of IF statement
+ -- After end of IF statement
elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
return;
@@ -6632,6 +6584,35 @@ package body Exp_Util is
end;
end Get_Current_Value_Condition;
+ -----------------------
+ -- Get_Index_Subtype --
+ -----------------------
+
+ function Get_Index_Subtype (N : Node_Id) return Node_Id is
+ P_Type : Entity_Id := Etype (Prefix (N));
+ Indx : Node_Id;
+ J : Int;
+
+ begin
+ if Is_Access_Type (P_Type) then
+ P_Type := Designated_Type (P_Type);
+ end if;
+
+ if No (Expressions (N)) then
+ J := 1;
+ else
+ J := UI_To_Int (Expr_Value (First (Expressions (N))));
+ end if;
+
+ Indx := First_Index (P_Type);
+ while J > 1 loop
+ Next_Index (Indx);
+ J := J - 1;
+ end loop;
+
+ return Etype (Indx);
+ end Get_Index_Subtype;
+
---------------------
-- Get_Stream_Size --
---------------------
@@ -7282,7 +7263,7 @@ package body Exp_Util is
-- actions should be inserted outside the complete record
-- declaration.
- elsif Nkind_In (Parent (P), N_Variant, N_Record_Definition) then
+ elsif Nkind (Parent (P)) in N_Variant | N_Record_Definition then
null;
-- Do not insert freeze nodes within the loop generated for
@@ -7363,6 +7344,7 @@ package body Exp_Util is
when N_Component_Association
| N_Iterated_Component_Association
+ | N_Iterated_Element_Association
=>
if Nkind (Parent (P)) = N_Aggregate
and then Present (Loop_Actions (P))
@@ -7669,8 +7651,8 @@ package body Exp_Util is
P := Parent (P);
if Is_List_Member (P) then
- exit when Nkind_In (Parent (P), N_Package_Specification,
- N_Subprogram_Body);
+ exit when Nkind (Parent (P)) in
+ N_Package_Specification | N_Subprogram_Body;
-- Special handling for handled sequence of statements, we must
-- insert in the statements not the exception handlers!
@@ -7890,8 +7872,8 @@ package body Exp_Util is
if Nkind (Result) = N_Explicit_Dereference then
Result := Prefix (Result);
- elsif Nkind_In (Result, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ elsif Nkind (Result) in
+ N_Type_Conversion | N_Unchecked_Type_Conversion
then
Result := Expression (Result);
@@ -8141,7 +8123,7 @@ package body Exp_Util is
if Nkind (N) = N_Identifier
and then Present (Entity (N))
- and then Ekind_In (Entity (N), E_Constant, E_Variable)
+ and then Ekind (Entity (N)) in E_Constant | E_Variable
then
Ren_Obj := Entity (N);
return Abandon;
@@ -8348,7 +8330,7 @@ package body Exp_Util is
end if;
return
- Ekind_In (Obj_Id, E_Constant, E_Variable)
+ Ekind (Obj_Id) in E_Constant | E_Variable
and then Needs_Finalization (Desig)
and then Requires_Transient_Scope (Desig)
and then Nkind (Rel_Node) /= N_Simple_Return_Statement
@@ -8774,7 +8756,7 @@ package body Exp_Util is
return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
end if;
- if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
+ if Nkind (N) in N_Indexed_Component | N_Selected_Component then
if Is_Bit_Packed_Array (Etype (Prefix (N))) then
Result := True;
else
@@ -8816,7 +8798,7 @@ package body Exp_Util is
then
return True;
- elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
+ elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
else
@@ -8834,7 +8816,7 @@ package body Exp_Util is
begin
if Kind = N_Object_Renaming_Declaration then
return True;
- elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then
+ elsif Kind in N_Indexed_Component | N_Selected_Component then
return Is_Renamed_Object (Pnod);
else
return False;
@@ -8846,7 +8828,6 @@ package body Exp_Util is
--------------------------------------
function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
- Alloc_Nam : Name_Id := No_Name;
Actual : Node_Id;
Call : Node_Id := Expr;
Formal : Node_Id;
@@ -8873,20 +8854,10 @@ package body Exp_Util is
Formal := Selector_Name (Param);
Actual := Explicit_Actual_Parameter (Param);
- -- Construct the name of formal BIPalloc. It is much easier to
- -- extract the name of the function using an arbitrary formal's
- -- scope rather than the Name field of Call.
-
- if Alloc_Nam = No_Name and then Present (Entity (Formal)) then
- Alloc_Nam :=
- New_External_Name
- (Chars (Scope (Entity (Formal))),
- BIP_Formal_Suffix (BIP_Alloc_Form));
- end if;
-
-- A match for BIPalloc => 2 has been found
- if Chars (Formal) = Alloc_Nam
+ if Is_Build_In_Place_Entity (Formal)
+ and then BIP_Suffix_Kind (Formal) = BIP_Alloc_Form
and then Nkind (Actual) = N_Integer_Literal
and then Intval (Actual) = Uint_2
then
@@ -9003,7 +8974,7 @@ package body Exp_Util is
-- True if volatile component
- elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
+ elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
if (Is_Entity_Name (Prefix (N))
and then Has_Volatile_Components (Entity (Prefix (N))))
or else (Present (Etype (Prefix (N)))
@@ -9379,18 +9350,15 @@ package body Exp_Util is
function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Expr);
Typ : constant Entity_Id := Base_Type (Etype (Expr));
-
- Proc_Id : Entity_Id;
-
- begin
pragma Assert (Has_Invariants (Typ));
-
- Proc_Id := Invariant_Procedure (Typ);
+ Proc_Id : constant Entity_Id := Invariant_Procedure (Typ);
pragma Assert (Present (Proc_Id));
+ begin
+ -- The invariant procedure has a null body if assertions are disabled or
+ -- Assertion_Policy Ignore is in effect. In that case, generate a null
+ -- statement instead of a call to the invariant procedure.
- -- Ignore the invariant if that policy is in effect
-
- if Invariants_Ignored (Typ) then
+ if Has_Null_Body (Proc_Id) then
return Make_Null_Statement (Loc);
else
return
@@ -9606,7 +9574,7 @@ package body Exp_Util is
(Next (First (Pragma_Argument_Associations (Item))));
end if;
- Item := Next_Rep_Item (Item);
+ Next_Rep_Item (Item);
end loop;
return Empty;
@@ -9666,11 +9634,6 @@ package body Exp_Util is
procedure Replace_Subtype_Reference (N : Node_Id) is
begin
Rewrite (N, New_Copy_Tree (Expr));
-
- -- We want to treat the node as if it comes from source, so that
- -- ASIS will not ignore it.
-
- Set_Comes_From_Source (N, True);
end Replace_Subtype_Reference;
procedure Replace_Subtype_References is
@@ -9717,10 +9680,9 @@ package body Exp_Util is
return Make_Null_Statement (Loc);
end if;
- -- Do not generate a check within an internal subprogram (stream
- -- functions and the like, including predicate functions).
+ -- Do not generate a check within stream functions and the like.
- if Within_Internal_Subprogram then
+ if not Predicate_Check_In_Scope (Expr) then
return Make_Null_Statement (Loc);
end if;
@@ -9896,7 +9858,7 @@ package body Exp_Util is
Low_Bound => New_Occurrence_Of (Low_Bound, Loc),
High_Bound => New_Occurrence_Of (High_Bound, Loc)));
- Index_Typ := Next_Index (Index_Typ);
+ Next_Index (Index_Typ);
end loop;
elsif Is_Class_Wide_Type (Unc_Typ) then
@@ -11041,7 +11003,7 @@ package body Exp_Util is
=>
-- Check the "then statements" for elsif parts and if statements
- if Nkind_In (N, N_Elsif_Part, N_If_Statement)
+ if Nkind (N) in N_Elsif_Part | N_If_Statement
and then not Is_Empty_List (Then_Statements (N))
and then not Are_Wrapped (Then_Statements (N))
and then Requires_Cleanup_Actions
@@ -11058,9 +11020,8 @@ package body Exp_Util is
-- Check the "else statements" for conditional entry calls, if
-- statements and selective accepts.
- if Nkind_In (N, N_Conditional_Entry_Call,
- N_If_Statement,
- N_Selective_Accept)
+ if Nkind (N) in
+ N_Conditional_Entry_Call | N_If_Statement | N_Selective_Accept
and then not Is_Empty_List (Else_Statements (N))
and then not Are_Wrapped (Else_Statements (N))
and then Requires_Cleanup_Actions
@@ -11372,6 +11333,21 @@ package body Exp_Util is
Scope_Suppress.Suppress := (others => True);
+ -- If this is a side-effect free attribute reference whose expressions
+ -- are also side-effect free and whose prefix is not a name, remove the
+ -- side effects of the prefix. A copy of the prefix is required in this
+ -- case and it is better not to make an additional one for the attribute
+ -- itself, because the return type of many of them is universal integer,
+ -- which is a very large type for a temporary.
+
+ if Nkind (Exp) = N_Attribute_Reference
+ and then Side_Effect_Free_Attribute (Attribute_Name (Exp))
+ and then Side_Effect_Free (Expressions (Exp), Name_Req, Variable_Ref)
+ and then not Is_Name_Reference (Prefix (Exp))
+ then
+ Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
+ goto Leave;
+
-- If this is an elementary or a small not-by-reference record type, and
-- we need to capture the value, just make a constant; this is cheap and
-- objects of both kinds of types can be bit aligned, so it might not be
@@ -11382,12 +11358,12 @@ package body Exp_Util is
-- anyway, see below). Also do it if we have a volatile reference and
-- Name_Req is not set (see comments for Side_Effect_Free).
- if (Is_Elementary_Type (Exp_Type)
- or else (Is_Record_Type (Exp_Type)
- and then Known_Static_RM_Size (Exp_Type)
- and then RM_Size (Exp_Type) <= 64
- and then not Has_Discriminants (Exp_Type)
- and then not Is_By_Reference_Type (Exp_Type)))
+ elsif (Is_Elementary_Type (Exp_Type)
+ or else (Is_Record_Type (Exp_Type)
+ and then Known_Static_RM_Size (Exp_Type)
+ and then RM_Size (Exp_Type) <= 64
+ and then not Has_Discriminants (Exp_Type)
+ and then not Is_By_Reference_Type (Exp_Type)))
and then (Variable_Ref
or else (not Is_Name_Reference (Exp)
and then Nkind (Exp) /= N_Type_Conversion)
@@ -11475,12 +11451,15 @@ package body Exp_Util is
goto Leave;
-- If this is a type conversion, leave the type conversion and remove
- -- the side effects in the expression. This is important in several
- -- circumstances: for change of representations, and also when this is a
- -- view conversion to a smaller object, where gigi can end up creating
- -- its own temporary of the wrong size.
-
- elsif Nkind (Exp) = N_Type_Conversion then
+ -- side effects in the expression, unless it is of universal integer,
+ -- which is a very large type for a temporary. This is important in
+ -- several circumstances: for change of representations and also when
+ -- this is a view conversion to a smaller object, where gigi can end
+ -- up creating its own temporary of the wrong size.
+
+ elsif Nkind (Exp) = N_Type_Conversion
+ and then Etype (Expression (Exp)) /= Universal_Integer
+ then
Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
-- Generating C code the type conversion of an access to constrained
@@ -11574,7 +11553,7 @@ package body Exp_Util is
-- by the expression it renames, which would defeat the purpose of
-- removing the side effect.
- if Nkind_In (Exp, N_Selected_Component, N_Indexed_Component)
+ if Nkind (Exp) in N_Selected_Component | N_Indexed_Component
and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
then
null;
@@ -12001,8 +11980,8 @@ package body Exp_Util is
-- and view swaps, the parent type is taken from the formal
-- parameter of the subprogram being called.
- if Nkind_In (Context, N_Function_Call,
- N_Procedure_Call_Statement)
+ if Nkind (Context) in
+ N_Function_Call | N_Procedure_Call_Statement
and then No (Type_Map.Get (Entity (Name (Context))))
then
New_Ref :=
@@ -12117,13 +12096,8 @@ package body Exp_Util is
procedure Replace_Type_Ref (N : Node_Id) is
begin
-- Decorate the reference to Typ even though it may be rewritten
- -- further down. This is done for two reasons:
-
- -- * ASIS has all necessary semantic information in the original
- -- tree.
-
- -- * Routines which examine properties of the Original_Node have
- -- some semantic information.
+ -- further down. This is done so that routines which examine
+ -- properties of the Original_Node have some semantic information.
if Nkind (N) = N_Identifier then
Set_Entity (N, Typ);
@@ -12173,9 +12147,8 @@ package body Exp_Util is
Lib_Level : Boolean) return Boolean
is
At_Lib_Level : constant Boolean :=
- Lib_Level
- and then Nkind_In (N, N_Package_Body,
- N_Package_Specification);
+ Lib_Level
+ and then Nkind (N) in N_Package_Body | N_Package_Specification;
-- N is at the library level if the top-most context is a package and
-- the path taken to reach N does not include nonpackage constructs.
@@ -12552,8 +12525,8 @@ package body Exp_Util is
if (Nkind (Pexp) = N_Assignment_Statement
and then Expression (Pexp) = Exp)
- or else Nkind_In (Pexp, N_Object_Declaration,
- N_Object_Renaming_Declaration)
+ or else Nkind (Pexp)
+ in N_Object_Declaration | N_Object_Renaming_Declaration
then
return True;
@@ -12566,13 +12539,10 @@ package body Exp_Util is
elsif Nkind (Pexp) = N_Selected_Component
and then Prefix (Pexp) = Exp
then
- if No (Etype (Pexp)) then
- return True;
- else
- return
- not Has_Discriminants (Etype (Pexp))
- or else Is_Constrained (Etype (Pexp));
- end if;
+ return No (Etype (Pexp))
+ or else not Is_Type (Etype (Pexp))
+ or else not Has_Discriminants (Etype (Pexp))
+ or else Is_Constrained (Etype (Pexp));
end if;
-- Set the output type, this comes from Etype if it is set, otherwise we
@@ -12767,7 +12737,7 @@ package body Exp_Util is
-- they occur at the same level. If the second one is nested,
-- then the decision is neither right nor wrong (it would be
-- equally OK to leave the outer one in place, or take the new
- -- inner one. Really we should record both, but our data
+ -- inner one). Really we should record both, but our data
-- structures are not that elaborate.
if Nkind (Current_Value (Ent)) not in N_Subexpr then
@@ -12812,10 +12782,9 @@ package body Exp_Util is
Set_Entity_Current_Value (Right_Opnd (Cond));
end if;
- elsif Nkind_In (Cond,
- N_Type_Conversion,
- N_Qualified_Expression,
- N_Expression_With_Actions)
+ elsif Nkind (Cond) in N_Type_Conversion
+ | N_Qualified_Expression
+ | N_Expression_With_Actions
then
Set_Expression_Current_Value (Expression (Cond));
@@ -12888,7 +12857,7 @@ package body Exp_Util is
if Nkind (N) = N_Subprogram_Body
and then Address_Taken (Spec_Id)
and then
- Ekind_In (Scope (Spec_Id), E_Block, E_Procedure, E_Function)
+ Ekind (Scope (Spec_Id)) in E_Block | E_Procedure | E_Function
then
declare
Loc : constant Source_Ptr := Sloc (N);
@@ -13112,7 +13081,7 @@ package body Exp_Util is
elsif Is_Entity_Name (N) then
return Ekind (Entity (N)) = E_In_Parameter;
- elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
+ elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
return Within_In_Parameter (Prefix (N));
else
@@ -13193,9 +13162,7 @@ package body Exp_Util is
-- explicit dereference, then the designated object could
-- be modified by an assignment.
- if Nkind_In (RO, N_Indexed_Component,
- N_Explicit_Dereference)
- then
+ if Nkind (RO) in N_Indexed_Component | N_Explicit_Dereference then
return False;
-- A selected component must have a safe prefix
@@ -13244,58 +13211,18 @@ package body Exp_Util is
case Nkind (N) is
- -- An attribute reference is side effect free if its expressions
- -- are side effect free and its prefix is side effect free or
- -- is an entity reference.
-
- -- Is this right? what about x'first where x is a variable???
+ -- An attribute reference is side-effect free if its expressions
+ -- are side-effect free and its prefix is side-effect free or is
+ -- an entity reference.
when N_Attribute_Reference =>
- Attribute_Reference : declare
-
- function Side_Effect_Free_Attribute
- (Attribute_Name : Name_Id) return Boolean;
- -- Returns True if evaluation of the given attribute is
- -- considered side-effect free (independent of prefix and
- -- arguments).
-
- --------------------------------
- -- Side_Effect_Free_Attribute --
- --------------------------------
-
- function Side_Effect_Free_Attribute
- (Attribute_Name : Name_Id) return Boolean
- is
- begin
- case Attribute_Name is
- when Name_Input =>
- return False;
-
- when Name_Image
- | Name_Img
- | Name_Wide_Image
- | Name_Wide_Wide_Image
- =>
- -- CodePeer doesn't want to see replicated copies of
- -- 'Image calls.
-
- return not CodePeer_Mode;
-
- when others =>
- return True;
- end case;
- end Side_Effect_Free_Attribute;
-
- -- Start of processing for Attribute_Reference
-
- begin
- return
- Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
- and then Side_Effect_Free_Attribute (Attribute_Name (N))
- and then (Is_Entity_Name (Prefix (N))
- or else Side_Effect_Free
- (Prefix (N), Name_Req, Variable_Ref));
- end Attribute_Reference;
+ return Side_Effect_Free_Attribute (Attribute_Name (N))
+ and then
+ Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
+ and then
+ (Is_Entity_Name (Prefix (N))
+ or else
+ Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref));
-- A binary operator is side effect free if and both operands are
-- side effect free. For this purpose binary operators include
@@ -13416,6 +13343,12 @@ package body Exp_Util is
=>
return True;
+ -- An aggregate is side effect free if all its values are compile
+ -- time known.
+
+ when N_Aggregate =>
+ return Compile_Time_Known_Aggregate (N);
+
-- We consider that anything else has side effects. This is a bit
-- crude, but we are pretty close for most common cases, and we
-- are certainly correct (i.e. we never return True when the
@@ -13454,6 +13387,30 @@ package body Exp_Util is
end if;
end Side_Effect_Free;
+ --------------------------------
+ -- Side_Effect_Free_Attribute --
+ --------------------------------
+
+ function Side_Effect_Free_Attribute (Name : Name_Id) return Boolean is
+ begin
+ case Name is
+ when Name_Input =>
+ return False;
+
+ when Name_Image
+ | Name_Img
+ | Name_Wide_Image
+ | Name_Wide_Wide_Image
+ =>
+ -- CodePeer doesn't want to see replicated copies of 'Image calls
+
+ return not CodePeer_Mode;
+
+ when others =>
+ return True;
+ end case;
+ end Side_Effect_Free_Attribute;
+
----------------------------------
-- Silly_Boolean_Array_Not_Test --
----------------------------------
@@ -13734,8 +13691,7 @@ package body Exp_Util is
Par := Parent (N);
while Present (Par) loop
- if Nkind_In (Original_Node (Par), N_Case_Expression,
- N_If_Expression)
+ if Nkind (Original_Node (Par)) in N_Case_Expression | N_If_Expression
then
return True;
@@ -13751,11 +13707,11 @@ package body Exp_Util is
return False;
end Within_Case_Or_If_Expression;
- --------------------------------
- -- Within_Internal_Subprogram --
- --------------------------------
+ ------------------------------
+ -- Predicate_Check_In_Scope --
+ ------------------------------
- function Within_Internal_Subprogram return Boolean is
+ function Predicate_Check_In_Scope (N : Node_Id) return Boolean is
S : Entity_Id;
begin
@@ -13764,10 +13720,23 @@ package body Exp_Util is
S := Scope (S);
end loop;
- return Present (S)
- and then Get_TSS_Name (S) /= TSS_Null
- and then not Is_Predicate_Function (S)
- and then not Is_Predicate_Function_M (S);
- end Within_Internal_Subprogram;
+ if Present (S) then
+
+ -- Predicate checks should only be enabled in init procs for
+ -- expressions coming from source.
+
+ if Is_Init_Proc (S) then
+ return Comes_From_Source (N);
+
+ elsif Get_TSS_Name (S) /= TSS_Null
+ and then not Is_Predicate_Function (S)
+ and then not Is_Predicate_Function_M (S)
+ then
+ return False;
+ end if;
+ end if;
+
+ return True;
+ end Predicate_Check_In_Scope;
end Exp_Util;
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 03008ba..3f882a6 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -724,6 +724,10 @@ package Exp_Util is
-- N_Op_Eq), or to determine the result of some other test in other cases
-- (e.g. no access check required if N_Op_Ne Null).
+ function Get_Index_Subtype (N : Node_Id) return Entity_Id;
+ -- Used for First, Last, and Length, when the prefix is an array type.
+ -- Obtains the corresponding index subtype.
+
function Get_Stream_Size (E : Entity_Id) return Uint;
-- Return the stream size value of the subtype E
@@ -1191,12 +1195,10 @@ package Exp_Util is
function Within_Case_Or_If_Expression (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N is within a case or an if expression
- function Within_Internal_Subprogram return Boolean;
- -- Indicates that some expansion is taking place within the body of a
- -- predefined primitive operation. Some expansion activity (e.g. predicate
- -- checks) is disabled in such. Because we want to detect invalid uses
- -- of function calls within predicates (which lead to infinite recursion)
- -- predicate functions themselves are not considered internal here.
+ function Predicate_Check_In_Scope (N : Node_Id) return Boolean;
+ -- Return True if predicate checks should be generated in the current
+ -- scope on the given node. Will return False for example when the current
+ -- scope is a predefined primitive operation.
private
pragma Inline (Duplicate_Subexpr);
diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb
index aac2e7d..b8e86b8 100644
--- a/gcc/ada/expander.adb
+++ b/gcc/ada/expander.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -545,10 +545,10 @@ package body Expander is
procedure Expander_Mode_Restore is
begin
- -- Not active (has no effect) in ASIS and GNATprove modes (see comments
+ -- Not active (has no effect) in GNATprove mode (see comments
-- in spec of Expander_Mode_Save_And_Set).
- if ASIS_Mode or GNATprove_Mode then
+ if GNATprove_Mode then
return;
end if;
@@ -572,10 +572,10 @@ package body Expander is
procedure Expander_Mode_Save_And_Set (Status : Boolean) is
begin
- -- Not active (has no effect) in ASIS and GNATprove modes (see comments
+ -- Not active (has no effect) in GNATprove modes (see comments
-- in spec of Expander_Mode_Save_And_Set).
- if ASIS_Mode or GNATprove_Mode then
+ if GNATprove_Mode then
return;
end if;
diff --git a/gcc/ada/expander.ads b/gcc/ada/expander.ads
index 91d2683..d7c61ec 100644
--- a/gcc/ada/expander.ads
+++ b/gcc/ada/expander.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -73,9 +73,9 @@
-- For nodes other than subexpressions, it is not necessary to preserve the
-- original tree in the Expand routines, unlike the case for modifications
-- to the tree made in the semantic analyzer. This is because anyone who is
--- interested in working with the original tree (like ASIS) is required to
--- compile in semantics checks only mode. Thus Replace may be freely used
--- in such instances.
+-- interested in working with the original tree is required to compile in
+-- semantics checks only mode. Thus Replace may be freely used in such
+-- instances.
-- For subexpressions, preservation of the original tree is required because
-- of the need for conformance checking of default expressions, which occurs
@@ -150,20 +150,17 @@ package Expander is
-- Saves the current setting of the Expander_Active flag on an internal
-- stack and then sets the flag to the given value.
--
- -- Note: this routine has no effect in ASIS and GNATprove modes. In ASIS
- -- mode, all expansion activity is always off, since we want the original
- -- semantic tree for ASIS purposes without any expansion. In GNATprove
- -- mode, a very light expansion is performed on specific nodes. Both are
- -- achieved by setting Expander_Active False in ASIS and GNATprove modes.
+ -- Note: this routine has no effect in GNATprove mode. In this mode,
+ -- a very light expansion is performed on specific nodes and
+ -- Expander_Active is set to False.
-- In situations such as the call to Instantiate_Bodies in Frontend,
-- Expander_Mode_Save_And_Set may be called to temporarily turn the
- -- expander on, but this will have no effect in ASIS and GNATprove modes.
+ -- expander on, but this will have no effect in GNATprove mode.
procedure Expander_Mode_Restore;
-- Restores the setting of the Expander_Active flag using the top entry
-- pushed onto the stack by Expander_Mode_Save_And_Reset, popping the
-- stack, except that if any errors have been detected, then the state of
- -- the flag is left set to False. Disabled for ASIS and GNATprove modes
- -- (see above).
+ -- the flag is left set to False. Disabled for GNATprove mode (see above).
end Expander;
diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c
index b8753ab..718886d 100644
--- a/gcc/ada/expect.c
+++ b/gcc/ada/expect.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2001-2019, AdaCore *
+ * Copyright (C) 2001-2020, AdaCore *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -78,6 +78,7 @@
#include <process.h>
#include <signal.h>
#include <io.h>
+#include "adaint.h"
#include "mingw32.h"
int
@@ -85,11 +86,10 @@ __gnat_waitpid (int pid)
{
HANDLE h = OpenProcess (PROCESS_ALL_ACCESS, FALSE, pid);
DWORD exitcode = 1;
- DWORD res;
if (h != NULL)
{
- res = WaitForSingleObject (h, INFINITE);
+ (void) WaitForSingleObject (h, INFINITE);
GetExitCodeProcess (h, &exitcode);
CloseHandle (h);
}
@@ -105,7 +105,8 @@ __gnat_expect_fork (void)
}
void
-__gnat_expect_portable_execvp (int *pid, char *cmd, char *argv[])
+__gnat_expect_portable_execvp (int *pid, char *cmd ATTRIBUTE_UNUSED,
+ char *argv[])
{
*pid = __gnat_portable_no_block_spawn (argv);
}
diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h
index 6b3f300..8ad16c2 100644
--- a/gcc/ada/fe.h
+++ b/gcc/ada/fe.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -59,9 +59,11 @@ extern int Compiler_Abort (String_Pointer, String_Pointer, Boolean) ATTRIBUTE_NO
/* debug: */
+#define Debug_Flag_Dot_KK debug__debug_flag_dot_kk
#define Debug_Flag_Dot_R debug__debug_flag_dot_r
#define Debug_Flag_NN debug__debug_flag_nn
+extern Boolean Debug_Flag_Dot_KK;
extern Boolean Debug_Flag_Dot_R;
extern Boolean Debug_Flag_NN;
@@ -253,9 +255,9 @@ extern Boolean No_Exception_Handlers_Set (void);
/* sem_aggr: */
-#define Is_Others_Aggregate sem_aggr__is_others_aggregate
+#define Is_Single_Aggregate sem_aggr__is_single_aggregate
-extern Boolean Is_Others_Aggregate (Node_Id);
+extern Boolean Is_Single_Aggregate (Node_Id);
/* sem_aux: */
@@ -278,10 +280,8 @@ extern Boolean Is_Derived_Type (Entity_Id);
/* sem_eval: */
#define Compile_Time_Known_Value sem_eval__compile_time_known_value
-#define Is_OK_Static_Expression sem_eval__is_ok_static_expression
extern Boolean Compile_Time_Known_Value (Node_Id);
-extern Boolean Is_OK_Static_Expression (Node_Id);
/* sem_util: */
diff --git a/gcc/ada/final.c b/gcc/ada/final.c
index 4647ba5..5b3b3b4 100644
--- a/gcc/ada/final.c
+++ b/gcc/ada/final.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb
index 04935bb..a5ae66e 100644
--- a/gcc/ada/fmap.adb
+++ b/gcc/ada/fmap.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/fmap.ads b/gcc/ada/fmap.ads
index e185d1c..862b8ea 100644
--- a/gcc/ada/fmap.ads
+++ b/gcc/ada/fmap.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/fname-sf.adb b/gcc/ada/fname-sf.adb
index aab11ea..dc0a3de 100644
--- a/gcc/ada/fname-sf.adb
+++ b/gcc/ada/fname-sf.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/fname-sf.ads b/gcc/ada/fname-sf.ads
index 5a05b15..c9b5081 100644
--- a/gcc/ada/fname-sf.ads
+++ b/gcc/ada/fname-sf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb
index a7ce4c9..97d3b7b 100644
--- a/gcc/ada/fname-uf.adb
+++ b/gcc/ada/fname-uf.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/fname-uf.ads b/gcc/ada/fname-uf.ads
index 3e62c47..0bbd787 100644
--- a/gcc/ada/fname-uf.ads
+++ b/gcc/ada/fname-uf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/fname.adb b/gcc/ada/fname.adb
index d41e28f..ad316eb 100644
--- a/gcc/ada/fname.adb
+++ b/gcc/ada/fname.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,34 +29,8 @@
-- --
------------------------------------------------------------------------------
-with Alloc;
-with Table;
-with Types; use Types;
-
package body Fname is
- -----------------------------
- -- Dummy Table Definitions --
- -----------------------------
-
- -- The following table was used in old versions of the compiler. We retain
- -- the declarations here for compatibility with old tree files. The new
- -- version of the compiler does not use this table, and will write out a
- -- dummy empty table for Tree_Write.
-
- type SFN_Entry is record
- U : Unit_Name_Type;
- F : File_Name_Type;
- end record;
-
- package SFN_Table is new Table.Table (
- Table_Component_Type => SFN_Entry,
- Table_Index_Type => Int,
- Table_Low_Bound => 0,
- Table_Initial => Alloc.SFN_Table_Initial,
- Table_Increment => Alloc.SFN_Table_Increment,
- Table_Name => "Fname_Dummy_Table");
-
function Has_Internal_Extension (Fname : String) return Boolean;
pragma Inline (Has_Internal_Extension);
-- True if the extension is appropriate for an internal/predefined unit.
@@ -268,22 +242,4 @@ package body Fname is
return Result;
end Is_Predefined_Renaming_File_Name;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- SFN_Table.Tree_Read;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- SFN_Table.Tree_Write;
- end Tree_Write;
-
end Fname;
diff --git a/gcc/ada/fname.ads b/gcc/ada/fname.ads
index ce363c2..06a77f1 100644
--- a/gcc/ada/fname.ads
+++ b/gcc/ada/fname.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -100,14 +100,4 @@ package Fname is
function Is_GNAT_File_Name (Fname : File_Name_Type) return Boolean;
-- True for units in the GNAT hierarchy
- procedure Tree_Read;
- -- Dummy procedure (reads dummy table values from tree file)
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using Tree_Write
- -- This is actually a dummy routine, since the relevant table is
- -- no longer used, but we retain it for now, to avoid a tree file
- -- incompatibility with the 3.13 compiler. Should be removed for
- -- the 3.14a release ???
-
end Fname;
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 0312ca7..1c177b1 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -283,11 +283,11 @@ package body Freeze is
and then
(Present (Interface_Name (Renamed_Subp))
- or else Nam_In (Chars (Renamed_Subp), Name_Rotate_Left,
- Name_Rotate_Right,
- Name_Shift_Left,
- Name_Shift_Right,
- Name_Shift_Right_Arithmetic))
+ or else Chars (Renamed_Subp) in Name_Rotate_Left
+ | Name_Rotate_Right
+ | Name_Shift_Left
+ | Name_Shift_Right
+ | Name_Shift_Right_Arithmetic)
then
Set_Interface_Name (Ent, Interface_Name (Renamed_Subp));
@@ -412,7 +412,7 @@ package body Freeze is
-- as we need to check other conditions for creating a body to inline
-- in that case, which are controlled in Analyze_Subprogram_Body_Helper.
- if Ekind_In (Old_S, E_Function, E_Procedure)
+ if Ekind (Old_S) in E_Function | E_Procedure
and then Nkind (Decl) = N_Subprogram_Declaration
and then not Is_Generic_Instance (Old_S)
and then not GNATprove_Mode
@@ -652,7 +652,7 @@ package body Freeze is
while Present (Rep)
and then Next_Rep_Item (Rep) /= Addr
loop
- Rep := Next_Rep_Item (Rep);
+ Next_Rep_Item (Rep);
end loop;
end if;
@@ -1894,8 +1894,8 @@ package body Freeze is
end if;
elsif Ekind (E) in Task_Kind
- and then Nkind_In (Parent (E), N_Single_Task_Declaration,
- N_Task_Type_Declaration)
+ and then Nkind (Parent (E)) in
+ N_Single_Task_Declaration | N_Task_Type_Declaration
then
Push_Scope (E);
Freeze_All (First_Entity (E), After);
@@ -1957,7 +1957,7 @@ package body Freeze is
Check_Aspect_At_End_Of_Declarations (Ritem);
end if;
- Ritem := Next_Rep_Item (Ritem);
+ Next_Rep_Item (Ritem);
end loop;
end;
end if;
@@ -1986,15 +1986,15 @@ package body Freeze is
-- current package, but this body does not freeze incomplete
-- types that may be declared in this private part.
- if (Nkind_In (Bod, N_Entry_Body,
- N_Package_Body,
- N_Protected_Body,
- N_Subprogram_Body,
- N_Task_Body)
- or else Nkind (Bod) in N_Body_Stub)
+ if Comes_From_Source (Bod)
+ and then Nkind (Bod) in N_Entry_Body
+ | N_Package_Body
+ | N_Protected_Body
+ | N_Subprogram_Body
+ | N_Task_Body
+ | N_Body_Stub
and then
List_Containing (After) = List_Containing (Parent (E))
- and then Comes_From_Source (Bod)
then
Error_Msg_Sloc := Sloc (Next (After));
Error_Msg_NE
@@ -2373,8 +2373,7 @@ package body Freeze is
begin
case Nkind (N) is
when N_Attribute_Reference =>
- if Nam_In (Attribute_Name (N), Name_Access,
- Name_Unchecked_Access)
+ if Attribute_Name (N) in Name_Access | Name_Unchecked_Access
and then Is_Entity_Name (Prefix (N))
and then Is_Type (Entity (Prefix (N)))
and then Entity (Prefix (N)) = E
@@ -2573,13 +2572,13 @@ package body Freeze is
-- Propagate flags for component type
- if Is_Controlled (Component_Type (Arr))
+ if Is_Controlled (Ctyp)
or else Has_Controlled_Component (Ctyp)
then
Set_Has_Controlled_Component (Arr);
end if;
- if Has_Unchecked_Union (Component_Type (Arr)) then
+ if Has_Unchecked_Union (Ctyp) then
Set_Has_Unchecked_Union (Arr);
end if;
@@ -2590,7 +2589,7 @@ package body Freeze is
-- that the procedure can be used to check the array type
-- invariants if any.
- if Has_Invariants (Component_Type (Arr))
+ if Has_Invariants (Ctyp)
and then not GNATprove_Mode
then
Set_Has_Own_Invariants (Arr);
@@ -2902,8 +2901,8 @@ package body Freeze is
-- If the Esize of the component is known and equal to
-- the component size then even packing is not needed.
- if Known_Static_Esize (Component_Type (Arr))
- and then Esize (Component_Type (Arr)) = Csiz
+ if Known_Static_Esize (Ctyp)
+ and then Esize (Ctyp) = Csiz
then
-- Here the array was requested to be packed, but
-- the packing request had no effect whatsoever,
@@ -2928,7 +2927,10 @@ package body Freeze is
-- Bit packing is not needed for multiples of the storage
-- unit if the type is composite because the back end can
- -- byte pack composite types.
+ -- byte pack composite types efficiently. That's not true
+ -- for discrete types because every read would generate a
+ -- lot of instructions, so we keep using the manipulation
+ -- routines of the runtime for them.
elsif Csiz mod System_Storage_Unit = 0
and then Is_Composite_Type (Ctyp)
@@ -3157,21 +3159,6 @@ package body Freeze is
<<Skip_Packed>>
- -- For non-packed arrays set the alignment of the array to the
- -- alignment of the component type if it is unknown. Skip this
- -- in atomic/VFA case (atomic/VFA arrays may need larger alignments).
-
- if not Is_Packed (Arr)
- and then Unknown_Alignment (Arr)
- and then Known_Alignment (Ctyp)
- and then Known_Static_Component_Size (Arr)
- and then Known_Static_Esize (Ctyp)
- and then Esize (Ctyp) = Component_Size (Arr)
- and then not Is_Atomic_Or_VFA (Arr)
- then
- Set_Alignment (Arr, Alignment (Component_Type (Arr)));
- end if;
-
-- A Ghost type cannot have a component of protected or task type
-- (SPARK RM 6.9(19)).
@@ -3443,7 +3430,7 @@ package body Freeze is
Check_Address_Clause (E);
-- Similar processing is needed for aspects that may affect object
- -- layout, like Alignment, if there is an initialization expression.
+ -- layout, like Address, if there is an initialization expression.
-- We don't do this if there is a pragma Linker_Section, because it
-- would prevent the back end from statically initializing the
-- object; we don't want elaboration code in that case.
@@ -3451,11 +3438,11 @@ package body Freeze is
if Has_Delayed_Aspects (E)
and then Expander_Active
and then Is_Array_Type (Typ)
- and then Present (Expression (Parent (E)))
+ and then Present (Expression (Declaration_Node (E)))
and then No (Linker_Section_Pragma (E))
then
declare
- Decl : constant Node_Id := Parent (E);
+ Decl : constant Node_Id := Declaration_Node (E);
Lhs : constant Node_Id := New_Occurrence_Of (E, Loc);
begin
@@ -3674,9 +3661,7 @@ package body Freeze is
if Warn_On_Export_Import
and then Comes_From_Source (E)
- and then (Convention (E) = Convention_C
- or else
- Convention (E) = Convention_CPP)
+ and then Convention (E) in Convention_C_Family
and then (Is_Imported (E) or else Is_Exported (E))
and then Convention (E) /= Convention (Formal)
and then not Has_Warnings_Off (E)
@@ -3823,9 +3808,8 @@ package body Freeze is
-- Check suspicious return type for C function
if Warn_On_Export_Import
- and then (Convention (E) = Convention_C
- or else
- Convention (E) = Convention_CPP)
+ and then Comes_From_Source (E)
+ and then Convention (E) in Convention_C_Family
and then (Is_Imported (E) or else Is_Exported (E))
then
-- Check suspicious return of fat C pointer
@@ -4155,7 +4139,7 @@ package body Freeze is
-- Handle the component and discriminant case
- if Ekind_In (Comp, E_Component, E_Discriminant) then
+ if Ekind (Comp) in E_Component | E_Discriminant then
declare
CC : constant Node_Id := Component_Clause (Comp);
@@ -4227,14 +4211,6 @@ package body Freeze is
elsif CodePeer_Mode then
null;
- -- Omit check if component has a generic type. This can
- -- happen in an instantiation within a generic in ASIS
- -- mode, where we force freeze actions without full
- -- expansion.
-
- elsif Is_Generic_Type (Etype (Comp)) then
- null;
-
-- Do the check
elsif not
@@ -5226,7 +5202,7 @@ package body Freeze is
-- case, both the body and imported function utilize the same
-- type.
- if Ekind_In (E, E_Function, E_Generic_Function) then
+ if Ekind (E) in E_Function | E_Generic_Function then
Stmt :=
Make_Simple_Return_Statement (Loc,
Expression =>
@@ -5596,10 +5572,9 @@ package body Freeze is
begin
while Present (Prag) loop
- if Nam_In (Pragma_Name_Unmapped (Prag),
- Name_Post,
- Name_Postcondition,
- Name_Refined_Post)
+ if Pragma_Name_Unmapped (Prag) in Name_Post
+ | Name_Postcondition
+ | Name_Refined_Post
then
Exp :=
Expression
@@ -5696,7 +5671,7 @@ package body Freeze is
-- Remaining step is to layout objects
- if Ekind_In (E, E_Variable, E_Constant, E_Loop_Parameter)
+ if Ekind (E) in E_Variable | E_Constant | E_Loop_Parameter
or else Is_Formal (E)
then
Layout_Object (E);
@@ -5707,7 +5682,7 @@ package body Freeze is
-- statement, move them back now directly within the enclosing
-- statement sequence.
- if Ekind_In (E, E_Constant, E_Variable)
+ if Ekind (E) in E_Constant | E_Variable
and then not Has_Delayed_Freeze (E)
then
Explode_Initialization_Compound_Statement (E);
@@ -6068,7 +6043,7 @@ package body Freeze is
-- for the case of a private type with record extension (we will do
-- that later when the full type is frozen).
- elsif Ekind_In (E, E_Record_Type, E_Record_Subtype) then
+ elsif Ekind (E) in E_Record_Type | E_Record_Subtype then
if not In_Generic_Scope (E) then
Freeze_Record_Type (E);
end if;
@@ -6201,8 +6176,7 @@ package body Freeze is
if Present (F_Node) then
Inherit_Freeze_Node
- (Fnod => F_Node,
- Typ => Full_View (E));
+ (Fnod => F_Node, Typ => Full_View (E));
else
Set_Has_Delayed_Freeze (Full_View (E), False);
Set_Freeze_Node (Full_View (E), Empty);
@@ -6213,9 +6187,7 @@ package body Freeze is
F_Node := Freeze_Node (Full_View (E));
if Present (F_Node) then
- Inherit_Freeze_Node
- (Fnod => F_Node,
- Typ => E);
+ Inherit_Freeze_Node (Fnod => F_Node, Typ => E);
else
-- {Incomplete,Private}_Subtypes with Full_Views
-- constrained by discriminants.
@@ -6651,9 +6623,9 @@ package body Freeze is
begin
pragma Assert
- (Nam_In (Op_Name, Name_Allocate,
- Name_Deallocate,
- Name_Storage_Size));
+ (Op_Name in Name_Allocate
+ | Name_Deallocate
+ | Name_Storage_Size);
Error_Msg_Name_1 := Op_Name;
@@ -6665,7 +6637,7 @@ package body Freeze is
Op := Get_Name_Entity_Id (Op_Name);
while Present (Op) loop
- if Ekind_In (Op, E_Function, E_Procedure)
+ if Ekind (Op) in E_Function | E_Procedure
and then Scope (Op) = Current_Scope
then
Formal := First_Entity (Op);
@@ -6796,7 +6768,7 @@ package body Freeze is
Check_Strict_Alignment (E);
end if;
- if Ekind_In (E, E_Record_Type, E_Record_Subtype) then
+ if Ekind (E) in E_Record_Type | E_Record_Subtype then
declare
RC : constant Node_Id := Get_Record_Representation_Clause (E);
begin
@@ -7080,10 +7052,18 @@ package body Freeze is
-- as well.
function In_Expanded_Body (N : Node_Id) return Boolean;
- -- Given an N_Handled_Sequence_Of_Statements node N, determines whether
- -- it is the handled statement sequence of an expander-generated
- -- subprogram (init proc, stream subprogram, or renaming as body).
- -- If so, this is not a freezing context.
+ -- Given an N_Handled_Sequence_Of_Statements node, determines whether it
+ -- is the statement sequence of an expander-generated subprogram: body
+ -- created for an expression function, for a predicate function, an init
+ -- proc, a stream subprogram, or a renaming as body. If so, this is not
+ -- a freezing context and the entity will be frozen at a later point.
+
+ function Has_Decl_In_List
+ (E : Entity_Id;
+ N : Node_Id;
+ L : List_Id) return Boolean;
+ -- Determines whether an entity E referenced in node N is declared in
+ -- the list L.
-----------------------------------------
-- Find_Aggregate_Component_Desig_Type --
@@ -7124,19 +7104,26 @@ package body Freeze is
----------------------
function In_Expanded_Body (N : Node_Id) return Boolean is
- P : Node_Id;
+ P : constant Node_Id := Parent (N);
Id : Entity_Id;
begin
- if Nkind (N) = N_Subprogram_Body then
- P := N;
- else
- P := Parent (N);
- end if;
-
if Nkind (P) /= N_Subprogram_Body then
return False;
+ -- AI12-0157: An expression function that is a completion is a freeze
+ -- point. If the body is the result of expansion, it is not.
+
+ elsif Was_Expression_Function (P) then
+ return not Comes_From_Source (P);
+
+ -- This is the body of a generated predicate function
+
+ elsif Present (Corresponding_Spec (P))
+ and then Is_Predicate_Function (Corresponding_Spec (P))
+ then
+ return True;
+
else
Id := Defining_Unit_Name (Specification (P));
@@ -7149,9 +7136,8 @@ package body Freeze is
or else Is_TSS (Id, TSS_Stream_Output)
or else Is_TSS (Id, TSS_Stream_Read)
or else Is_TSS (Id, TSS_Stream_Write)
- or else Nkind_In (Original_Node (P),
- N_Subprogram_Renaming_Declaration,
- N_Expression_Function))
+ or else Nkind (Original_Node (P)) =
+ N_Subprogram_Renaming_Declaration)
then
return True;
else
@@ -7160,6 +7146,30 @@ package body Freeze is
end if;
end In_Expanded_Body;
+ ----------------------
+ -- Has_Decl_In_List --
+ ----------------------
+
+ function Has_Decl_In_List
+ (E : Entity_Id;
+ N : Node_Id;
+ L : List_Id) return Boolean
+ is
+ Decl_Node : Node_Id;
+
+ begin
+ -- If E is an itype, pretend that it is declared in N
+
+ if Is_Itype (E) then
+ Decl_Node := N;
+ else
+ Decl_Node := Declaration_Node (E);
+ end if;
+
+ return Is_List_Member (Decl_Node)
+ and then List_Containing (Decl_Node) = L;
+ end Has_Decl_In_List;
+
-- Local variables
In_Spec_Exp : constant Boolean := In_Spec_Expression;
@@ -7170,6 +7180,8 @@ package body Freeze is
Parent_P : Node_Id;
Typ : Entity_Id;
+ Allocator_Typ : Entity_Id := Empty;
+
Freeze_Outside : Boolean := False;
-- This flag is set true if the entity must be frozen outside the
-- current subprogram. This happens in the case of expander generated
@@ -7280,6 +7292,10 @@ package body Freeze is
when N_Allocator =>
Desig_Typ := Designated_Type (Etype (N));
+ if Nkind (Expression (N)) = N_Qualified_Expression then
+ Allocator_Typ := Entity (Subtype_Mark (Expression (N)));
+ end if;
+
when N_Aggregate =>
if Is_Array_Type (Etype (N))
and then Is_Access_Type (Component_Type (Etype (N)))
@@ -7322,6 +7338,7 @@ package body Freeze is
if No (Typ)
and then No (Nam)
and then No (Desig_Typ)
+ and then No (Allocator_Typ)
then
return;
end if;
@@ -7390,10 +7407,16 @@ package body Freeze is
return;
end if;
- exit when
- Nkind (Parent_P) = N_Subprogram_Body
+ -- If the parent is a subprogram body, the candidate insertion
+ -- point is just ahead of it.
+
+ if Nkind (Parent_P) = N_Subprogram_Body
and then Unique_Defining_Entity (Parent_P) =
- Freeze_Outside_Subp;
+ Freeze_Outside_Subp
+ then
+ P := Parent_P;
+ exit;
+ end if;
P := Parent_P;
end loop;
@@ -7474,7 +7497,7 @@ package body Freeze is
-- The case we are looking for is an enumeration literal
- if Nkind_In (N, N_Identifier, N_Character_Literal)
+ if Nkind (N) in N_Identifier | N_Character_Literal
and then Is_Enumeration_Type (Etype (N))
then
-- If enumeration literal appears directly as the choice,
@@ -7515,53 +7538,57 @@ package body Freeze is
if In_Expanded_Body (Parent_P) then
declare
- Subp : constant Node_Id := Parent (Parent_P);
- Spec : Entity_Id;
+ Subp_Body : constant Node_Id := Parent (Parent_P);
+ Spec_Id : Entity_Id;
begin
-- Freeze the entity only when it is declared inside
- -- the body of the expander generated procedure.
- -- This case is recognized by the scope of the entity
- -- or its type, which is either the spec for some
- -- enclosing body, or (in the case of init_procs,
- -- for which there are no separate specs) the current
- -- scope.
-
- if Nkind (Subp) = N_Subprogram_Body then
- Spec := Corresponding_Spec (Subp);
-
- if (Present (Typ) and then Scope (Typ) = Spec)
- or else
- (Present (Nam) and then Scope (Nam) = Spec)
- then
- exit;
+ -- the body of the expander generated procedure. This
+ -- case is recognized by the subprogram scope of the
+ -- entity or its type, which is either the spec of an
+ -- enclosing body, or (in the case of init_procs for
+ -- which there is no separate spec) the current scope.
+
+ if Nkind (Subp_Body) = N_Subprogram_Body then
+ declare
+ S : Entity_Id;
+
+ begin
+ Spec_Id := Corresponding_Spec (Subp_Body);
+
+ if Present (Typ) then
+ S := Scope (Typ);
+ elsif Present (Nam) then
+ S := Scope (Nam);
+ else
+ S := Standard_Standard;
+ end if;
- elsif Present (Typ)
- and then Scope (Typ) = Current_Scope
- and then Defining_Entity (Subp) = Current_Scope
- then
- exit;
- end if;
- end if;
+ while S /= Standard_Standard
+ and then not Is_Subprogram (S)
+ loop
+ S := Scope (S);
+ end loop;
- -- An expression function may act as a completion of
- -- a function declaration. As such, it can reference
- -- entities declared between the two views:
+ if S = Spec_Id then
+ exit;
- -- Hidden []; -- 1
- -- function F return ...;
- -- private
- -- function Hidden return ...;
- -- function F return ... is (Hidden); -- 2
+ elsif Present (Typ)
+ and then Scope (Typ) = Current_Scope
+ and then
+ Defining_Entity (Subp_Body) = Current_Scope
+ then
+ exit;
+ end if;
+ end;
+ end if;
- -- Refering to the example above, freezing the
- -- expression of F (2) would place Hidden's freeze
- -- node (1) in the wrong place. Avoid explicit
- -- freezing and let the usual scenarios do the job
- -- (for example, reaching the end of the private
- -- declarations, or a call to F.)
+ -- If the entity is not frozen by an expression
+ -- function that is not a completion, continue
+ -- climbing the tree.
- if Nkind (Original_Node (Subp)) = N_Expression_Function
+ if Nkind (Subp_Body) = N_Subprogram_Body
+ and then Was_Expression_Function (Subp_Body)
then
null;
@@ -7601,7 +7628,6 @@ package body Freeze is
when N_Abortable_Part
| N_Accept_Alternative
- | N_And_Then
| N_Case_Statement_Alternative
| N_Compilation_Unit_Aux
| N_Conditional_Entry_Call
@@ -7612,32 +7638,58 @@ package body Freeze is
| N_Extended_Return_Statement
| N_Freeze_Entity
| N_If_Statement
- | N_Or_Else
| N_Selective_Accept
| N_Triggering_Alternative
=>
exit when Is_List_Member (P);
- -- Freeze nodes produced by an expression coming from the
- -- Actions list of a N_Expression_With_Actions node must remain
- -- within the Actions list. Inserting the freeze nodes further
- -- up the tree may lead to use before declaration issues in the
- -- case of array types.
+ -- The freeze nodes produced by an expression coming from the
+ -- Actions list of an N_Expression_With_Actions, short-circuit
+ -- expression or N_Case_Expression_Alternative node must remain
+ -- within the Actions list if they freeze an entity declared in
+ -- this list, as inserting the freeze nodes further up the tree
+ -- may lead to use before declaration issues for the entity.
- when N_Expression_With_Actions =>
- if Is_List_Member (P)
- and then List_Containing (P) = Actions (Parent_P)
- then
- exit;
- end if;
+ when N_Case_Expression_Alternative
+ | N_Expression_With_Actions
+ | N_Short_Circuit
+ =>
+ exit when (Present (Nam)
+ and then
+ Has_Decl_In_List (Nam, P, Actions (Parent_P)))
+ or else (Present (Typ)
+ and then
+ Has_Decl_In_List (Typ, P, Actions (Parent_P)));
+
+ -- Likewise for an N_If_Expression and its two Actions list
+
+ when N_If_Expression =>
+ declare
+ L1 : constant List_Id := Then_Actions (Parent_P);
+ L2 : constant List_Id := Else_Actions (Parent_P);
- -- Note: N_Loop_Statement is a special case. A type that
- -- appears in the source can never be frozen in a loop (this
- -- occurs only because of a loop expanded by the expander), so
- -- we keep on going. Otherwise we terminate the search. Same
- -- is true of any entity which comes from source. (if they
- -- have predefined type, that type does not appear to come
- -- from source, but the entity should not be frozen here).
+ begin
+ exit when (Present (Nam)
+ and then
+ Has_Decl_In_List (Nam, P, L1))
+ or else (Present (Typ)
+ and then
+ Has_Decl_In_List (Typ, P, L1))
+ or else (Present (Nam)
+ and then
+ Has_Decl_In_List (Nam, P, L2))
+ or else (Present (Typ)
+ and then
+ Has_Decl_In_List (Typ, P, L2));
+ end;
+
+ -- N_Loop_Statement is a special case: a type that appears in
+ -- the source can never be frozen in a loop (this occurs only
+ -- because of a loop expanded by the expander), so we keep on
+ -- going. Otherwise we terminate the search. Same is true of
+ -- any entity which comes from source (if it has a predefined
+ -- type, this type does not appear to come from source, but the
+ -- entity should not be frozen here).
when N_Loop_Statement =>
exit when not Comes_From_Source (Etype (N))
@@ -7756,6 +7808,14 @@ package body Freeze is
In_Spec_Expression := False;
+ -- Freeze the subtype mark before a qualified expression on an
+ -- allocator as per AARM 13.14(4.a). This is needed in particular to
+ -- generate predicate functions.
+
+ if Present (Allocator_Typ) then
+ Freeze_Before (P, Allocator_Typ);
+ end if;
+
-- Freeze the designated type of an allocator (RM 13.14(13))
if Present (Desig_Typ) then
@@ -7812,8 +7872,8 @@ package body Freeze is
function Clone_Id (Node : Node_Id) return Traverse_Result is
begin
- if Nkind_In (Node, N_Iterator_Specification,
- N_Loop_Parameter_Specification)
+ if Nkind (Node) in
+ N_Iterator_Specification | N_Loop_Parameter_Specification
then
Set_Defining_Identifier
(Node, New_Copy (Defining_Identifier (Node)));
@@ -7904,7 +7964,7 @@ package body Freeze is
-- Check that the enclosing record type can be frozen
- if Ekind_In (Entity (Node), E_Component, E_Discriminant) then
+ if Ekind (Entity (Node)) in E_Component | E_Discriminant then
Check_And_Freeze_Type (Scope (Entity (Node)));
end if;
@@ -7934,6 +7994,32 @@ package body Freeze is
and then Node = Controlling_Argument (Parent (Node))
then
Check_And_Freeze_Type (Designated_Type (Etype (Node)));
+
+ -- An explicit dereference freezes the designated type as well,
+ -- even though that type is not attached to an entity in the
+ -- expression.
+
+ elsif Nkind (Node) in N_Has_Etype
+ and then Nkind (Parent (Node)) = N_Explicit_Dereference
+ then
+ Check_And_Freeze_Type (Designated_Type (Etype (Node)));
+
+ -- An iterator specification freezes the iterator type, even though
+ -- that type is not attached to an entity in the construct.
+
+ elsif Nkind (Node) in N_Has_Etype
+ and then Nkind (Parent (Node)) = N_Iterator_Specification
+ and then Node = Name (Parent (Node))
+ then
+ declare
+ Iter : constant Node_Id :=
+ Find_Value_Of_Aspect (Etype (Node), Aspect_Default_Iterator);
+
+ begin
+ if Present (Iter) then
+ Check_And_Freeze_Type (Etype (Iter));
+ end if;
+ end;
end if;
-- No point in posting several errors on the same expression
@@ -8700,10 +8786,77 @@ package body Freeze is
-----------------------
procedure Freeze_Subprogram (E : Entity_Id) is
+ function Check_Extra_Formals (E : Entity_Id) return Boolean;
+ -- Return True if the decoration of the attributes associated with extra
+ -- formals are properly set.
+
procedure Set_Profile_Convention (Subp_Id : Entity_Id);
-- Set the conventions of all anonymous access-to-subprogram formals and
-- result subtype of subprogram Subp_Id to the convention of Subp_Id.
+ -------------------------
+ -- Check_Extra_Formals --
+ -------------------------
+
+ function Check_Extra_Formals (E : Entity_Id) return Boolean is
+ Last_Formal : Entity_Id := Empty;
+ Formal : Entity_Id;
+ Has_Extra_Formals : Boolean := False;
+
+ begin
+ -- No check required if expansion is disabled because extra
+ -- formals are only generated when we are generating code.
+ -- See Create_Extra_Formals.
+
+ if not Expander_Active then
+ return True;
+ end if;
+
+ -- Check attribute Extra_Formal: If available, it must be set only
+ -- on the last formal of E.
+
+ Formal := First_Formal (E);
+ while Present (Formal) loop
+ if Present (Extra_Formal (Formal)) then
+ if Has_Extra_Formals then
+ return False;
+ end if;
+
+ Has_Extra_Formals := True;
+ end if;
+
+ Last_Formal := Formal;
+ Next_Formal (Formal);
+ end loop;
+
+ -- Check attribute Extra_Accessibility_Of_Result
+
+ if Ekind (E) in E_Function | E_Subprogram_Type
+ and then Needs_Result_Accessibility_Level (E)
+ and then No (Extra_Accessibility_Of_Result (E))
+ then
+ return False;
+ end if;
+
+ -- Check attribute Extra_Formals: If E has extra formals, then this
+ -- attribute must point to the first extra formal of E.
+
+ if Has_Extra_Formals then
+ return Present (Extra_Formals (E))
+ and then Present (Extra_Formal (Last_Formal))
+ and then Extra_Formal (Last_Formal) = Extra_Formals (E);
+
+ -- When E has no formals, the first extra formal is available through
+ -- the Extra_Formals attribute.
+
+ elsif Present (Extra_Formals (E)) then
+ return No (First_Formal (E));
+
+ else
+ return True;
+ end if;
+ end Check_Extra_Formals;
+
----------------------------
-- Set_Profile_Convention --
----------------------------
@@ -8840,9 +8993,29 @@ package body Freeze is
if not Has_Foreign_Convention (E) then
if No (Extra_Formals (E)) then
- Create_Extra_Formals (E);
+
+ -- Extra formals are shared by derived subprograms; therefore, if
+ -- the ultimate alias of E has been frozen before E then the extra
+ -- formals have been added, but the attribute Extra_Formals is
+ -- still unset (and must be set now).
+
+ if Present (Alias (E))
+ and then Is_Frozen (Ultimate_Alias (E))
+ and then Present (Extra_Formals (Ultimate_Alias (E)))
+ and then Last_Formal (Ultimate_Alias (E)) = Last_Formal (E)
+ then
+ Set_Extra_Formals (E, Extra_Formals (Ultimate_Alias (E)));
+
+ if Ekind (E) = E_Function then
+ Set_Extra_Accessibility_Of_Result (E,
+ Extra_Accessibility_Of_Result (Ultimate_Alias (E)));
+ end if;
+ else
+ Create_Extra_Formals (E);
+ end if;
end if;
+ pragma Assert (Check_Extra_Formals (E));
Set_Mechanisms (E);
-- If this is convention Ada and a Valued_Procedure, that's odd
@@ -9059,11 +9232,11 @@ package body Freeze is
-- directly.
if Nkind (Dcopy) = N_Identifier
- or else Nkind_In (Dcopy, N_Expanded_Name,
- N_Integer_Literal,
- N_Character_Literal,
- N_String_Literal,
- N_Real_Literal)
+ or else Nkind (Dcopy) in N_Expanded_Name
+ | N_Integer_Literal
+ | N_Character_Literal
+ | N_String_Literal
+ | N_Real_Literal
or else (Nkind (Dcopy) = N_Attribute_Reference
and then Attribute_Name (Dcopy) = Name_Null_Parameter)
or else Known_Null (Dcopy)
diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads
index 8df3a30..56061a07 100644
--- a/gcc/ada/freeze.ads
+++ b/gcc/ada/freeze.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb
index 1cc143a..b194741 100644
--- a/gcc/ada/frontend.adb
+++ b/gcc/ada/frontend.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -66,6 +66,7 @@ with Sinput.L; use Sinput.L;
with SCIL_LL;
with Tbuild; use Tbuild;
with Types; use Types;
+with VAST;
procedure Frontend is
begin
@@ -381,6 +382,16 @@ begin
Warn_On_Non_Local_Exception := True;
end if;
+ -- Disable Initialize_Scalars for runtime files to avoid circular
+ -- dependencies.
+
+ if Initialize_Scalars
+ and then Fname.Is_Predefined_File_Name (File_Name (Main_Source_File))
+ then
+ Initialize_Scalars := False;
+ Init_Or_Norm_Scalars := Normalize_Scalars;
+ end if;
+
-- Now on to the semantics. Skip if in syntax only mode
if Operating_Mode /= Check_Syntax then
@@ -412,14 +423,15 @@ begin
-- Cleanup processing after completing main analysis
- -- Comment needed for ASIS mode test and GNATprove mode test???
+ -- In GNATprove_Mode we do not perform most expansions but body
+ -- instantiation is needed.
pragma Assert
(Operating_Mode = Generate_Code
or else Operating_Mode = Check_Semantics);
if Operating_Mode = Generate_Code
- or else (ASIS_Mode or GNATprove_Mode)
+ or else GNATprove_Mode
then
Instantiate_Bodies;
end if;
@@ -504,6 +516,12 @@ begin
null;
end if;
+ -- Verify the validity of the tree
+
+ if Debug_Flag_Underscore_VV then
+ VAST.Check_Tree (Cunit (Main_Unit));
+ end if;
+
-- Dump the source now. Note that we do this as soon as the analysis
-- of the tree is complete, because it is not just a dump in the case
-- of -gnatD, where it rewrites all source locations in the tree.
diff --git a/gcc/ada/frontend.ads b/gcc/ada/frontend.ads
index 363ad43..6ec3969 100644
--- a/gcc/ada/frontend.ads
+++ b/gcc/ada/frontend.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in
index acbe2b87..7d2ea52 100644
--- a/gcc/ada/gcc-interface/Make-lang.in
+++ b/gcc/ada/gcc-interface/Make-lang.in
@@ -302,6 +302,7 @@ GNAT_ADA_OBJS = \
ada/exp_intr.o \
ada/exp_pakd.o \
ada/exp_prag.o \
+ ada/exp_put_image.o \
ada/exp_sel.o \
ada/exp_smem.o \
ada/exp_strm.o \
@@ -472,9 +473,6 @@ GNAT_ADA_OBJS = \
ada/table.o \
ada/targparm.o \
ada/tbuild.o \
- ada/tree_gen.o \
- ada/tree_in.o \
- ada/tree_io.o \
ada/treepr.o \
ada/treeprs.o \
ada/ttypes.o \
@@ -484,6 +482,7 @@ GNAT_ADA_OBJS = \
ada/urealp.o \
ada/usage.o \
ada/validsw.o \
+ ada/vast.o \
ada/warnsw.o \
ada/widechar.o
@@ -632,7 +631,6 @@ GNATBIND_OBJS = \
ada/table.o \
ada/targext.o \
ada/targparm.o \
- ada/tree_io.o \
ada/types.o \
ada/uintp.o \
ada/uname.o \
@@ -1040,7 +1038,7 @@ ada/sdefault.o : ada/libgnat/ada.ads ada/libgnat/a-except.ads ada/libgnat/a-uncc
ada/libgnat/s-exctab.ads ada/libgnat/s-memory.ads ada/libgnat/s-os_lib.ads ada/libgnat/s-parame.ads \
ada/libgnat/s-stalib.ads ada/libgnat/s-strops.ads ada/libgnat/s-sopco3.ads ada/libgnat/s-sopco4.ads \
ada/libgnat/s-sopco5.ads ada/libgnat/s-string.ads ada/libgnat/s-traent.ads ada/libgnat/s-unstyp.ads \
- ada/libgnat/s-wchcon.ads ada/libgnat/system.ads ada/table.adb ada/table.ads ada/tree_io.ads \
+ ada/libgnat/s-wchcon.ads ada/libgnat/system.ads ada/table.adb ada/table.ads \
ada/types.ads ada/libgnat/unchdeal.ads ada/libgnat/unchconv.ads
# Special flags - see gcc-interface/Makefile.in for the template.
diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in
index 3342e33..6177d75 100644
--- a/gcc/ada/gcc-interface/Makefile.in
+++ b/gcc/ada/gcc-interface/Makefile.in
@@ -318,7 +318,7 @@ GNATLINK_OBJS = gnatlink.o \
a-except.o ali.o alloc.o butil.o casing.o csets.o debug.o fmap.o fname.o \
gnatvsn.o hostparm.o indepsw.o interfac.o i-c.o i-cstrin.o namet.o opt.o \
osint.o output.o rident.o s-exctab.o s-secsta.o s-stalib.o s-stoele.o \
- sdefault.o snames.o stylesw.o switch.o system.o table.o targparm.o tree_io.o \
+ sdefault.o snames.o stylesw.o switch.o system.o table.o targparm.o \
types.o validsw.o widechar.o
GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o alloc.o \
@@ -330,7 +330,7 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o alloc.o \
s-secsta.o s-stalib.o s-stoele.o scans.o scng.o sdefault.o sfn_scan.o \
s-purexc.o s-htable.o scil_ll.o sem_aux.o sinfo.o sinput.o sinput-c.o \
snames.o stand.o stringt.o styleg.o stylesw.o system.o validsw.o \
- switch.o switch-m.o table.o targparm.o tempdir.o tree_io.o types.o uintp.o \
+ switch.o switch-m.o table.o targparm.o tempdir.o types.o uintp.o \
uname.o urealp.o usage.o widechar.o \
$(EXTRA_GNATMAKE_OBJS)
@@ -895,7 +895,7 @@ ADA_RTL_DSO_DIR = $(toolexeclibdir)
# need to keep the frame pointer in tracebak.o to pop the stack properly on
# some targets.
-tracebak.o : tracebak.c tb-gcc.c
+tracebak.o : tracebak.c
$(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) \
$(INCLUDES) $(NO_OMIT_ADAFLAGS) $< $(OUTPUT_OPTION)
diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h
index acea5d1..461fa2b 100644
--- a/gcc/ada/gcc-interface/ada-tree.h
+++ b/gcc/ada/gcc-interface/ada-tree.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -73,15 +73,15 @@ do { \
#define TYPE_IS_FAT_POINTER_P(NODE) \
(TREE_CODE (NODE) == RECORD_TYPE && TYPE_FAT_POINTER_P (NODE))
-/* For integral types and array types, nonzero if this is a packed array type
- used for bit-packed types. Such types should not be extended to a larger
- size or validated against a specified size. */
-#define TYPE_PACKED_ARRAY_TYPE_P(NODE) \
+/* For integral types and array types, nonzero if this is an implementation
+ type for a bit-packed array type. Such types should not be extended to a
+ larger size or validated against a specified size. */
+#define TYPE_BIT_PACKED_ARRAY_TYPE_P(NODE) \
TYPE_LANG_FLAG_0 (TREE_CHECK2 (NODE, INTEGER_TYPE, ARRAY_TYPE))
-#define TYPE_IS_PACKED_ARRAY_TYPE_P(NODE) \
+#define BIT_PACKED_ARRAY_TYPE_P(NODE) \
((TREE_CODE (NODE) == INTEGER_TYPE || TREE_CODE (NODE) == ARRAY_TYPE) \
- && TYPE_PACKED_ARRAY_TYPE_P (NODE))
+ && TYPE_BIT_PACKED_ARRAY_TYPE_P (NODE))
/* For FUNCTION_TYPE and METHOD_TYPE, nonzero if the function returns by
direct reference, i.e. the callee returns a pointer to a memory location
@@ -196,7 +196,7 @@ do { \
types. */
#define TYPE_IMPL_PACKED_ARRAY_P(NODE) \
((TREE_CODE (NODE) == ARRAY_TYPE && TYPE_PACKED (NODE)) \
- || (TREE_CODE (NODE) == INTEGER_TYPE && TYPE_PACKED_ARRAY_TYPE_P (NODE)))
+ || (TREE_CODE (NODE) == INTEGER_TYPE && TYPE_BIT_PACKED_ARRAY_TYPE_P (NODE)))
/* True for types that can hold a debug type. */
#define TYPE_CAN_HAVE_DEBUG_TYPE_P(NODE) (!TYPE_IMPL_PACKED_ARRAY_P (NODE))
@@ -525,13 +525,6 @@ do { \
#define SET_DECL_INDUCTION_VAR(NODE, X) \
SET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE), X)
-/* In a VAR_DECL without the DECL_LOOP_PARM_P flag set and that is a renaming
- pointer, points to the object being renamed, if any. */
-#define DECL_RENAMED_OBJECT(NODE) \
- GET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE))
-#define SET_DECL_RENAMED_OBJECT(NODE, X) \
- SET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE), X)
-
/* In a TYPE_DECL, points to the parallel type if any, otherwise 0. */
#define DECL_PARALLEL_TYPE(NODE) \
GET_DECL_LANG_SPECIFIC (TYPE_DECL_CHECK (NODE))
diff --git a/gcc/ada/gcc-interface/ada.h b/gcc/ada/gcc-interface/ada.h
index 197ab95..c5a1916 100644
--- a/gcc/ada/gcc-interface/ada.h
+++ b/gcc/ada/gcc-interface/ada.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2013, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/gcc-interface/cuintp.c b/gcc/ada/gcc-interface/cuintp.c
index 8233f68..dada72a 100644
--- a/gcc/ada/gcc-interface/cuintp.c
+++ b/gcc/ada/gcc-interface/cuintp.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 80dfc55..025714b 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -230,7 +230,7 @@ static Uint annotate_value (tree);
static void annotate_rep (Entity_Id, tree);
static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
static vec<subst_pair> build_subst_list (Entity_Id, Entity_Id, bool);
-static vec<variant_desc> build_variant_list (tree, vec<subst_pair>,
+static vec<variant_desc> build_variant_list (tree, Node_Id, vec<subst_pair>,
vec<variant_desc>);
static tree maybe_saturate_size (tree);
static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool,
@@ -248,7 +248,7 @@ static tree create_variant_part_from (tree, vec<variant_desc>, tree,
static void copy_and_substitute_in_size (tree, tree, vec<subst_pair>);
static void copy_and_substitute_in_layout (Entity_Id, Entity_Id, tree, tree,
vec<subst_pair>, bool);
-static void associate_original_type_to_packed_array (tree, Entity_Id);
+static tree associate_original_type_to_packed_array (tree, Entity_Id);
static const char *get_entity_char (Entity_Id);
/* The relevant constituents of a subprogram binding to a GCC builtin. Used
@@ -280,6 +280,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
{
/* The construct that declared the entity. */
const Node_Id gnat_decl = Declaration_Node (gnat_entity);
+ /* The object that the entity renames, if any. */
+ const Entity_Id gnat_renamed_obj = Renamed_Object (gnat_entity);
/* The kind of the entity. */
const Entity_Kind kind = Ekind (gnat_entity);
/* True if this is a type. */
@@ -327,7 +329,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* Contains the list of attributes directly attached to the entity. */
struct attrib *attr_list = NULL;
- /* Since a use of an Itype is a definition, process it as such if it is in
+ /* Since a use of an itype is a definition, process it as such if it is in
the main unit, except for E_Access_Subtype because it's actually a use
of its base type, see below. */
if (!definition
@@ -375,7 +377,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
}
}
- /* This abort means the Itype has an incorrect scope, i.e. that its
+ /* This abort means the itype has an incorrect scope, i.e. that its
scope does not correspond to the subprogram it is first used in. */
gcc_unreachable ();
}
@@ -448,6 +450,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
If we are not defining it, it must be a type or an entity that is defined
elsewhere or externally, otherwise we should have defined it already.
+ In other words, the failure of this assertion typically arises when a
+ reference to an entity (type or object) is made before its declaration,
+ either directly or by means of a freeze node which is incorrectly placed.
+ This can also happen for an entity referenced out of context, for example
+ a parameter outside of the subprogram where it is declared. GNAT_ENTITY
+ is the N_Defining_Identifier of the entity, the problematic N_Identifier
+ being the argument passed to Identifier_to_gnu in the parent frame.
+
One exception is for an entity, typically an inherited operation, which is
a local alias for the parent's operation. It is neither defined, since it
is an inherited operation, nor public, since it is declared in the current
@@ -636,7 +646,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& !gnu_expr
&& No (Address_Clause (gnat_entity))
&& !No_Initialization (gnat_decl)
- && No (Renamed_Object (gnat_entity)))
+ && No (gnat_renamed_obj))
{
gnu_decl = error_mark_node;
saved = true;
@@ -692,7 +702,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& !Treat_As_Volatile (gnat_entity)
&& (((Nkind (gnat_decl) == N_Object_Declaration)
&& Present (Expression (gnat_decl)))
- || Present (Renamed_Object (gnat_entity))
+ || Present (gnat_renamed_obj)
|| imported_p));
bool inner_const_flag = const_flag;
bool static_flag = Is_Statically_Allocated (gnat_entity);
@@ -704,20 +714,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
bool mutable_p = false;
bool used_by_ref = false;
tree gnu_ext_name = NULL_TREE;
- tree renamed_obj = NULL_TREE;
tree gnu_ada_size = NULL_TREE;
/* We need to translate the renamed object even though we are only
referencing the renaming. But it may contain a call for which
we'll generate a temporary to hold the return value and which
is part of the definition of the renaming, so discard it. */
- if (Present (Renamed_Object (gnat_entity)) && !definition)
+ if (Present (gnat_renamed_obj) && !definition)
{
if (kind == E_Exception)
gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
NULL_TREE, false);
else
- gnu_expr = gnat_to_gnu_external (Renamed_Object (gnat_entity));
+ gnu_expr = gnat_to_gnu_external (gnat_renamed_obj);
}
/* Get the type after elaborating the renamed object. */
@@ -764,7 +773,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* Reject non-renamed objects whose type is an unconstrained array or
any object whose type is a dummy type or void. */
if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
- && No (Renamed_Object (gnat_entity)))
+ && No (gnat_renamed_obj))
|| TYPE_IS_DUMMY_P (gnu_type)
|| TREE_CODE (gnu_type) == VOID_TYPE)
{
@@ -806,7 +815,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
initializing expression, in which case we can get the size from
that. Note that the resulting size may still be a variable, so
this may end up with an indirect allocation. */
- if (No (Renamed_Object (gnat_entity))
+ if (No (gnat_renamed_obj)
&& CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
{
if (gnu_expr && kind == E_Constant)
@@ -882,7 +891,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& integer_zerop (TYPE_SIZE (gnu_type))
&& !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
&& !Is_Constr_Subt_For_UN_Aliased (gnat_type)
- && No (Renamed_Object (gnat_entity))
+ && No (gnat_renamed_obj)
&& No (Address_Clause (gnat_entity)))
gnu_size = bitsize_unit_node;
@@ -901,7 +910,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& !Is_Constr_Subt_For_UN_Aliased (gnat_type)
&& !Is_Exported (gnat_entity)
&& !imported_p
- && No (Renamed_Object (gnat_entity))
+ && No (gnat_renamed_obj)
&& No (Address_Clause (gnat_entity))))
&& TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
align = promote_object_alignment (gnu_type, gnat_entity);
@@ -945,7 +954,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
because we don't support dynamic alignment. */
if (align == 0
&& Ekind (gnat_type) == E_Class_Wide_Subtype
- && No (Renamed_Object (gnat_entity))
+ && No (gnat_renamed_obj)
&& No (Address_Clause (gnat_entity)))
align = get_target_system_allocator_alignment () * BITS_PER_UNIT;
@@ -961,7 +970,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
if (align == 0
&& MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
&& !FLOAT_TYPE_P (gnu_type)
- && !const_flag && No (Renamed_Object (gnat_entity))
+ && !const_flag && No (gnat_renamed_obj)
&& !imported_p && No (Address_Clause (gnat_entity))
&& kind != E_Out_Parameter
&& (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
@@ -969,16 +978,25 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
align = MINIMUM_ATOMIC_ALIGNMENT;
#endif
- /* Make a new type with the desired size and alignment, if needed.
- But do not take into account alignment promotions to compute the
- size of the object. */
+ /* Do not take into account aliased adjustments or alignment promotions
+ to compute the size of the object. */
tree gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
+
+ /* If the object is aliased, of a constrained nominal subtype and its
+ size might be zero at run time, we force at least the unit size. */
+ if (Is_Aliased (gnat_entity)
+ && !Is_Constr_Subt_For_UN_Aliased (gnat_type)
+ && Is_Array_Type (Underlying_Type (gnat_type))
+ && !TREE_CONSTANT (gnu_object_size))
+ gnu_size = size_binop (MAX_EXPR, gnu_object_size, bitsize_unit_node);
+
+ /* Make a new type with the desired size and alignment, if needed. */
if (gnu_size || align > 0)
{
tree orig_type = gnu_type;
gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
- false, false, definition, true);
+ false, definition, true);
/* If the nominal subtype of the object is unconstrained and its
size is not fixed, compute the Ada size from the Ada size of
@@ -1004,7 +1022,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
renaming can be applied to objects that are not names in Ada.
This processing needs to be applied to the raw expression so as
to make it more likely to rename the underlying object. */
- if (Present (Renamed_Object (gnat_entity)))
+ if (Present (gnat_renamed_obj))
{
/* If the renamed object had padding, strip off the reference to
the inner object and reset our type. */
@@ -1022,13 +1040,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
else if (type_is_padding_self_referential (TREE_TYPE (gnu_expr)))
gnu_type = TREE_TYPE (gnu_expr);
- /* Case 1: if this is a constant renaming stemming from a function
- call, treat it as a normal object whose initial value is what
- is being renamed. RM 3.3 says that the result of evaluating a
- function call is a constant object. Therefore, it can be the
- inner object of a constant renaming and the renaming must be
- fully instantiated, i.e. it cannot be a reference to (part of)
- an existing object. And treat other rvalues the same way. */
+ /* If this is a constant renaming stemming from a function call,
+ treat it as a normal object whose initial value is what is being
+ renamed. RM 3.3 says that the result of evaluating a function
+ call is a constant object. Therefore, it can be the inner
+ object of a constant renaming and the renaming must be fully
+ instantiated, i.e. it cannot be a reference to (part of) an
+ existing object. And treat other rvalues the same way. */
tree inner = gnu_expr;
while (handled_component_p (inner) || CONVERT_EXPR_P (inner))
inner = TREE_OPERAND (inner, 0);
@@ -1070,89 +1088,75 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& DECL_RETURN_VALUE_P (inner)))
;
- /* Case 2: if the renaming entity need not be materialized, use
- the elaborated renamed expression for the renaming. But this
- means that the caller is responsible for evaluating the address
- of the renaming in the correct place for the definition case to
- instantiate the SAVE_EXPRs. */
- else if (!Materialize_Entity (gnat_entity))
+ /* Otherwise, this is an lvalue being renamed, so it needs to be
+ elaborated as a reference and substituted for the entity. But
+ this means that we must evaluate the address of the renaming
+ in the definition case to instantiate the SAVE_EXPRs. */
+ else
{
- tree init = NULL_TREE;
+ tree gnu_init = NULL_TREE;
- gnu_decl
- = elaborate_reference (gnu_expr, gnat_entity, definition,
- &init);
+ if (type_annotate_only && TREE_CODE (gnu_expr) == ERROR_MARK)
+ break;
- /* We cannot evaluate the first arm of a COMPOUND_EXPR in the
- correct place for this case. */
- gcc_assert (!init);
+ gnu_expr
+ = elaborate_reference (gnu_expr, gnat_entity, definition,
+ &gnu_init);
- /* No DECL_EXPR will be created so the expression needs to be
+ /* No DECL_EXPR might be created so the expression needs to be
marked manually because it will likely be shared. */
if (global_bindings_p ())
- MARK_VISITED (gnu_decl);
+ MARK_VISITED (gnu_expr);
/* This assertion will fail if the renamed object isn't aligned
enough as to make it possible to honor the alignment set on
the renaming. */
if (align)
{
- unsigned int ralign = DECL_P (gnu_decl)
- ? DECL_ALIGN (gnu_decl)
- : TYPE_ALIGN (TREE_TYPE (gnu_decl));
+ const unsigned int ralign
+ = DECL_P (gnu_expr)
+ ? DECL_ALIGN (gnu_expr)
+ : TYPE_ALIGN (TREE_TYPE (gnu_expr));
gcc_assert (ralign >= align);
}
/* The expression might not be a DECL so save it manually. */
+ gnu_decl = gnu_expr;
save_gnu_tree (gnat_entity, gnu_decl, true);
saved = true;
annotate_object (gnat_entity, gnu_type, NULL_TREE, false);
- break;
- }
- /* Case 3: otherwise, make a constant pointer to the object we
- are renaming and attach the object to the pointer after it is
- elaborated. The object will be referenced directly instead
- of indirectly via the pointer to avoid aliasing problems with
- non-addressable entities. The pointer is called a "renaming"
- pointer in this case. Note that we also need to preserve the
- volatility of the renamed object through the indirection. */
- else
- {
- tree init = NULL_TREE;
+ /* If this is only a reference to the entity, we are done. */
+ if (!definition)
+ break;
- if (TREE_THIS_VOLATILE (gnu_expr) && !TYPE_VOLATILE (gnu_type))
- gnu_type
- = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
- gnu_type = build_reference_type (gnu_type);
- used_by_ref = true;
- const_flag = true;
- volatile_flag = false;
- inner_const_flag = TREE_READONLY (gnu_expr);
- gnu_size = NULL_TREE;
+ /* Otherwise, emit the initialization statement, if any. */
+ if (gnu_init)
+ add_stmt (gnu_init);
- renamed_obj
- = elaborate_reference (gnu_expr, gnat_entity, definition,
- &init);
+ /* If it needs to be materialized for debugging purposes, build
+ the entity as indirect reference to the renamed object. */
+ if (Materialize_Entity (gnat_entity))
+ {
+ gnu_type = build_reference_type (gnu_type);
+ const_flag = true;
+ volatile_flag = false;
- /* The expression needs to be marked manually because it will
- likely be shared, even for a definition since the ADDR_EXPR
- built below can cause the first few nodes to be folded. */
- if (global_bindings_p ())
- MARK_VISITED (renamed_obj);
+ gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr);
- if (type_annotate_only
- && TREE_CODE (renamed_obj) == ERROR_MARK)
- gnu_expr = NULL_TREE;
- else
- {
- gnu_expr
- = build_unary_op (ADDR_EXPR, gnu_type, renamed_obj);
- if (init)
- gnu_expr
- = build_compound_expr (TREE_TYPE (gnu_expr), init,
- gnu_expr);
+ create_var_decl (gnu_entity_name, gnu_ext_name,
+ TREE_TYPE (gnu_expr), gnu_expr,
+ const_flag, Is_Public (gnat_entity),
+ imported_p, static_flag, volatile_flag,
+ artificial_p, debug_info_p, attr_list,
+ gnat_entity, false);
}
+
+ /* Otherwise, instantiate the SAVE_EXPRs if needed. */
+ else if (TREE_SIDE_EFFECTS (gnu_expr))
+ add_stmt (build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr));
+
+ break;
}
}
@@ -1516,7 +1520,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
imported_p || !definition, static_flag,
volatile_flag, artificial_p,
debug_info_p && definition, attr_list,
- gnat_entity, !renamed_obj);
+ gnat_entity, true);
DECL_BY_REF_P (gnu_decl) = used_by_ref;
DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
DECL_CAN_NEVER_BE_NULL_P (gnu_decl) = Can_Never_Be_Null (gnat_entity);
@@ -1544,10 +1548,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
else if (kind == E_Loop_Parameter)
DECL_LOOP_PARM_P (gnu_decl) = 1;
- /* If this is a renaming pointer, attach the renamed object to it. */
- if (renamed_obj)
- SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
-
/* If this is a constant and we are defining it or it generates a real
symbol at the object level and we are referencing it, we may want
or need to have a true variable to represent it:
@@ -1745,9 +1745,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
{
/* Given RM restrictions on 'Small values, we assume here that
the denominator fits in an int. */
- const tree base = build_int_cst (integer_type_node,
- Rbase (gnat_small_value));
- const tree exponent
+ tree base
+ = build_int_cst (integer_type_node, Rbase (gnat_small_value));
+ tree exponent
= build_int_cst (integer_type_node,
UI_To_Int (Denominator (gnat_small_value)));
scale_factor
@@ -1765,10 +1765,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
if (UI_Is_In_Int_Range (num) && UI_Is_In_Int_Range (den))
{
- const tree gnu_num
+ tree gnu_num
= build_int_cst (integer_type_node,
UI_To_Int (Norm_Num (gnat_small_value)));
- const tree gnu_den
+ tree gnu_den
= build_int_cst (integer_type_node,
UI_To_Int (Norm_Den (gnat_small_value)));
scale_factor = build2 (RDIV_EXPR, integer_type_node,
@@ -1847,8 +1847,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, false);
/* Set the precision to the Esize except for bit-packed arrays. */
- if (Is_Packed_Array_Impl_Type (gnat_entity)
- && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
+ if (Is_Packed_Array_Impl_Type (gnat_entity))
esize = UI_To_Int (RM_Size (gnat_entity));
/* Boolean types with foreign convention have precision 1. */
@@ -1925,11 +1924,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
TYPE_STUB_DECL (gnu_type)
= create_type_stub_decl (gnu_entity_name, gnu_type);
- /* For a packed array, make the original array type a parallel/debug
- type. */
- if (debug_info_p && Is_Packed_Array_Impl_Type (gnat_entity))
- associate_original_type_to_packed_array (gnu_type, gnat_entity);
-
discrete_type:
/* We have to handle clauses that under-align the type specially. */
@@ -1951,19 +1945,30 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
such values), we only get the good bits, since the unused bits
are uninitialized. Both goals are accomplished by wrapping up
the modular type in an enclosing record type. */
- if (Is_Packed_Array_Impl_Type (gnat_entity)
- && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
+ if (Is_Packed_Array_Impl_Type (gnat_entity))
{
- tree gnu_field_type, gnu_field;
+ tree gnu_field_type, gnu_field, t;
+
+ gcc_assert (Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
+ TYPE_BIT_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
+
+ /* Make the original array type a parallel/debug type. */
+ if (debug_info_p)
+ {
+ tree gnu_name
+ = associate_original_type_to_packed_array (gnu_type,
+ gnat_entity);
+ if (gnu_name)
+ gnu_entity_name = gnu_name;
+ }
/* Set the RM size before wrapping up the original type. */
SET_TYPE_RM_SIZE (gnu_type,
UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
- TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
/* Create a stripped-down declaration, mainly for debugging. */
- create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
- gnat_entity);
+ t = create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
+ gnat_entity);
/* Now save it and build the enclosing record type. */
gnu_field_type = gnu_type;
@@ -2002,15 +2007,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
finish_record_type (gnu_type, gnu_field, 2, false);
TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
+ /* Make the original array type a parallel/debug type. Note that
+ gnat_get_array_descr_info needs a TYPE_IMPL_PACKED_ARRAY_P type
+ so we use an intermediate step for standard DWARF. */
if (debug_info_p)
{
- /* Make the original array type a parallel/debug type. */
- associate_original_type_to_packed_array (gnu_type, gnat_entity);
-
- /* Since GNU_TYPE is a padding type around the packed array
- implementation type, the padded type is its debug type. */
if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
SET_TYPE_DEBUG_TYPE (gnu_type, gnu_field_type);
+ else if (DECL_PARALLEL_TYPE (t))
+ add_parallel_type (gnu_type, DECL_PARALLEL_TYPE (t));
}
}
@@ -2024,9 +2029,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* Set the RM size before wrapping the type. */
SET_TYPE_RM_SIZE (gnu_type, gnu_size);
+ /* Create a stripped-down declaration, mainly for debugging. */
+ create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
+ gnat_entity);
+
gnu_type
= maybe_pad_type (gnu_type, TYPE_SIZE (gnu_type), align,
- gnat_entity, false, true, definition, false);
+ gnat_entity, false, definition, false);
TYPE_PACKED (gnu_type) = 1;
SET_TYPE_ADA_SIZE (gnu_type, gnu_size);
@@ -2081,16 +2090,28 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* Array Types and Subtypes
- Unconstrained array types are represented by E_Array_Type and
- constrained array types are represented by E_Array_Subtype. There
- are no actual objects of an unconstrained array type; all we have
- are pointers to that type.
+ In GNAT unconstrained array types are represented by E_Array_Type and
+ constrained array types are represented by E_Array_Subtype. They are
+ translated into UNCONSTRAINED_ARRAY_TYPE and ARRAY_TYPE respectively.
+ But there are no actual objects of an unconstrained array type; all we
+ have are pointers to that type. In addition to the type node itself,
+ 4 other types associated with it are built in the process:
- The following fields are defined on array types and subtypes:
+ 1. the array type (suffix XUA) containing the actual data,
- Component_Type Component type of the array.
- Number_Dimensions Number of dimensions (an int).
- First_Index Type of first index. */
+ 2. the template type (suffix XUB) containng the bounds,
+
+ 3. the fat pointer type (suffix XUP) representing a pointer or a
+ reference to the unconstrained array type:
+ XUP = struct { XUA *, XUB * }
+
+ 4. the object record type (suffix XUT) containing bounds and data:
+ XUT = struct { XUB, XUA }
+
+ The bounds of the array type XUA (de)reference the XUB * field of a
+ PLACEHOLDER_EXPR for the fat pointer type XUP, so the array type XUA
+ is to be interpreted in the context of the fat pointer type XUB for
+ debug info purposes. */
case E_Array_Type:
{
@@ -2102,8 +2123,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
tree gnu_template_reference, gnu_template_fields, gnu_fat_type;
tree *gnu_index_types = XALLOCAVEC (tree, ndim);
tree *gnu_temp_fields = XALLOCAVEC (tree, ndim);
- tree gnu_max_size = size_one_node, tem, t;
- Entity_Id gnat_index, gnat_name;
+ tree gnu_max_size = size_one_node, tem, obj;
+ Entity_Id gnat_index;
int index;
tree comp_type;
@@ -2177,7 +2198,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
TREE_TYPE (tem) = ptr_type_node;
TREE_TYPE (DECL_CHAIN (tem)) = gnu_ptr_template;
TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (gnu_fat_type)) = 0;
- for (t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
+ for (tree t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type);
}
else
@@ -2194,6 +2215,22 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
}
+ /* If the GNAT encodings are used, give the fat pointer type a name.
+ If this is a packed array, tell the debugger how to interpret the
+ underlying bits by fetching that of the implementation type. But
+ in any case, mark it as artificial so the debugger can skip it. */
+ const Entity_Id gnat_name
+ = (Present (Packed_Array_Impl_Type (gnat_entity))
+ && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ ? Packed_Array_Impl_Type (gnat_entity)
+ : gnat_entity;
+ tree xup_name
+ = (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ ? create_concat_name (gnat_name, "XUP")
+ : gnu_entity_name;
+ create_type_decl (xup_name, gnu_fat_type, true, debug_info_p,
+ gnat_entity);
+
/* Build a reference to the template from a PLACEHOLDER_EXPR that
is the fat pointer. This will be used to access the individual
fields once we build them. */
@@ -2295,6 +2332,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
= chainon (gnu_template_fields, gnu_temp_fields[index]);
finish_record_type (gnu_template_type, gnu_template_fields, 0,
debug_info_p);
+ TYPE_CONTEXT (gnu_template_type) = current_function_decl;
TYPE_READONLY (gnu_template_type) = 1;
/* If Component_Size is not already specified, annotate it with the
@@ -2351,14 +2389,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type))
record_component_aliases (gnu_fat_type);
- /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
- corresponding fat pointer. */
- TREE_TYPE (gnu_type) = gnu_fat_type;
- TYPE_POINTER_TO (gnu_type) = gnu_fat_type;
- TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
- SET_TYPE_MODE (gnu_type, BLKmode);
- SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (tem));
-
/* If the maximum size doesn't overflow, use it. */
if (gnu_max_size
&& TREE_CODE (gnu_max_size) == INTEGER_CST
@@ -2366,22 +2396,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& compare_tree_int (gnu_max_size, TYPE_ARRAY_SIZE_LIMIT) <= 0)
TYPE_ARRAY_MAX_SIZE (tem) = gnu_max_size;
+ /* See the above description for the rationale. */
create_type_decl (create_concat_name (gnat_entity, "XUA"), tem,
artificial_p, debug_info_p, gnat_entity);
-
- /* If told to generate GNAT encodings for them (GDB rely on them at the
- moment): give the fat pointer type a name. If this is a packed
- array, tell the debugger how to interpret the underlying bits. */
- if (Present (Packed_Array_Impl_Type (gnat_entity)))
- gnat_name = Packed_Array_Impl_Type (gnat_entity);
- else
- gnat_name = gnat_entity;
- tree xup_name
- = (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
- ? get_entity_name (gnat_name)
- : create_concat_name (gnat_name, "XUP");
- create_type_decl (xup_name, gnu_fat_type, artificial_p, debug_info_p,
- gnat_entity);
+ TYPE_CONTEXT (tem) = gnu_fat_type;
+ TYPE_CONTEXT (TYPE_POINTER_TO (tem)) = gnu_fat_type;
/* Create the type to be designated by thin pointers: a record type for
the array and its template. We used to shift the fields to have the
@@ -2392,14 +2411,22 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
don't have to name them as a GNAT encoding, except if specifically
asked to. */
tree xut_name
- = (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
- ? get_entity_name (gnat_name)
- : create_concat_name (gnat_name, "XUT");
- tem = build_unc_object_type (gnu_template_type, tem, xut_name,
+ = (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ ? create_concat_name (gnat_name, "XUT")
+ : gnu_entity_name;
+ obj = build_unc_object_type (gnu_template_type, tem, xut_name,
debug_info_p);
- SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
- TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
+ SET_TYPE_UNCONSTRAINED_ARRAY (obj, gnu_type);
+ TYPE_OBJECT_RECORD_TYPE (gnu_type) = obj;
+
+ /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
+ corresponding fat pointer. */
+ TREE_TYPE (gnu_type) = gnu_fat_type;
+ TYPE_POINTER_TO (gnu_type) = gnu_fat_type;
+ TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
+ SET_TYPE_MODE (gnu_type, BLKmode);
+ SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (tem));
}
break;
@@ -2685,6 +2712,22 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
set_reverse_storage_order_on_array_type (gnu_type);
if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
set_nonaliased_component_on_array_type (gnu_type);
+
+ /* Kludge to remove the TREE_OVERFLOW flag for the sake of LTO
+ on maximally-sized array types designed by access types. */
+ if (integer_zerop (TYPE_SIZE (gnu_type))
+ && TREE_OVERFLOW (TYPE_SIZE (gnu_type))
+ && Is_Itype (gnat_entity)
+ && (gnat_temp = Associated_Node_For_Itype (gnat_entity))
+ && IN (Nkind (gnat_temp), N_Declaration)
+ && Is_Access_Type (Defining_Entity (gnat_temp))
+ && Is_Entity_Name (First_Index (gnat_entity))
+ && UI_To_Int (RM_Size (Entity (First_Index (gnat_entity))))
+ == BITS_PER_WORD)
+ {
+ TYPE_SIZE (gnu_type) = bitsize_zero_node;
+ TYPE_SIZE_UNIT (gnu_type) = size_zero_node;
+ }
}
/* Attach the TYPE_STUB_DECL in case we have a parallel type. */
@@ -2727,6 +2770,24 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
}
}
+ /* Set the TYPE_PACKED flag on packed array types and also on their
+ implementation types, so that the DWARF back-end can output the
+ appropriate description for them. */
+ TYPE_PACKED (gnu_type)
+ = (Is_Packed (gnat_entity)
+ || Is_Packed_Array_Impl_Type (gnat_entity));
+
+ TYPE_BIT_PACKED_ARRAY_TYPE_P (gnu_type)
+ = (Is_Packed_Array_Impl_Type (gnat_entity)
+ && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
+
+ /* If the maximum size doesn't overflow, use it. */
+ if (gnu_max_size
+ && TREE_CODE (gnu_max_size) == INTEGER_CST
+ && !TREE_OVERFLOW (gnu_max_size)
+ && compare_tree_int (gnu_max_size, TYPE_ARRAY_SIZE_LIMIT) <= 0)
+ TYPE_ARRAY_MAX_SIZE (gnu_type) = gnu_max_size;
+
/* If we need to write out a record type giving the names of the
bounds for debugging purposes, do it now and make the record
type a parallel type. This is not needed for a packed array
@@ -2761,44 +2822,32 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
}
/* If this is a packed array type, make the original array type a
- parallel/debug type. Otherwise, if such GNAT encodings are
- required, do it for the base array type if it isn't artificial to
- make sure it is kept in the debug info. */
+ parallel/debug type. Otherwise, if GNAT encodings are used, do
+ it for the base array type if it is not artificial to make sure
+ that it is kept in the debug info. */
if (debug_info_p)
{
if (Is_Packed_Array_Impl_Type (gnat_entity))
- associate_original_type_to_packed_array (gnu_type,
- gnat_entity);
- else
+ {
+ tree gnu_name
+ = associate_original_type_to_packed_array (gnu_type,
+ gnat_entity);
+ if (gnu_name)
+ gnu_entity_name = gnu_name;
+ }
+
+ else if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
{
tree gnu_base_decl
= gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE,
false);
- if (!DECL_ARTIFICIAL (gnu_base_decl)
- && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+
+ if (!DECL_ARTIFICIAL (gnu_base_decl))
add_parallel_type (gnu_type,
TREE_TYPE (TREE_TYPE (gnu_base_decl)));
}
}
- TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
- = (Is_Packed_Array_Impl_Type (gnat_entity)
- && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
-
- /* Tag top-level ARRAY_TYPE nodes for packed arrays and their
- implementation types as such so that the debug information back-end
- can output the appropriate description for them. */
- TYPE_PACKED (gnu_type)
- = (Is_Packed (gnat_entity)
- || Is_Packed_Array_Impl_Type (gnat_entity));
-
- /* If the maximum size doesn't overflow, use it. */
- if (gnu_max_size
- && TREE_CODE (gnu_max_size) == INTEGER_CST
- && !TREE_OVERFLOW (gnu_max_size)
- && compare_tree_int (gnu_max_size, TYPE_ARRAY_SIZE_LIMIT) <= 0)
- TYPE_ARRAY_MAX_SIZE (gnu_type) = gnu_max_size;
-
/* Set our alias set to that of our base type. This gives all
array subtypes the same alias set. */
relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
@@ -2934,15 +2983,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* Record Types and Subtypes
- The following fields are defined on record types:
-
- Has_Discriminants True if the record has discriminants
- First_Discriminant Points to head of list of discriminants
- First_Entity Points to head of list of fields
- Is_Tagged_Type True if the record is tagged
-
- Implementation of Ada records and discriminated records:
-
A record type definition is transformed into the equivalent of a C
struct definition. The fields that are the discriminants which are
found in the Full_Type_Declaration node and the elements of the
@@ -3347,7 +3387,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* If there are entities in the chain corresponding to components
that we did not elaborate, ensure we elaborate their types if
- they are Itypes. */
+ they are itypes. */
for (gnat_temp = First_Entity (gnat_entity);
Present (gnat_temp);
gnat_temp = Next_Entity (gnat_temp))
@@ -3433,7 +3473,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* When the subtype has discriminants and these discriminants affect
the initial shape it has inherited, factor them in. But for an
- Unchecked_Union (it must be an Itype), just return the type. */
+ Unchecked_Union (it must be an itype), just return the type. */
if (Has_Discriminants (gnat_entity)
&& Stored_Constraint (gnat_entity) != No_Elist
&& Is_Record_Type (gnat_base_type)
@@ -3445,18 +3485,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
gnu_type = make_node (RECORD_TYPE);
TYPE_NAME (gnu_type) = gnu_entity_name;
- if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
- {
- /* Use the ultimate base record type as the debug type.
- Subtypes and derived types bring no useful
- information. */
- Entity_Id gnat_debug_type = gnat_entity;
- while (Etype (gnat_debug_type) != gnat_debug_type)
- gnat_debug_type = Etype (gnat_debug_type);
- tree gnu_debug_type
- = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_debug_type));
- SET_TYPE_DEBUG_TYPE (gnu_type, gnu_debug_type);
- }
TYPE_PACKED (gnu_type) = TYPE_PACKED (gnu_base_type);
TYPE_REVERSE_STORAGE_ORDER (gnu_type)
= Reverse_Storage_Order (gnat_entity);
@@ -3486,7 +3514,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
we are asked to output such encodings, write a record that
shows what we are a subtype of and also make a variable that
indicates our size, if still variable. */
- if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ if (debug_info_p
+ && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
{
tree gnu_subtype_marker = make_node (RECORD_TYPE);
tree gnu_unpad_base_name
@@ -3517,6 +3546,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
true, debug_info_p,
NULL, gnat_entity);
}
+
+ /* Or else, if the subtype is artificial and encodings are not
+ used, use the base record type as the debug type. */
+ else if (debug_info_p
+ && artificial_p
+ && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
+ SET_TYPE_DEBUG_TYPE (gnu_type, gnu_unpad_base_type);
}
/* Otherwise, go down all the components in the new type and make
@@ -3920,16 +3956,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
of its type, so we must elaborate that type now. */
if (Present (Alias (gnat_entity)))
{
- const Entity_Id gnat_renamed = Renamed_Object (gnat_entity);
+ const Entity_Id gnat_alias = Alias (gnat_entity);
- if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
- gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE,
- false);
+ if (Ekind (gnat_alias) == E_Enumeration_Literal)
+ gnat_to_gnu_entity (Etype (gnat_alias), NULL_TREE, false);
- gnu_decl
- = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, false);
+ gnu_decl = gnat_to_gnu_entity (gnat_alias, gnu_expr, false);
- /* Elaborate any Itypes in the parameters of this entity. */
+ /* Elaborate any itypes in the parameters of this entity. */
for (gnat_temp = First_Formal_With_Extras (gnat_entity);
Present (gnat_temp);
gnat_temp = Next_Formal_With_Extras (gnat_temp))
@@ -3937,24 +3971,22 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false);
/* Materialize renamed subprograms in the debugging information
- when the renamed object is compile time known. We can consider
+ when the renamed object is known at compile time; we consider
such renamings as imported declarations.
- Because the parameters in generics instantiation are generally
- materialized as renamings, we ofter end up having both the
+ Because the parameters in generic instantiations are generally
+ materialized as renamings, we often end up having both the
renamed subprogram and the renaming in the same context and with
- the same name: in this case, renaming is both useless debug-wise
+ the same name; in this case, renaming is both useless debug-wise
and potentially harmful as name resolution in the debugger could
return twice the same entity! So avoid this case. */
- if (debug_info_p && !artificial_p
+ if (debug_info_p
+ && !artificial_p
+ && (Ekind (gnat_alias) == E_Function
+ || Ekind (gnat_alias) == E_Procedure)
&& !(get_debug_scope (gnat_entity, NULL)
- == get_debug_scope (gnat_renamed, NULL)
- && Name_Equals (Chars (gnat_entity),
- Chars (gnat_renamed)))
- && Present (gnat_renamed)
- && (Ekind (gnat_renamed) == E_Function
- || Ekind (gnat_renamed) == E_Procedure)
- && gnu_decl
+ == get_debug_scope (gnat_alias, NULL)
+ && Name_Equals (Chars (gnat_entity), Chars (gnat_alias)))
&& TREE_CODE (gnu_decl) == FUNCTION_DECL)
{
tree decl = build_decl (input_location, IMPORTED_DECL,
@@ -4327,15 +4359,20 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& integer_pow2p (gnu_size))
align = MIN (BIGGEST_ALIGNMENT, tree_to_uhwi (gnu_size));
- /* See if we need to pad the type. If we did, and made a record,
- the name of the new type may be changed. So get it back for
- us when we make the new TYPE_DECL below. */
+ /* See if we need to pad the type. If we did and built a new type,
+ then create a stripped-down declaration for the original type,
+ mainly for debugging, unless there was already one. */
if (gnu_size || align > 0)
- gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
- false, !gnu_decl, definition, false);
+ {
+ tree orig_type = gnu_type;
+
+ gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
+ false, definition, false);
- if (TYPE_IS_PADDING_P (gnu_type))
- gnu_entity_name = TYPE_IDENTIFIER (gnu_type);
+ if (gnu_type != orig_type && !gnu_decl)
+ create_type_decl (gnu_entity_name, orig_type, true, debug_info_p,
+ gnat_entity);
+ }
/* Now set the RM size of the type. We cannot do it before padding
because we need to accept arbitrary RM sizes on integral types. */
@@ -4792,7 +4829,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
force_global--;
/* If this is a packed array type whose original array type is itself
- an Itype without freeze node, make sure the latter is processed. */
+ an itype without freeze node, make sure the latter is processed. */
if (Is_Packed_Array_Impl_Type (gnat_entity)
&& Is_Itype (Original_Array_Type (gnat_entity))
&& No (Freeze_Node (Original_Array_Type (gnat_entity)))
@@ -5082,13 +5119,14 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
bool debug_info_p)
{
const Entity_Id gnat_type = Component_Type (gnat_array);
+ const bool is_bit_packed = Is_Bit_Packed_Array (gnat_array);
tree gnu_type = gnat_to_gnu_type (gnat_type);
- bool has_packed_components = Is_Bit_Packed_Array (gnat_array);
tree gnu_comp_size;
+ bool has_packed_components;
unsigned int max_align;
/* If an alignment is specified, use it as a cap on the component type
- so that it can be honored for the whole type. But ignore it for the
+ so that it can be honored for the whole type, but ignore it for the
original type of packed array types. */
if (No (Packed_Array_Impl_Type (gnat_array))
&& Known_Alignment (gnat_array))
@@ -5098,9 +5136,9 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
/* Try to get a packable form of the component if needed. */
if ((Is_Packed (gnat_array) || Has_Component_Size_Clause (gnat_array))
+ && !is_bit_packed
&& !Has_Aliased_Components (gnat_array)
&& !Strict_Alignment (gnat_type)
- && !has_packed_components
&& RECORD_OR_UNION_TYPE_P (gnu_type)
&& !TYPE_FAT_POINTER_P (gnu_type)
&& tree_fits_uhwi_p (TYPE_SIZE (gnu_type)))
@@ -5108,6 +5146,8 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
gnu_type = make_packable_type (gnu_type, false, max_align);
has_packed_components = true;
}
+ else
+ has_packed_components = is_bit_packed;
/* Get and validate any specified Component_Size. */
gnu_comp_size
@@ -5130,9 +5170,10 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
gnu_comp_size = bitsize_unit_node;
/* Honor the component size. This is not needed for bit-packed arrays. */
- if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array))
+ if (gnu_comp_size && !is_bit_packed)
{
tree orig_type = gnu_type;
+ unsigned int gnu_comp_align;
gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
@@ -5140,8 +5181,22 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
else
orig_type = gnu_type;
- gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
- true, false, definition, true);
+ /* We need to make sure that the size is a multiple of the alignment.
+ But we do not misalign the component type because of the alignment
+ of the array type here; this either must have been done earlier in
+ the packed case or should be rejected in the non-packed case. */
+ if (TREE_CODE (gnu_comp_size) == INTEGER_CST)
+ {
+ const unsigned HOST_WIDE_INT int_size = tree_to_uhwi (gnu_comp_size);
+ gnu_comp_align = int_size & -int_size;
+ if (gnu_comp_align > TYPE_ALIGN (gnu_type))
+ gnu_comp_align = 0;
+ }
+ else
+ gnu_comp_align = 0;
+
+ gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, gnu_comp_align,
+ gnat_array, true, definition, true);
/* If a padding record was made, declare it now since it will never be
declared otherwise. This is necessary to ensure that its subtrees
@@ -5168,7 +5223,7 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
= size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
TYPE_PADDING_FOR_COMPONENT (gnu_type)
= maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
- true, false, definition, true);
+ true, definition, true);
gnu_type = TYPE_PADDING_FOR_COMPONENT (gnu_type);
create_type_decl (TYPE_NAME (gnu_type), gnu_type, true, debug_info_p,
gnat_array);
@@ -5184,8 +5239,8 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
storage order to the padding type since it is the innermost enclosing
aggregate type around the scalar. */
if (TYPE_IS_PADDING_P (gnu_type)
+ && !is_bit_packed
&& Reverse_Storage_Order (gnat_array)
- && !Is_Bit_Packed_Array (gnat_array)
&& Is_Scalar_Type (gnat_type))
gnu_type = set_reverse_storage_order_on_pad_type (gnu_type);
@@ -5319,19 +5374,13 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
if (foreign
- || (!must_pass_by_ref (unpadded_type)
- && mech != By_Reference
+ || (mech != By_Reference
+ && !must_pass_by_ref (unpadded_type)
&& (mech == By_Copy || !default_pass_by_ref (unpadded_type))
&& TYPE_ALIGN (unpadded_type) >= TYPE_ALIGN (gnu_param_type)))
gnu_param_type = unpadded_type;
}
- /* If this is a read-only parameter, make a variant of the type that is
- read-only. ??? However, if this is a self-referential type, the type
- can be very complex, so skip it for now. */
- if (ro_param && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
- gnu_param_type = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
-
/* For foreign conventions, pass arrays as pointers to the element type.
First check for unconstrained array and get the underlying array. */
if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
@@ -5348,11 +5397,6 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
gnu_param_type = TREE_TYPE (gnu_param_type);
gnu_param_type = TREE_TYPE (gnu_param_type);
-
- if (ro_param)
- gnu_param_type
- = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
-
gnu_param_type = build_pointer_type (gnu_param_type);
by_component_ptr = true;
}
@@ -5419,7 +5463,10 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
&& (!type_requires_init_of_formal (Etype (gnat_param))
|| Is_Init_Proc (gnat_subprog)
|| by_return))
- return gnu_param_type;
+ {
+ Set_Mechanism (gnat_param, By_Copy);
+ return gnu_param_type;
+ }
gnu_param = create_param_decl (gnu_param_name, gnu_param_type);
TREE_READONLY (gnu_param) = ro_param || by_ref || by_component_ptr;
@@ -5681,6 +5728,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
{
const Entity_Kind kind = Ekind (gnat_subprog);
const bool method_p = is_cplusplus_method (gnat_subprog);
+ const bool variadic = IN (Convention (gnat_subprog), Convention_C_Variadic);
Entity_Id gnat_return_type = Etype (gnat_subprog);
Entity_Id gnat_param;
tree gnu_type = present_gnu_tree (gnat_subprog)
@@ -5713,7 +5761,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
bool return_by_invisi_ref_p = false;
bool return_unconstrained_p = false;
bool incomplete_profile_p = false;
- unsigned int num;
+ int num;
/* Look into the return type and get its associated GCC tree if it is not
void, and then compute various flags for the subprogram type. But make
@@ -5815,8 +5863,8 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
}
gnu_return_type = maybe_pad_type (gnu_return_type, max_return_size,
- 0, gnat_subprog, false, false,
- definition, true);
+ 0, gnat_subprog, false, definition,
+ true);
/* Declare it now since it will never be declared otherwise. This
is necessary to ensure that its subtrees are properly marked. */
@@ -5883,6 +5931,11 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
tree gnu_param, gnu_param_type;
bool cico = false;
+ /* For a variadic C function, do not build unnamed parameters. */
+ if (variadic
+ && num == (Convention (gnat_subprog) - Convention_C_Variadic_0))
+ break;
+
/* Fetch an existing parameter with complete type and reuse it. But we
didn't save the CICO property so we can only do it for In parameters
or parameters passed by reference. */
@@ -6116,7 +6169,8 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
/* The lists have been built in reverse. */
gnu_param_type_list = nreverse (gnu_param_type_list);
- gnu_param_type_list = chainon (gnu_param_type_list, void_list_node);
+ if (!variadic)
+ gnu_param_type_list = chainon (gnu_param_type_list, void_list_node);
gnu_param_list = nreverse (gnu_param_list);
gnu_cico_list = nreverse (gnu_cico_list);
@@ -6698,13 +6752,13 @@ elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, const char *s,
/* If we don't need a value and this is static or a discriminant,
we don't need to do anything. */
if (!need_value
- && (Is_OK_Static_Expression (gnat_expr)
+ && (Compile_Time_Known_Value (gnat_expr)
|| (Nkind (gnat_expr) == N_Identifier
&& Ekind (Entity (gnat_expr)) == E_Discriminant)))
return NULL_TREE;
/* If it's a static expression, we don't need a variable for debugging. */
- if (need_debug && Is_OK_Static_Expression (gnat_expr))
+ if (need_debug && Compile_Time_Known_Value (gnat_expr))
need_debug = false;
/* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
@@ -6769,6 +6823,18 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s,
&& Nkind (Associated_Node_For_Itype (gnat_entity))
== N_Loop_Parameter_Specification));
+ /* If the GNAT encodings are not used, we don't need a variable for debug
+ info purposes if the expression is a constant or another variable, but
+ we need to be careful because we do not generate debug info for external
+ variables so DECL_IGNORED_P is not stable across units. */
+ if (need_debug
+ && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL
+ && (TREE_CONSTANT (gnu_expr)
+ || (!expr_public_p
+ && DECL_P (gnu_expr)
+ && !DECL_IGNORED_P (gnu_expr))))
+ need_debug = false;
+
/* Now create it, possibly only for debugging purposes. */
if (use_variable || need_debug)
{
@@ -6789,10 +6855,7 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s,
variable only if the variable is used by the generated code.
Returning the variable ensures the caller will use it in generated
code. Note that there is no need for a location if the debug info
- contains an integer constant.
- TODO: when the encoding-based debug scheme is dropped, move this
- condition to the top-level IF block: we will not need to create a
- variable anymore in such cases, then. */
+ contains an integer constant. */
if (use_variable || (need_debug && !TREE_CONSTANT (gnu_expr)))
return gnu_decl;
}
@@ -7162,7 +7225,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
if (align > 0)
gnu_field_type
= maybe_pad_type (gnu_field_type, NULL_TREE, align, gnat_field,
- false, false, definition, true);
+ false, definition, true);
check_ok_for_atomic_type (gnu_field_type, gnat_field, false);
}
@@ -7171,12 +7234,12 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
{
Entity_Id gnat_parent = Parent_Subtype (gnat_record_type);
- /* Ensure the position does not overlap with the parent subtype, if there
- is one. This test is omitted if the parent of the tagged type has a
- full rep clause since, in this case, component clauses are allowed to
- overlay the space allocated for the parent type and the front-end has
- checked that there are no overlapping components. */
- if (Present (gnat_parent) && !Is_Fully_Repped_Tagged_Type (gnat_parent))
+ /* Ensure the position doesn't overlap with the parent subtype if there
+ is one. It would be impossible to build CONSTRUCTORs and accessing
+ the parent could clobber the component in the extension if directly
+ done. We accept it with -gnatd.K for the sake of compatibility. */
+ if (Present (gnat_parent)
+ && !(Debug_Flag_Dot_KK && Is_Fully_Repped_Tagged_Type (gnat_parent)))
{
tree gnu_parent = gnat_to_gnu_type (gnat_parent);
@@ -7323,7 +7386,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
orig_field_type = gnu_field_type;
gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
- false, false, definition, true);
+ false, definition, true);
/* If a padding record was made, declare it now since it will never be
declared otherwise. This is necessary to ensure that its subtrees
@@ -8798,20 +8861,29 @@ build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
return gnu_list;
}
-/* Scan all fields in QUAL_UNION_TYPE and return a list describing the
- variants of QUAL_UNION_TYPE that are still relevant after applying
- the substitutions described in SUBST_LIST. GNU_LIST is a pre-existing
+/* Scan all fields in {GNU_QUAL_UNION_TYPE,GNAT_VARIANT_PART} and return a list
+ describing the variants of GNU_QUAL_UNION_TYPE that are still relevant after
+ applying the substitutions described in SUBST_LIST. GNU_LIST is an existing
list to be prepended to the newly created entries. */
static vec<variant_desc>
-build_variant_list (tree qual_union_type, vec<subst_pair> subst_list,
- vec<variant_desc> gnu_list)
+build_variant_list (tree gnu_qual_union_type, Node_Id gnat_variant_part,
+ vec<subst_pair> subst_list, vec<variant_desc> gnu_list)
{
+ Node_Id gnat_variant;
tree gnu_field;
- for (gnu_field = TYPE_FIELDS (qual_union_type);
+ for (gnu_field = TYPE_FIELDS (gnu_qual_union_type),
+ gnat_variant
+ = Present (gnat_variant_part)
+ ? First_Non_Pragma (Variants (gnat_variant_part))
+ : Empty;
gnu_field;
- gnu_field = DECL_CHAIN (gnu_field))
+ gnu_field = DECL_CHAIN (gnu_field),
+ gnat_variant
+ = Present (gnat_variant_part)
+ ? Next_Non_Pragma (gnat_variant)
+ : Empty)
{
tree qual = DECL_QUALIFIER (gnu_field);
unsigned int i;
@@ -8830,11 +8902,21 @@ build_variant_list (tree qual_union_type, vec<subst_pair> subst_list,
gnu_list.safe_push (v);
+ /* Annotate the GNAT node if present. */
+ if (Present (gnat_variant))
+ Set_Present_Expr (gnat_variant, annotate_value (qual));
+
/* Recurse on the variant subpart of the variant, if any. */
variant_subpart = get_variant_part (variant_type);
if (variant_subpart)
- gnu_list = build_variant_list (TREE_TYPE (variant_subpart),
- subst_list, gnu_list);
+ gnu_list
+ = build_variant_list (TREE_TYPE (variant_subpart),
+ Present (gnat_variant)
+ ? Variant_Part
+ (Component_List (gnat_variant))
+ : Empty,
+ subst_list,
+ gnu_list);
/* If the new qualifier is unconditionally true, the subsequent
variants cannot be accessed. */
@@ -8928,11 +9010,11 @@ validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
return NULL_TREE;
}
- /* If this is an integral type or a packed array type, the front-end has
- already verified the size, so we need not do it here (which would mean
- checking against the bounds). However, if this is an aliased object,
- it may not be smaller than the type of the object. */
- if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
+ /* If this is an integral type or a bit-packed array type, the front-end has
+ already verified the size, so we need not do it again (which would mean
+ checking against the bounds). However, if this is an aliased object, it
+ may not be smaller than the type of the object. */
+ if ((INTEGRAL_TYPE_P (gnu_type) || BIT_PACKED_ARRAY_TYPE_P (gnu_type))
&& !(kind == VAR_DECL && Is_Aliased (gnat_object)))
return size;
@@ -9030,16 +9112,13 @@ set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
/* Issue an error either if the old size of the object isn't a constant or
if the new size is smaller than it. The front-end has already verified
- this for scalar and packed array types. */
+ this for scalar and bit-packed array types. */
if (TREE_CODE (old_size) != INTEGER_CST
|| TREE_OVERFLOW (old_size)
|| (AGGREGATE_TYPE_P (gnu_type)
- && !(TREE_CODE (gnu_type) == ARRAY_TYPE
- && TYPE_PACKED_ARRAY_TYPE_P (gnu_type))
+ && !BIT_PACKED_ARRAY_TYPE_P (gnu_type)
&& !(TYPE_IS_PADDING_P (gnu_type)
- && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE
- && TYPE_PACKED_ARRAY_TYPE_P
- (TREE_TYPE (TYPE_FIELDS (gnu_type))))
+ && BIT_PACKED_ARRAY_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_type))))
&& tree_int_cst_lt (size, old_size)))
{
if (Present (gnat_attr_node))
@@ -9721,7 +9800,7 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type,
Entity_Id gnat_old_type,
tree gnu_new_type,
tree gnu_old_type,
- vec<subst_pair> gnu_subst_list,
+ vec<subst_pair> subst_list,
bool debug_info_p)
{
const bool is_subtype = (Ekind (gnat_new_type) == E_Record_Subtype);
@@ -9740,11 +9819,18 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type,
build a new qualified union for the variants that are still relevant. */
if (gnu_variant_part)
{
+ const Node_Id gnat_decl = Declaration_Node (gnat_new_type);
variant_desc *v;
unsigned int i;
- gnu_variant_list = build_variant_list (TREE_TYPE (gnu_variant_part),
- gnu_subst_list, vNULL);
+ gnu_variant_list
+ = build_variant_list (TREE_TYPE (gnu_variant_part),
+ is_subtype
+ ? Empty
+ : Variant_Part
+ (Component_List (Type_Definition (gnat_decl))),
+ subst_list,
+ vNULL);
/* If all the qualifiers are unconditionally true, the innermost variant
is statically selected. */
@@ -9770,8 +9856,7 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type,
IDENTIFIER_POINTER (suffix));
TYPE_REVERSE_STORAGE_ORDER (new_variant)
= TYPE_REVERSE_STORAGE_ORDER (gnu_new_type);
- copy_and_substitute_in_size (new_variant, old_variant,
- gnu_subst_list);
+ copy_and_substitute_in_size (new_variant, old_variant, subst_list);
v->new_type = new_variant;
}
}
@@ -9882,7 +9967,7 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type,
gnu_field
= create_field_decl_from (gnu_old_field, gnu_field_type,
gnu_cont_type, gnu_size,
- gnu_pos_list, gnu_subst_list);
+ gnu_pos_list, subst_list);
gnu_pos = DECL_FIELD_OFFSET (gnu_field);
/* If the context is a variant, put it in the new variant directly. */
@@ -9969,20 +10054,20 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type,
tree new_variant_part
= create_variant_part_from (gnu_variant_part, gnu_variant_list,
gnu_new_type, gnu_pos_list,
- gnu_subst_list, debug_info_p);
+ subst_list, debug_info_p);
DECL_CHAIN (new_variant_part) = gnu_field_list;
gnu_field_list = new_variant_part;
}
gnu_variant_list.release ();
- gnu_subst_list.release ();
+ subst_list.release ();
/* If NEW_TYPE is a subtype, it inherits all the attributes from OLD_TYPE.
Otherwise sizes and alignment must be computed independently. */
finish_record_type (gnu_new_type, nreverse (gnu_field_list),
is_subtype ? 2 : 1, debug_info_p);
- /* Now go through the entities again looking for Itypes that we have not yet
+ /* Now go through the entities again looking for itypes that we have not yet
elaborated (e.g. Etypes of fields that have Original_Components). */
for (Entity_Id gnat_field = First_Entity (gnat_new_type);
Present (gnat_field);
@@ -9994,39 +10079,43 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type,
gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, false);
}
-/* Associate to GNU_TYPE, the translation of GNAT_ENTITY, which is
- the implementation type of a packed array type (Is_Packed_Array_Impl_Type),
- the original array type if it has been translated. This association is a
- parallel type for GNAT encodings or a debug type for standard DWARF. Note
- that for standard DWARF, we also want to get the original type name. */
+/* Associate to the implementation type of a packed array type specified by
+ GNU_TYPE, which is the translation of GNAT_ENTITY, the original array type
+ if it has been translated. This association is a parallel type for GNAT
+ encodings or a debug type for standard DWARF. Note that for standard DWARF,
+ we also want to get the original type name and therefore we return it. */
-static void
+static tree
associate_original_type_to_packed_array (tree gnu_type, Entity_Id gnat_entity)
{
- Entity_Id gnat_original_array_type
+ const Entity_Id gnat_original_array_type
= Underlying_Type (Original_Array_Type (gnat_entity));
tree gnu_original_array_type;
if (!present_gnu_tree (gnat_original_array_type))
- return;
+ return NULL_TREE;
gnu_original_array_type = gnat_to_gnu_type (gnat_original_array_type);
if (TYPE_IS_DUMMY_P (gnu_original_array_type))
- return;
+ return NULL_TREE;
+
+ gcc_assert (TYPE_IMPL_PACKED_ARRAY_P (gnu_type));
if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
{
- tree original_name = TYPE_NAME (gnu_original_array_type);
+ SET_TYPE_ORIGINAL_PACKED_ARRAY (gnu_type, gnu_original_array_type);
+ tree original_name = TYPE_NAME (gnu_original_array_type);
if (TREE_CODE (original_name) == TYPE_DECL)
original_name = DECL_NAME (original_name);
-
- SET_TYPE_ORIGINAL_PACKED_ARRAY (gnu_type, gnu_original_array_type);
- TYPE_NAME (gnu_type) = original_name;
+ return original_name;
}
else
- add_parallel_type (gnu_type, gnu_original_array_type);
+ {
+ add_parallel_type (gnu_type, gnu_original_array_type);
+ return NULL_TREE;
+ }
}
/* Given a type T, a FIELD_DECL F, and a replacement value R, return an
diff --git a/gcc/ada/gcc-interface/gadaint.h b/gcc/ada/gcc-interface/gadaint.h
index ce27a14..bf49794 100644
--- a/gcc/ada/gcc-interface/gadaint.h
+++ b/gcc/ada/gcc-interface/gadaint.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2010-2011, Free Software Foundation, Inc. *
+ * Copyright (C) 2010-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index edfcbd5..e43b3db 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -138,14 +138,12 @@ extern tree make_type_from_size (tree type, tree size_tree, bool for_biased);
if needed. We have already verified that SIZE and ALIGN are large enough.
GNAT_ENTITY is used to name the resulting record and to issue a warning.
IS_COMPONENT_TYPE is true if this is being done for the component type of
- an array. IS_USER_TYPE is true if the original type needs to be completed.
- DEFINITION is true if this type is being defined. SET_RM_SIZE is true if
- the RM size of the resulting type is to be set to SIZE too; in this case,
- the padded type is canonicalized before being returned. */
+ an array. DEFINITION is true if this type is being defined. SET_RM_SIZE
+ is true if the RM size of the resulting type is to be set to SIZE too; in
+ this case, the padded type is canonicalized before being returned. */
extern tree maybe_pad_type (tree type, tree size, unsigned int align,
Entity_Id gnat_entity, bool is_component_type,
- bool is_user_type, bool definition,
- bool set_rm_size);
+ bool definition, bool set_rm_size);
/* Return true if padded TYPE was built with an RM size. */
extern bool pad_type_has_rm_size (tree type);
@@ -1065,20 +1063,6 @@ extern void enumerate_modes (void (*f) (const char *, int, int, int, int, int,
#define gigi_checking_assert(EXPR) \
gcc_checking_assert ((EXPR) || type_annotate_only)
-/* If EXP's type is a VECTOR_TYPE, return EXP converted to the associated
- TYPE_REPRESENTATIVE_ARRAY. */
-
-static inline tree
-maybe_vector_array (tree exp)
-{
- tree etype = TREE_TYPE (exp);
-
- if (VECTOR_TYPE_P (etype))
- exp = convert (TYPE_REPRESENTATIVE_ARRAY (etype), exp);
-
- return exp;
-}
-
/* Return the smallest power of 2 larger than X. */
static inline unsigned HOST_WIDE_INT
@@ -1144,6 +1128,33 @@ gnat_signed_type_for (tree type_node)
return gnat_signed_or_unsigned_type_for (0, type_node);
}
+/* Like build_qualified_type, but TYPE_QUALS is added to the existing
+ qualifiers on TYPE. */
+
+static inline tree
+change_qualified_type (tree type, int type_quals)
+{
+ /* Qualifiers must be put on the associated array type. */
+ if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
+ return type;
+
+ return build_qualified_type (type, TYPE_QUALS (type) | type_quals);
+}
+
+/* If EXPR's type is a VECTOR_TYPE, return EXPR converted to the associated
+ TYPE_REPRESENTATIVE_ARRAY. */
+
+static inline tree
+maybe_vector_array (tree expr)
+{
+ tree type = TREE_TYPE (expr);
+
+ if (VECTOR_TYPE_P (type))
+ expr = convert (TYPE_REPRESENTATIVE_ARRAY (type), expr);
+
+ return expr;
+}
+
/* Adjust the character type TYPE if need be. */
static inline tree
@@ -1186,15 +1197,23 @@ maybe_debug_type (tree type)
return type;
}
-/* Like build_qualified_type, but TYPE_QUALS is added to the existing
- qualifiers on TYPE. */
+/* Remove the padding around EXPR if need be. */
static inline tree
-change_qualified_type (tree type, int type_quals)
+maybe_padded_object (tree expr)
{
- /* Qualifiers must be put on the associated array type. */
- if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
- return type;
+ tree type = TREE_TYPE (expr);
- return build_qualified_type (type, TYPE_QUALS (type) | type_quals);
+ if (TYPE_IS_PADDING_P (type))
+ expr = convert (TREE_TYPE (TYPE_FIELDS (type)), expr);
+
+ return expr;
+}
+
+/* Return the type of operand #0 of EXPR. */
+
+static inline tree
+operand_type (tree expr)
+{
+ return TREE_TYPE (TREE_OPERAND (expr, 0));
}
diff --git a/gcc/ada/gcc-interface/lang-specs.h b/gcc/ada/gcc-interface/lang-specs.h
index 374fc1e..f0ef3b92 100644
--- a/gcc/ada/gcc-interface/lang-specs.h
+++ b/gcc/ada/gcc-interface/lang-specs.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2018, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -23,6 +23,10 @@
* *
****************************************************************************/
+/* Pass -d* flags to the actual compiler, but mapping non-Ada
+ extensions to .ada in dump file names. */
+#define ADA_DUMPS_OPTIONS DUMPS_OPTIONS ("%{!.adb:%{!.ads:.ada}}")
+
/* This is the contribution to the `default_compilers' array in gcc.c for
GNAT. */
@@ -34,17 +38,15 @@
%{!S:%{!c:%e-c or -S required for Ada}}\
gnat1 %{I*} %{k8:-gnatk8} %{Wall:-gnatwa} %{w:-gnatws} %{!Q:-quiet}\
%{nostdinc*} %{nostdlib*}\
- -dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\
- %{fcompare-debug-second:%:compare-debug-auxbase-opt(%b) -gnatd_A} \
- %{!fcompare-debug-second:%{c|S:%{o*:-auxbase-strip %*}%{!o*:-auxbase %b}}%{!c:%{!S:-auxbase %b}}} \
- %{O*} %{W*} %{w} %{p} %{pg:-p} %{d*} \
+ %{fcompare-debug-second:-gnatd_A} \
+ %{O*} %{W*} %{w} %{p} %{pg:-p} " ADA_DUMPS_OPTIONS " \
%{coverage:-fprofile-arcs -ftest-coverage} "
#if defined(TARGET_VXWORKS_RTP)
"%{fRTS=rtp|fRTS=rtp-smp|fRTS=ravenscar-cert-rtp:-mrtp} "
#endif
"%{gnatea:-gnatez} %{g*&m*&f*} "
"%1 %{!S:%{o*:%w%*-gnatO}} \
- %i %{S:%W{o*}%{!o*:-o %b.s}} \
+ %i %{S:%W{o*}%{!o*:-o %w%b.s}} \
%{gnatc*|gnats*: -o %j} %{-param*} \
%{!gnatc*:%{!gnats*:%(invoke_as)}}", 0, 0, 0},
@@ -53,9 +55,7 @@
%{!c:%e-c required for gnat2why}\
gnat1why %{I*} %{k8:-gnatk8} %{!Q:-quiet}\
%{nostdinc*} %{nostdlib*}\
- -dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\
- %{o*:-auxbase-strip %*}%{!o*:-auxbase %b} \
- %{a} %{d*} \
+ %{a} " ADA_DUMPS_OPTIONS " \
%{gnatea:-gnatez} %{g*&m*&f*} \
%1 %{o*:%w%*-gnatO} \
%i \
@@ -66,9 +66,7 @@
%{!c:%e-c required for gnat2scil}\
gnat1scil %{I*} %{k8:-gnatk8} %{!Q:-quiet}\
%{nostdinc*} %{nostdlib*}\
- -dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\
- %{o*:-auxbase-strip %*}%{!o*:-auxbase %b} \
- %{a} %{d*} \
+ %{a} " ADA_DUMPS_OPTIONS " \
%{gnatea:-gnatez} %{g*&m*&f*} \
%1 %{o*:%w%*-gnatO} \
%i \
diff --git a/gcc/ada/gcc-interface/lang.opt b/gcc/ada/gcc-interface/lang.opt
index 6691136..379157c 100644
--- a/gcc/ada/gcc-interface/lang.opt
+++ b/gcc/ada/gcc-interface/lang.opt
@@ -104,8 +104,4 @@ fbuiltin-printf
Ada Undocumented
Ignored.
-fopenacc
-Ada LTO
-; Documented in C but it should be: Enable OpenACC support
-
; This comment is to ensure we retain the blank line above.
diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c
index d68b373..3999f9c 100644
--- a/gcc/ada/gcc-interface/misc.c
+++ b/gcc/ada/gcc-interface/misc.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -47,6 +47,7 @@
#include "atree.h"
#include "namet.h"
#include "nlists.h"
+#include "snames.h"
#include "uintp.h"
#include "fe.h"
#include "sinfo.h"
@@ -164,7 +165,6 @@ gnat_handle_option (size_t scode, const char *arg, HOST_WIDE_INT value,
/* These are handled by the front-end. */
break;
- case OPT_fopenacc:
case OPT_fshort_enums:
case OPT_fsigned_char:
case OPT_funsigned_char:
@@ -417,7 +417,8 @@ gnat_init_gcc_eh (void)
}
else
{
- flag_non_call_exceptions = 1;
+ if (!global_options_set.x_flag_non_call_exceptions)
+ flag_non_call_exceptions = 1;
flag_aggressive_loop_optimizations = 0;
warn_aggressive_loop_optimizations = 0;
}
@@ -466,9 +467,6 @@ gnat_print_decl (FILE *file, tree node, int indent)
if (DECL_LOOP_PARM_P (node))
print_node (file, "induction var", DECL_INDUCTION_VAR (node),
indent + 4);
- else
- print_node (file, "renamed object", DECL_RENAMED_OBJECT (node),
- indent + 4);
break;
default:
@@ -601,20 +599,10 @@ gnat_enum_underlying_base_type (const_tree)
static tree
gnat_get_debug_type (const_tree type)
{
- if (TYPE_CAN_HAVE_DEBUG_TYPE_P (type) && TYPE_DEBUG_TYPE (type))
- {
- type = TYPE_DEBUG_TYPE (type);
-
- /* ??? The get_debug_type language hook is processed after the array
- descriptor language hook, so if there is an array behind this type,
- the latter is supposed to handle it. Still, we can get here with
- a type we are not supposed to handle (e.g. when the DWARF back-end
- processes the type of a variable), so keep this guard. */
- if (type && TYPE_CAN_HAVE_DEBUG_TYPE_P (type))
- return const_cast<tree> (type);
- }
-
- return NULL_TREE;
+ if (TYPE_CAN_HAVE_DEBUG_TYPE_P (type))
+ return TYPE_DEBUG_TYPE (type);
+ else
+ return NULL_TREE;
}
/* Provide information in INFO for debugging output about the TYPE fixed-point
@@ -649,14 +637,14 @@ gnat_get_fixed_point_type_info (const_tree type,
if (TREE_CODE (scale_factor) == RDIV_EXPR)
{
- const tree num = TREE_OPERAND (scale_factor, 0);
- const tree den = TREE_OPERAND (scale_factor, 1);
+ tree num = TREE_OPERAND (scale_factor, 0);
+ tree den = TREE_OPERAND (scale_factor, 1);
/* See if we have a binary or decimal scale. */
if (TREE_CODE (den) == POWER_EXPR)
{
- const tree base = TREE_OPERAND (den, 0);
- const tree exponent = TREE_OPERAND (den, 1);
+ tree base = TREE_OPERAND (den, 0);
+ tree exponent = TREE_OPERAND (den, 1);
/* We expect the scale factor to be 1 / 2 ** N or 1 / 10 ** N. */
gcc_assert (num == integer_one_node
@@ -785,14 +773,9 @@ static bool
gnat_get_array_descr_info (const_tree const_type,
struct array_descr_info *info)
{
- bool convention_fortran_p;
- bool is_array = false;
- bool is_fat_ptr = false;
- bool is_packed_array = false;
tree type = const_cast<tree> (const_type);
- const_tree first_dimen = NULL_TREE;
- const_tree last_dimen = NULL_TREE;
- const_tree dimen;
+ tree first_dimen, dimen;
+ bool is_packed_array, is_array;
int i;
/* Temporaries created in the first pass and used in the second one for thin
@@ -802,9 +785,6 @@ gnat_get_array_descr_info (const_tree const_type,
tree thinptr_template_expr = NULL_TREE;
tree thinptr_bound_field = NULL_TREE;
- /* ??? See gnat_get_debug_type. */
- type = maybe_debug_type (type);
-
/* If we have an implementation type for a packed array, get the orignial
array type. */
if (TYPE_IMPL_PACKED_ARRAY_P (type) && TYPE_ORIGINAL_PACKED_ARRAY (type))
@@ -812,6 +792,8 @@ gnat_get_array_descr_info (const_tree const_type,
type = TYPE_ORIGINAL_PACKED_ARRAY (type);
is_packed_array = true;
}
+ else
+ is_packed_array = false;
/* First pass: gather all information about this array except everything
related to dimensions. */
@@ -823,54 +805,27 @@ gnat_get_array_descr_info (const_tree const_type,
{
is_array = true;
first_dimen = type;
- info->data_location = NULL_TREE;
- }
-
- else if (TYPE_IS_FAT_POINTER_P (type)
- && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
- {
- const tree ua_type = TYPE_UNCONSTRAINED_ARRAY (type);
-
- /* This will be our base object address. */
- const tree placeholder_expr = build0 (PLACEHOLDER_EXPR, type);
-
- /* We assume below that maybe_unconstrained_array returns an INDIRECT_REF
- node. */
- const tree ua_val
- = maybe_unconstrained_array (build_unary_op (INDIRECT_REF,
- ua_type,
- placeholder_expr));
-
- is_fat_ptr = true;
- first_dimen = TREE_TYPE (ua_val);
-
- /* Get the *address* of the array, not the array itself. */
- info->data_location = TREE_OPERAND (ua_val, 0);
}
- /* Unlike fat pointers (which appear for unconstrained arrays passed in
- argument), thin pointers are used only for array access types, so we want
- them to appear in the debug info as pointers to an array type. That's why
- we match only the RECORD_TYPE here instead of the POINTER_TYPE with the
- TYPE_IS_THIN_POINTER_P predicate. */
+ /* As well as array types embedded in a record type with their bounds. */
else if (TREE_CODE (type) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (type)
&& gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
{
/* This will be our base object address. Note that we assume that
- pointers to these will actually point to the array field (thin
+ pointers to this will actually point to the array field (thin
pointers are shifted). */
- const tree placeholder_expr = build0 (PLACEHOLDER_EXPR, type);
- const tree placeholder_addr
- = build_unary_op (ADDR_EXPR, NULL_TREE, placeholder_expr);
+ tree placeholder_expr = build0 (PLACEHOLDER_EXPR, type);
+ tree placeholder_addr
+ = build_unary_op (ADDR_EXPR, NULL_TREE, placeholder_expr);
- const tree bounds_field = TYPE_FIELDS (type);
- const tree bounds_type = TREE_TYPE (bounds_field);
- const tree array_field = DECL_CHAIN (bounds_field);
- const tree array_type = TREE_TYPE (array_field);
+ tree bounds_field = TYPE_FIELDS (type);
+ tree bounds_type = TREE_TYPE (bounds_field);
+ tree array_field = DECL_CHAIN (bounds_field);
+ tree array_type = TREE_TYPE (array_field);
- /* Shift the thin pointer address to get the address of the template. */
- const tree shift_amount
+ /* Shift back the address to get the address of the template. */
+ tree shift_amount
= fold_build1 (NEGATE_EXPR, sizetype, byte_position (array_field));
tree template_addr
= build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (placeholder_addr),
@@ -878,46 +833,44 @@ gnat_get_array_descr_info (const_tree const_type,
template_addr
= fold_convert (TYPE_POINTER_TO (bounds_type), template_addr);
- first_dimen = array_type;
-
- /* The thin pointer is already the pointer to the array data, so there's
- no need for a specific "data location" expression. */
- info->data_location = NULL_TREE;
-
- thinptr_template_expr = build_unary_op (INDIRECT_REF,
- bounds_type,
- template_addr);
+ thinptr_template_expr
+ = build_unary_op (INDIRECT_REF, NULL_TREE, template_addr);
thinptr_bound_field = TYPE_FIELDS (bounds_type);
+
+ is_array = false;
+ first_dimen = array_type;
}
+
else
return false;
/* Second pass: compute the remaining information: dimensions and
corresponding bounds. */
- if (TYPE_PACKED (first_dimen))
- is_packed_array = true;
/* If this array has fortran convention, it's arranged in column-major
order, so our view here has reversed dimensions. */
- convention_fortran_p = TYPE_CONVENTION_FORTRAN_P (first_dimen);
+ const bool convention_fortran_p = TYPE_CONVENTION_FORTRAN_P (first_dimen);
+
+ if (TYPE_PACKED (first_dimen))
+ is_packed_array = true;
+
/* ??? For row major ordering, we probably want to emit nothing and
instead specify it as the default in Dw_TAG_compile_unit. */
info->ordering = (convention_fortran_p
? array_descr_ordering_column_major
: array_descr_ordering_row_major);
+ info->rank = NULL_TREE;
- /* Count how many dimensions this array has. */
- for (i = 0, dimen = first_dimen; ; ++i, dimen = TREE_TYPE (dimen))
+ /* Count the number of dimensions and determine the element type. */
+ i = 1;
+ dimen = TREE_TYPE (first_dimen);
+ while (TREE_CODE (dimen) == ARRAY_TYPE && TYPE_MULTI_ARRAY_P (dimen))
{
- if (i > 0
- && (TREE_CODE (dimen) != ARRAY_TYPE
- || !TYPE_MULTI_ARRAY_P (dimen)))
- break;
- last_dimen = dimen;
+ i++;
+ dimen = TREE_TYPE (dimen);
}
-
info->ndimensions = i;
- info->rank = NULL_TREE;
+ info->element_type = dimen;
/* Too many dimensions? Give up generating proper description: yield instead
nested arrays. Note that in this case, this hook is invoked once on each
@@ -927,12 +880,10 @@ gnat_get_array_descr_info (const_tree const_type,
|| TYPE_MULTI_ARRAY_P (first_dimen))
{
info->ndimensions = 1;
- last_dimen = first_dimen;
+ info->element_type = TREE_TYPE (first_dimen);
}
- info->element_type = TREE_TYPE (last_dimen);
-
- /* Now iterate over all dimensions in source-order and fill the info
+ /* Now iterate over all dimensions in source order and fill the info
structure. */
for (i = (convention_fortran_p ? info->ndimensions - 1 : 0),
dimen = first_dimen;
@@ -943,7 +894,7 @@ gnat_get_array_descr_info (const_tree const_type,
/* We are interested in the stored bounds for the debug info. */
tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (dimen));
- if (is_array || is_fat_ptr)
+ if (is_array)
{
/* GDB does not handle very well the self-referencial bound
expressions we are able to generate here for XUA types (they are
@@ -994,6 +945,7 @@ gnat_get_array_descr_info (const_tree const_type,
/* These are Fortran-specific fields. They make no sense here. */
info->allocated = NULL_TREE;
info->associated = NULL_TREE;
+ info->data_location = NULL_TREE;
if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
{
@@ -1048,6 +1000,9 @@ get_array_bit_stride (tree comp_type)
if (INTEGRAL_TYPE_P (comp_type))
return TYPE_RM_SIZE (comp_type);
+ /* The gnat_get_array_descr_info debug hook expects a debug tyoe. */
+ comp_type = maybe_debug_type (comp_type);
+
/* Otherwise, see if this is an array we can analyze; if it's not, punt. */
memset (&info, 0, sizeof (info));
if (!gnat_get_array_descr_info (comp_type, &info) || !info.stride)
@@ -1185,7 +1140,7 @@ must_pass_by_ref (tree gnu_type)
void
enumerate_modes (void (*f) (const char *, int, int, int, int, int, int, int))
{
- const tree c_types[]
+ tree const c_types[]
= { float_type_node, double_type_node, long_double_type_node };
const char *const c_names[]
= { "float", "double", "long double" };
diff --git a/gcc/ada/gcc-interface/targtyps.c b/gcc/ada/gcc-interface/targtyps.c
index 1a4d33b..9b2d241 100644
--- a/gcc/ada/gcc-interface/targtyps.c
+++ b/gcc/ada/gcc-interface/targtyps.c
@@ -6,7 +6,7 @@
* *
* Body *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index 5f87bc3..f74e0e7 100644
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -242,8 +242,6 @@ static bool addressable_p (tree, tree);
static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
static tree pos_to_constructor (Node_Id, tree);
static void validate_unchecked_conversion (Node_Id);
-static Node_Id adjust_for_implicit_deref (Node_Id);
-static tree maybe_implicit_deref (tree);
static void set_expr_location_from_node (tree, Node_Id, bool = false);
static void set_gnu_expr_location_from_node (tree, Node_Id);
static bool set_end_locus_from_node (tree, Node_Id);
@@ -775,8 +773,6 @@ lvalue_required_for_attribute_p (Node_Id gnat_node)
{
switch (Get_Attribute_Id (Attribute_Name (gnat_node)))
{
- case Attr_Pos:
- case Attr_Val:
case Attr_Pred:
case Attr_Succ:
case Attr_First:
@@ -871,8 +867,9 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
/* ... fall through ... */
+ case N_Selected_Component:
case N_Slice:
- /* Only the array expression can require an lvalue. */
+ /* Only the prefix expression can require an lvalue. */
if (Prefix (gnat_parent) != gnat_node)
return 0;
@@ -880,11 +877,6 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
get_unpadded_type (Etype (gnat_parent)),
constant, address_of_constant);
- case N_Selected_Component:
- return lvalue_required_p (gnat_parent,
- get_unpadded_type (Etype (gnat_parent)),
- constant, address_of_constant);
-
case N_Object_Renaming_Declaration:
/* We need to preserve addresses through a renaming. */
return 1;
@@ -925,12 +917,6 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
get_unpadded_type (Etype (gnat_parent)),
constant, address_of_constant);
- case N_Allocator:
- /* We should only reach here through the N_Qualified_Expression case.
- Force an lvalue for composite types since a block-copy to the newly
- allocated area of memory is made. */
- return Is_Composite_Type (Underlying_Type (Etype (gnat_node)));
-
case N_Explicit_Dereference:
/* We look through dereferences for address of constant because we need
to handle the special cases listed above. */
@@ -948,6 +934,74 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
gcc_unreachable ();
}
+/* Return true if an lvalue should be used for GNAT_NODE. GNU_TYPE is the type
+ that will be used for GNAT_NODE in the translated GNU tree and is assumed to
+ be an aggregate type.
+
+ The function climbs up the GNAT tree starting from the node and returns true
+ upon encountering a node that makes it doable to decide. lvalue_required_p
+ should have been previously invoked on the arguments and returned false. */
+
+static bool
+lvalue_for_aggregate_p (Node_Id gnat_node, tree gnu_type)
+{
+ Node_Id gnat_parent = Parent (gnat_node);
+
+ switch (Nkind (gnat_parent))
+ {
+ case N_Parameter_Association:
+ case N_Function_Call:
+ case N_Procedure_Call_Statement:
+ /* Even if the parameter is by copy, prefer an lvalue. */
+ return true;
+
+ case N_Indexed_Component:
+ case N_Selected_Component:
+ /* If an elementary component is used, take it from the constant. */
+ if (!Is_Composite_Type (Underlying_Type (Etype (gnat_parent))))
+ return false;
+
+ /* ... fall through ... */
+
+ case N_Slice:
+ return lvalue_for_aggregate_p (gnat_parent,
+ get_unpadded_type (Etype (gnat_parent)));
+
+ case N_Object_Declaration:
+ /* For an aggregate object declaration, return the constant at top level
+ in order to avoid generating elaboration code. */
+ if (global_bindings_p ())
+ return false;
+
+ /* ... fall through ... */
+
+ case N_Assignment_Statement:
+ /* For an aggregate assignment, decide based on the size. */
+ {
+ const HOST_WIDE_INT size = int_size_in_bytes (gnu_type);
+ return size < 0 || size >= param_large_stack_frame / 4;
+ }
+
+ case N_Unchecked_Type_Conversion:
+ case N_Type_Conversion:
+ case N_Qualified_Expression:
+ return lvalue_for_aggregate_p (gnat_parent,
+ get_unpadded_type (Etype (gnat_parent)));
+
+ case N_Allocator:
+ /* We should only reach here through the N_Qualified_Expression case.
+ Force an lvalue for aggregate types since a block-copy to the newly
+ allocated area of memory is made. */
+ return true;
+
+ default:
+ return false;
+ }
+
+ gcc_unreachable ();
+}
+
+
/* Return true if T is a constant DECL node that can be safely replaced
by its initializer. */
@@ -1195,25 +1249,16 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
true)))
gnu_result = DECL_INITIAL (gnu_result);
- /* If it's a renaming pointer, get to the renamed object. */
- if (TREE_CODE (gnu_result) == VAR_DECL
- && !DECL_LOOP_PARM_P (gnu_result)
- && DECL_RENAMED_OBJECT (gnu_result))
- gnu_result = DECL_RENAMED_OBJECT (gnu_result);
-
- /* Otherwise, do the final dereference. */
- else
- {
- gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
+ /* Do the final dereference. */
+ gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
- if ((TREE_CODE (gnu_result) == INDIRECT_REF
- || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
- && No (Address_Clause (gnat_entity)))
- TREE_THIS_NOTRAP (gnu_result) = 1;
+ if ((TREE_CODE (gnu_result) == INDIRECT_REF
+ || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
+ && No (Address_Clause (gnat_entity)))
+ TREE_THIS_NOTRAP (gnu_result) = 1;
- if (read_only)
- TREE_READONLY (gnu_result) = 1;
- }
+ if (read_only)
+ TREE_READONLY (gnu_result) = 1;
}
/* If we have a constant declaration and its initializer, try to return the
@@ -1232,7 +1277,9 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
if ((!constant_only || address_of_constant) && require_lvalue < 0)
require_lvalue
= lvalue_required_p (gnat_node, gnu_result_type, true,
- address_of_constant);
+ address_of_constant)
+ || (AGGREGATE_TYPE_P (gnu_result_type)
+ && lvalue_for_aggregate_p (gnat_node, gnu_result_type));
/* Finally retrieve the initializer if this is deemed valid. */
if ((constant_only && !address_of_constant) || !require_lvalue)
@@ -1276,234 +1323,6 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
return gnu_result;
}
-/* If GNAT_EXPR is an N_Identifier, N_Integer_Literal or N_Operator_Symbol,
- call FN on it. If GNAT_EXPR is an aggregate, call FN on each of its
- elements. In both cases, pass GNU_EXPR and DATA as additional arguments.
-
- This function is used everywhere OpenAcc pragmas are processed if these
- pragmas can accept aggregates. */
-
-static tree
-Iterate_Acc_Clause_Arg (Node_Id gnat_expr, tree gnu_expr,
- tree (*fn)(Node_Id, tree, void*),
- void* data)
-{
- switch (Nkind (gnat_expr))
- {
- case N_Aggregate:
- if (Present (Expressions (gnat_expr)))
- {
- for (Node_Id gnat_list_expr = First (Expressions (gnat_expr));
- Present (gnat_list_expr);
- gnat_list_expr = Next (gnat_list_expr))
- gnu_expr = fn (gnat_list_expr, gnu_expr, data);
- }
- else if (Present (Component_Associations (gnat_expr)))
- {
- for (Node_Id gnat_list_expr = First (Component_Associations
- (gnat_expr));
- Present (gnat_list_expr);
- gnat_list_expr = Next (gnat_list_expr))
- gnu_expr = fn (Expression (gnat_list_expr), gnu_expr, data);
- }
- else
- gcc_unreachable ();
- break;
-
- case N_Identifier:
- case N_Integer_Literal:
- case N_Operator_Symbol:
- gnu_expr = fn (gnat_expr, gnu_expr, data);
- break;
-
- default:
- gcc_unreachable ();
- }
-
- return gnu_expr;
-}
-
-/* Same as gnat_to_gnu for a GNAT_NODE referenced within an OpenAcc directive,
- undoing transformations that are inappropriate for such context. */
-
-tree
-Acc_gnat_to_gnu (Node_Id gnat_node)
-{
- tree gnu_result = gnat_to_gnu (gnat_node);
-
- /* If gnat_node is an identifier for a boolean, gnat_to_gnu might have
- turned it into `identifier != 0`. Since arguments to OpenAcc pragmas
- need to be writable, we need to return the identifier residing in such
- expressions rather than the expression itself. */
- if (Nkind (gnat_node) == N_Identifier
- && TREE_CODE (gnu_result) == NE_EXPR
- && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_result, 0))) == BOOLEAN_TYPE
- && integer_zerop (TREE_OPERAND (gnu_result, 1)))
- gnu_result = TREE_OPERAND (gnu_result, 0);
-
- return gnu_result;
-}
-
-/* Turn GNAT_EXPR into a tree node representing an OMP data clause and chain
- it to GNU_CLAUSES, a list of pre-existing OMP clauses. GNAT_EXPR should be
- a N_Identifier, this is enforced by the frontend.
-
- This function is called every time translation of an argument for an OpenAcc
- clause (e.g. Acc_Parallel(Copy => My_Identifier)) is needed. */
-
-static tree
-Acc_Data_to_gnu (Node_Id gnat_expr, tree gnu_clauses, void* data)
-{
- const enum gomp_map_kind kind = *((enum gomp_map_kind*) data);
- tree gnu_clause
- = build_omp_clause (EXPR_LOCATION(gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_MAP);
-
- gcc_assert (Nkind (gnat_expr) == N_Identifier);
- OMP_CLAUSE_DECL (gnu_clause)
- = gnat_to_gnu_entity (Entity (gnat_expr), NULL_TREE, false);
-
- TREE_ADDRESSABLE (OMP_CLAUSE_DECL (gnu_clause)) = 1;
- OMP_CLAUSE_SET_MAP_KIND (gnu_clause, kind);
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
-
- return gnu_clause;
-}
-
-/* Turn GNAT_EXPR into a tree node representing an OMP clause and chain it to
- GNU_CLAUSES, a list of existing OMP clauses.
-
- This function is used for parsing arguments of non-data clauses (e.g.
- Acc_Parallel(Wait => gnatexpr)). */
-
-static tree
-Acc_Var_to_gnu (Node_Id gnat_expr, tree gnu_clauses, void* data)
-{
- const enum omp_clause_code kind = *((enum omp_clause_code*) data);
- tree gnu_clause
- = build_omp_clause (EXPR_LOCATION (gnu_loop_stack->last ()->stmt), kind);
-
- OMP_CLAUSE_DECL (gnu_clause) = Acc_gnat_to_gnu (gnat_expr);
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
-
- return gnu_clause;
-}
-
-/* Turn GNAT_EXPR into a tree OMP clause representing a reduction clause.
- GNAT_EXPR has to be a N_Identifier, this is enforced by the frontend.
-
- For example, GNAT_EXPR could be My_Identifier in the following pragma:
- Acc_Parallel(Reduction => ("+" => My_Identifier)). */
-
-static tree
-Acc_Reduc_Var_to_gnu (Node_Id gnat_expr, tree gnu_clauses, void* data)
-{
- const tree_code code = *((tree_code*) data);
- tree gnu_clause
- = build_omp_clause (EXPR_LOCATION (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_REDUCTION);
-
- OMP_CLAUSE_DECL (gnu_clause) = Acc_gnat_to_gnu (gnat_expr);
- OMP_CLAUSE_REDUCTION_CODE (gnu_clause) = code;
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
-
- return gnu_clause;
-}
-
-/* Turn GNAT_EXPR into a list of OMP reduction clauses. GNAT_EXPR has to
- follow the structure of a reduction clause, e.g. ("+" => Identifier). */
-
-static tree
-Acc_Reduc_to_gnu (Node_Id gnat_expr)
-{
- tree gnu_clauses = NULL_TREE;
-
- for (Node_Id gnat_op = First (Component_Associations (gnat_expr));
- Present (gnat_op);
- gnat_op = Next (gnat_op))
- {
- tree_code code = ERROR_MARK;
- String_Id str = Strval (First (Choices (gnat_op)));
- switch (Get_String_Char (str, 1))
- {
- case '+':
- code = PLUS_EXPR;
- break;
- case '*':
- code = MULT_EXPR;
- break;
- case 'm':
- if (Get_String_Char (str, 2) == 'i'
- && Get_String_Char (str, 3) == 'n')
- code = MIN_EXPR;
- else if (Get_String_Char (str, 2) == 'a'
- && Get_String_Char (str, 3) == 'x')
- code = MAX_EXPR;
- break;
- case 'a':
- if (Get_String_Char (str, 2) == 'n'
- && Get_String_Char (str, 3) == 'd')
- code = TRUTH_ANDIF_EXPR;
- break;
- case 'o':
- if (Get_String_Char (str, 2) == 'r')
- code = TRUTH_ORIF_EXPR;
- break;
- default:
- gcc_unreachable ();
- }
-
- /* Unsupported reduction operation. This should have been
- caught in sem_prag.adb. */
- gcc_assert (code != ERROR_MARK);
-
- gnu_clauses = Iterate_Acc_Clause_Arg (Expression (gnat_op),
- gnu_clauses,
- Acc_Reduc_Var_to_gnu,
- &code);
- }
-
- return gnu_clauses;
-}
-
-/* Turn GNAT_EXPR, either '*' or an integer literal, into a tree_cons. This is
- only used by Acc_Size_List_to_gnu. */
-
-static tree
-Acc_Size_Expr_to_gnu (Node_Id gnat_expr, tree gnu_clauses, void *)
-{
- tree gnu_expr;
-
- if (Nkind (gnat_expr) == N_Operator_Symbol
- && Get_String_Char (Strval (gnat_expr), 1) == '*')
- gnu_expr = integer_zero_node;
- else
- gnu_expr = Acc_gnat_to_gnu (gnat_expr);
-
- return tree_cons (NULL_TREE, gnu_expr, gnu_clauses);
-}
-
-/* Turn GNAT_EXPR, an aggregate of either '*' or integer literals, into an OMP
- clause node.
-
- This function is used for the Tile clause of the Loop directive. This is
- what GNAT_EXPR might look like: (1, 1, '*'). */
-
-static tree
-Acc_Size_List_to_gnu (Node_Id gnat_expr)
-{
- tree gnu_clause
- = build_omp_clause (EXPR_LOCATION (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_TILE);
- tree gnu_list = Iterate_Acc_Clause_Arg (gnat_expr, NULL_TREE,
- Acc_Size_Expr_to_gnu,
- NULL);
-
- OMP_CLAUSE_TILE_LIST (gnu_clause) = nreverse (gnu_list);
-
- return gnu_clause;
-}
-
/* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
any statements we generate. */
@@ -1575,279 +1394,6 @@ Pragma_to_gnu (Node_Id gnat_node)
}
break;
- case Pragma_Acc_Loop:
- {
- if (!flag_openacc)
- break;
-
- tree gnu_clauses = gnu_loop_stack->last ()->omp_loop_clauses;
-
- if (!Present (Pragma_Argument_Associations (gnat_node)))
- break;
-
- for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
- Present (gnat_temp);
- gnat_temp = Next (gnat_temp))
- {
- Node_Id gnat_expr = Expression (gnat_temp);
- tree gnu_clause = NULL_TREE;
- enum omp_clause_code kind;
-
- if (Chars (gnat_temp) == No_Name)
- {
- /* The clause is an identifier without a parameter. */
- switch (Chars (gnat_expr))
- {
- case Name_Auto:
- kind = OMP_CLAUSE_AUTO;
- break;
- case Name_Gang:
- kind = OMP_CLAUSE_GANG;
- break;
- case Name_Independent:
- kind = OMP_CLAUSE_INDEPENDENT;
- break;
- case Name_Seq:
- kind = OMP_CLAUSE_SEQ;
- break;
- case Name_Vector:
- kind = OMP_CLAUSE_VECTOR;
- break;
- case Name_Worker:
- kind = OMP_CLAUSE_WORKER;
- break;
- default:
- gcc_unreachable ();
- }
- gnu_clause = build_omp_clause (EXPR_LOCATION
- (gnu_loop_stack->last ()->stmt),
- kind);
- }
- else
- {
- /* The clause is an identifier parameter(s). */
- switch (Chars (gnat_temp))
- {
- case Name_Collapse:
- gnu_clause = build_omp_clause
- (EXPR_LOCATION (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_COLLAPSE);
- OMP_CLAUSE_COLLAPSE_EXPR (gnu_clause) =
- Acc_gnat_to_gnu (gnat_expr);
- break;
- case Name_Device_Type:
- /* Unimplemented by GCC yet. */
- gcc_unreachable ();
- break;
- case Name_Independent:
- gnu_clause = build_omp_clause
- (EXPR_LOCATION (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_INDEPENDENT);
- break;
- case Name_Acc_Private:
- kind = OMP_CLAUSE_PRIVATE;
- gnu_clause = Iterate_Acc_Clause_Arg (gnat_expr, 0,
- Acc_Var_to_gnu,
- &kind);
- break;
- case Name_Reduction:
- gnu_clause = Acc_Reduc_to_gnu (gnat_expr);
- break;
- case Name_Tile:
- gnu_clause = Acc_Size_List_to_gnu (gnat_expr);
- break;
- case Name_Gang:
- case Name_Vector:
- case Name_Worker:
- /* These are for the Loop+Kernel combination, which is
- unimplemented by the frontend for now. */
- default:
- gcc_unreachable ();
- }
- }
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
- gnu_clauses = gnu_clause;
- }
- gnu_loop_stack->last ()->omp_loop_clauses = gnu_clauses;
- }
- break;
-
- /* Grouping the transformation of these pragmas together makes sense
- because they are mutually exclusive, share most of their clauses and
- the verification that each clause can legally appear for the pragma has
- been done in the frontend. */
- case Pragma_Acc_Data:
- case Pragma_Acc_Kernels:
- case Pragma_Acc_Parallel:
- {
- if (!flag_openacc)
- break;
-
- tree gnu_clauses = gnu_loop_stack->last ()->omp_construct_clauses;
- if (id == Pragma_Acc_Data)
- gnu_loop_stack->last ()->omp_code = OACC_DATA;
- else if (id == Pragma_Acc_Kernels)
- gnu_loop_stack->last ()->omp_code = OACC_KERNELS;
- else if (id == Pragma_Acc_Parallel)
- gnu_loop_stack->last ()->omp_code = OACC_PARALLEL;
- else
- gcc_unreachable ();
-
- if (!Present (Pragma_Argument_Associations (gnat_node)))
- break;
-
- for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
- Present (gnat_temp);
- gnat_temp = Next (gnat_temp))
- {
- Node_Id gnat_expr = Expression (gnat_temp);
- tree gnu_clause;
- enum omp_clause_code clause_code;
- enum gomp_map_kind map_kind;
-
- switch (Chars (gnat_temp))
- {
- case Name_Async:
- gnu_clause = build_omp_clause
- (EXPR_LOCATION (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_ASYNC);
- OMP_CLAUSE_ASYNC_EXPR (gnu_clause) =
- Acc_gnat_to_gnu (gnat_expr);
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
- gnu_clauses = gnu_clause;
- break;
-
- case Name_Num_Gangs:
- gnu_clause = build_omp_clause
- (EXPR_LOCATION (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_NUM_GANGS);
- OMP_CLAUSE_NUM_GANGS_EXPR (gnu_clause) =
- Acc_gnat_to_gnu (gnat_expr);
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
- gnu_clauses = gnu_clause;
- break;
-
- case Name_Num_Workers:
- gnu_clause = build_omp_clause
- (EXPR_LOCATION (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_NUM_WORKERS);
- OMP_CLAUSE_NUM_WORKERS_EXPR (gnu_clause) =
- Acc_gnat_to_gnu (gnat_expr);
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
- gnu_clauses = gnu_clause;
- break;
-
- case Name_Vector_Length:
- gnu_clause = build_omp_clause
- (EXPR_LOCATION (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_VECTOR_LENGTH);
- OMP_CLAUSE_VECTOR_LENGTH_EXPR (gnu_clause) =
- Acc_gnat_to_gnu (gnat_expr);
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
- gnu_clauses = gnu_clause;
- break;
-
- case Name_Wait:
- clause_code = OMP_CLAUSE_WAIT;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Var_to_gnu,
- &clause_code);
- break;
-
- case Name_Acc_If:
- gnu_clause = build_omp_clause (EXPR_LOCATION
- (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_IF);
- OMP_CLAUSE_IF_MODIFIER (gnu_clause) = ERROR_MARK;
- OMP_CLAUSE_IF_EXPR (gnu_clause) = Acc_gnat_to_gnu (gnat_expr);
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
- gnu_clauses = gnu_clause;
- break;
-
- case Name_Copy:
- map_kind = GOMP_MAP_FORCE_TOFROM;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Data_to_gnu,
- &map_kind);
- break;
-
- case Name_Copy_In:
- map_kind = GOMP_MAP_FORCE_TO;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Data_to_gnu,
- &map_kind);
- break;
-
- case Name_Copy_Out:
- map_kind = GOMP_MAP_FORCE_FROM;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Data_to_gnu,
- &map_kind);
- break;
-
- case Name_Present:
- map_kind = GOMP_MAP_FORCE_PRESENT;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Data_to_gnu,
- &map_kind);
- break;
-
- case Name_Create:
- map_kind = GOMP_MAP_FORCE_ALLOC;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Data_to_gnu,
- &map_kind);
- break;
-
- case Name_Device_Ptr:
- map_kind = GOMP_MAP_FORCE_DEVICEPTR;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Data_to_gnu,
- &map_kind);
- break;
-
- case Name_Acc_Private:
- clause_code = OMP_CLAUSE_PRIVATE;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Var_to_gnu,
- &clause_code);
- break;
-
- case Name_First_Private:
- clause_code = OMP_CLAUSE_FIRSTPRIVATE;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Var_to_gnu,
- &clause_code);
- break;
-
- case Name_Default:
- gnu_clause = build_omp_clause (EXPR_LOCATION
- (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_DEFAULT);
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
- /* The standard also accepts "present" but this isn't
- implemented in GCC yet. */
- OMP_CLAUSE_DEFAULT_KIND (gnu_clause) = OMP_CLAUSE_DEFAULT_NONE;
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
- gnu_clauses = gnu_clause;
- break;
-
- case Name_Reduction:
- gnu_clauses = Acc_Reduc_to_gnu(gnat_expr);
- break;
-
- case Name_Detach:
- case Name_Attach:
- case Name_Device_Type:
- /* Unimplemented by GCC. */
- default:
- gcc_unreachable ();
- }
- }
- gnu_loop_stack->last ()->omp_construct_clauses = gnu_clauses;
- }
- break;
-
case Pragma_Loop_Optimize:
for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
Present (gnat_temp);
@@ -2144,17 +1690,6 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
switch (attribute)
{
- case Attr_Pos:
- case Attr_Val:
- /* These are just conversions since representation clauses for
- enumeration types are handled in the front-end. */
- gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
- if (attribute == Attr_Pos)
- gnu_expr = maybe_character_value (gnu_expr);
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_result = convert (gnu_result_type, gnu_expr);
- break;
-
case Attr_Pred:
case Attr_Succ:
/* These just add or subtract the constant 1 since representation
@@ -2242,6 +1777,9 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
case Attr_Access:
case Attr_Unchecked_Access:
case Attr_Code_Address:
+ /* Taking the address of a type does not make sense. */
+ gcc_assert (TREE_CODE (gnu_prefix) != TYPE_DECL);
+
gnu_result_type = get_unpadded_type (Etype (gnat_node));
gnu_result
= build_unary_op (((attribute == Attr_Address
@@ -2503,7 +2041,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
case Attr_Range_Length:
prefix_unused = true;
- if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
+ if (INTEGRAL_TYPE_P (gnu_type) || SCALAR_FLOAT_TYPE_P (gnu_type))
{
gnu_result_type = get_unpadded_type (Etype (gnat_node));
@@ -2527,8 +2065,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
Entity_Id gnat_param = Empty;
bool unconstrained_ptr_deref = false;
- /* Make sure any implicit dereference gets done. */
- gnu_prefix = maybe_implicit_deref (gnu_prefix);
+ gnu_prefix = maybe_padded_object (gnu_prefix);
gnu_prefix = maybe_unconstrained_array (gnu_prefix);
/* We treat unconstrained array In parameters specially. We also note
@@ -2893,11 +2430,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
break;
case Attr_Component_Size:
- if (TREE_CODE (gnu_prefix) == COMPONENT_REF
- && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
- gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
-
- gnu_prefix = maybe_implicit_deref (gnu_prefix);
+ gnu_prefix = maybe_padded_object (gnu_prefix);
gnu_type = TREE_TYPE (gnu_prefix);
if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
@@ -2934,7 +2467,6 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
= build_unary_op (INDIRECT_REF, NULL_TREE,
convert (build_pointer_type (gnu_result_type),
integer_zero_node));
- TREE_PRIVATE (gnu_result) = 1;
break;
case Attr_Mechanism_Code:
@@ -3404,148 +2936,6 @@ independent_iterations_p (tree stmt_list)
return true;
}
-/* Helper for Loop_Statement_to_gnu to translate the body of a loop,
- designated by GNAT_LOOP, to which an Acc_Loop pragma applies. The pragma
- arguments might instruct us to collapse a nest of loops, where computation
- statements are expected only within the innermost loop, as in:
-
- for I in 1 .. 5 loop
- pragma Acc_Parallel;
- pragma Acc_Loop(Collapse => 3);
- for J in 1 .. 8 loop
- for K in 1 .. 4 loop
- X (I, J, K) := Y (I, J, K) + 2;
- end loop;
- end loop;
- end loop;
-
- We expect the top of gnu_loop_stack to hold a pointer to the loop info
- setup for the translation of GNAT_LOOP, which holds a pointer to the
- initial gnu loop stmt node. We return the new gnu loop statement to
- use. */
-
-static tree
-Acc_Loop_to_gnu (Node_Id gnat_loop)
-{
- tree acc_loop = make_node (OACC_LOOP);
- tree acc_bind_expr = NULL_TREE;
- Node_Id cur_loop = gnat_loop;
- int collapse_count = 1;
- tree initv;
- tree condv;
- tree incrv;
-
- /* Parse the pragmas, adding clauses to the current gnu_loop_stack through
- side effects. */
- for (Node_Id tmp = First (Statements (gnat_loop));
- Present (tmp) && Nkind (tmp) == N_Pragma;
- tmp = Next (tmp))
- Pragma_to_gnu(tmp);
-
- /* Find the number of loops that should be collapsed. */
- for (tree tmp = gnu_loop_stack->last ()->omp_loop_clauses; tmp ;
- tmp = OMP_CLAUSE_CHAIN (tmp))
- if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_COLLAPSE)
- collapse_count = tree_to_shwi (OMP_CLAUSE_COLLAPSE_EXPR (tmp));
- else if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_TILE)
- collapse_count = list_length (OMP_CLAUSE_TILE_LIST (tmp));
-
- initv = make_tree_vec (collapse_count);
- condv = make_tree_vec (collapse_count);
- incrv = make_tree_vec (collapse_count);
-
- start_stmt_group ();
- gnat_pushlevel ();
-
- /* For each nested loop that should be collapsed ... */
- for (int count = 0; count < collapse_count; ++count)
- {
- Node_Id lps =
- Loop_Parameter_Specification (Iteration_Scheme (cur_loop));
- tree low =
- Acc_gnat_to_gnu (Low_Bound (Discrete_Subtype_Definition (lps)));
- tree high =
- Acc_gnat_to_gnu (High_Bound (Discrete_Subtype_Definition (lps)));
- tree variable =
- gnat_to_gnu_entity (Defining_Identifier (lps), NULL_TREE, true);
-
- /* Build the initial value of the variable of the invariant. */
- TREE_VEC_ELT (initv, count) = build2 (MODIFY_EXPR,
- TREE_TYPE (variable),
- variable,
- low);
- add_stmt (TREE_VEC_ELT (initv, count));
-
- /* Build the invariant of the loop. */
- TREE_VEC_ELT (condv, count) = build2 (LE_EXPR,
- boolean_type_node,
- variable,
- high);
-
- /* Build the incrementation expression of the loop. */
- TREE_VEC_ELT (incrv, count) =
- build2 (MODIFY_EXPR,
- TREE_TYPE (variable),
- variable,
- build2 (PLUS_EXPR,
- TREE_TYPE (variable),
- variable,
- build_int_cst (TREE_TYPE (variable), 1)));
-
- /* Don't process the innermost loop because its statements belong to
- another statement group. */
- if (count < collapse_count - 1)
- /* Process the current loop's body. */
- for (Node_Id stmt = First (Statements (cur_loop));
- Present (stmt); stmt = Next (stmt))
- {
- /* If we are processsing the outermost loop, it is ok for it to
- contain pragmas. */
- if (Nkind (stmt) == N_Pragma && count == 0)
- ;
- /* The frontend might have inserted a N_Object_Declaration in the
- loop's body to declare the iteration variable of the next loop.
- It will need to be hoisted before the collapsed loops. */
- else if (Nkind (stmt) == N_Object_Declaration)
- Acc_gnat_to_gnu (stmt);
- else if (Nkind (stmt) == N_Loop_Statement)
- cur_loop = stmt;
- /* Every other kind of statement is prohibited in collapsed
- loops. */
- else if (count < collapse_count - 1)
- gcc_unreachable();
- }
- }
- gnat_poplevel ();
- acc_bind_expr = end_stmt_group ();
-
- /* Parse the innermost loop. */
- start_stmt_group();
- for (Node_Id stmt = First (Statements (cur_loop));
- Present (stmt);
- stmt = Next (stmt))
- {
- /* When the innermost loop is the only loop, do not parse the pragmas
- again. */
- if (Nkind (stmt) == N_Pragma && collapse_count == 1)
- continue;
- add_stmt (Acc_gnat_to_gnu (stmt));
- }
-
- TREE_TYPE (acc_loop) = void_type_node;
- OMP_FOR_INIT (acc_loop) = initv;
- OMP_FOR_COND (acc_loop) = condv;
- OMP_FOR_INCR (acc_loop) = incrv;
- OMP_FOR_BODY (acc_loop) = end_stmt_group ();
- OMP_FOR_PRE_BODY (acc_loop) = NULL;
- OMP_FOR_ORIG_DECLS (acc_loop) = NULL;
- OMP_FOR_CLAUSES (acc_loop) = gnu_loop_stack->last ()->omp_loop_clauses;
-
- BIND_EXPR_BODY (acc_bind_expr) = acc_loop;
-
- return acc_bind_expr;
-}
-
/* Helper for Loop_Statement_to_gnu, to translate the body of a loop not
subject to any sort of parallelization directive or restriction, designated
by GNAT_NODE.
@@ -3945,34 +3335,7 @@ Loop_Statement_to_gnu (Node_Id gnat_node)
gnu_loop_info->stmt = gnu_loop_stmt;
/* Perform the core loop body translation. */
- if (Is_OpenAcc_Loop (gnat_node))
- gnu_loop_stmt = Acc_Loop_to_gnu (gnat_node);
- else
- gnu_loop_stmt = Regular_Loop_to_gnu (gnat_node, &gnu_cond_expr);
-
- /* A gnat_node that has its OpenAcc_Environment flag set needs to be
- offloaded. Note that the OpenAcc_Loop flag is not necessarily set. */
- if (Is_OpenAcc_Environment (gnat_node))
- {
- tree_code code = gnu_loop_stack->last ()->omp_code;
- tree tmp = make_node (code);
- TREE_TYPE (tmp) = void_type_node;
- if (code == OACC_PARALLEL || code == OACC_KERNELS)
- {
- OMP_BODY (tmp) = gnu_loop_stmt;
- OMP_CLAUSES (tmp) = gnu_loop_stack->last ()->omp_construct_clauses;
- }
- else if (code == OACC_DATA)
- {
- OACC_DATA_BODY (tmp) = gnu_loop_stmt;
- OACC_DATA_CLAUSES (tmp) =
- gnu_loop_stack->last ()->omp_construct_clauses;
- }
- else
- gcc_unreachable();
- set_expr_location_from_node (tmp, gnat_node);
- gnu_loop_stmt = tmp;
- }
+ gnu_loop_stmt = Regular_Loop_to_gnu (gnat_node, &gnu_cond_expr);
/* If we have an outer COND_EXPR, that's our result and this loop is its
"true" statement. Otherwise, the result is the LOOP_STMT. */
@@ -5069,9 +4432,10 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
tree gnu_after_list = NULL_TREE;
tree gnu_retval = NULL_TREE;
tree gnu_call, gnu_result;
- bool by_descriptor = false;
bool went_into_elab_proc = false;
bool pushed_binding_level = false;
+ bool variadic;
+ bool by_descriptor;
Entity_Id gnat_formal;
Node_Id gnat_actual;
atomic_acces_t aa_type;
@@ -5117,20 +4481,32 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
entity being called. */
if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
{
+ const Entity_Id gnat_prefix_type
+ = Underlying_Type (Etype (Prefix (Name (gnat_node))));
+
gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
+ variadic = IN (Convention (gnat_prefix_type), Convention_C_Variadic);
/* If the access type doesn't require foreign-compatible representation,
be prepared for descriptors. */
- if (targetm.calls.custom_function_descriptors > 0
- && Can_Use_Internal_Rep
- (Underlying_Type (Etype (Prefix (Name (gnat_node))))))
- by_descriptor = true;
+ by_descriptor
+ = targetm.calls.custom_function_descriptors > 0
+ && Can_Use_Internal_Rep (gnat_prefix_type);
}
else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
- /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
- gnat_formal = Empty;
+ {
+ /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
+ gnat_formal = Empty;
+ variadic = false;
+ by_descriptor = false;
+ }
else
- gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
+ {
+ gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
+ variadic
+ = IN (Convention (Entity (Name (gnat_node))), Convention_C_Variadic);
+ by_descriptor = false;
+ }
/* The lifetime of the temporaries created for the call ends right after the
return value is copied, so we can give them the scope of the elaboration
@@ -5452,7 +4828,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
subprogram. */
else if (is_true_formal_parm && DECL_BY_COMPONENT_PTR_P (gnu_formal))
{
- gnu_actual = maybe_implicit_deref (gnu_actual);
+ gnu_actual = maybe_padded_object (gnu_actual);
gnu_actual = maybe_unconstrained_array (gnu_actual);
/* Take the address of the object and convert to the proper pointer
@@ -5465,51 +4841,110 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
}
- /* Otherwise the parameter is passed by copy. */
- else
+ /* Then see if the parameter is passed by copy. */
+ else if (is_true_formal_parm)
{
- tree gnu_size;
-
if (!in_param)
gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
- /* If we didn't create a PARM_DECL for the formal, this means that
- it is an Out parameter not passed by reference and that need not
- be copied in. In this case, the value of the actual need not be
- read. However, we still need to make sure that its side-effects
- are evaluated before the call, so we evaluate its address. */
- if (!is_true_formal_parm)
+ gnu_actual = convert (gnu_formal_type, gnu_actual);
+
+ /* If this is a front-end built-in function, there is no need to
+ convert to the type used to pass the argument. */
+ if (!frontend_builtin)
+ gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
+ }
+
+ /* Then see if this is an unnamed parameter in a variadic C function. */
+ else if (variadic)
+ {
+ /* This is based on the processing done in gnat_to_gnu_param, but
+ we expect the mechanism to be set in (almost) all cases. */
+ const Mechanism_Type mech = Mechanism (gnat_formal);
+
+ /* Strip off possible padding type. */
+ if (TYPE_IS_PADDING_P (gnu_formal_type))
+ gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
+
+ /* Arrays are passed as pointers to element type. First check for
+ unconstrained array and get the underlying array. */
+ if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
+ gnu_formal_type
+ = TREE_TYPE
+ (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_formal_type))));
+
+ /* Arrays are passed as pointers to element type. */
+ if (mech != By_Copy && TREE_CODE (gnu_formal_type) == ARRAY_TYPE)
{
- if (TREE_SIDE_EFFECTS (gnu_name))
- {
- tree addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_name);
- append_to_statement_list (addr, &gnu_stmt_list);
- }
- continue;
+ gnu_actual = maybe_padded_object (gnu_actual);
+ gnu_actual = maybe_unconstrained_array (gnu_actual);
+
+ /* Strip off any multi-dimensional entries, then strip
+ off the last array to get the component type. */
+ while (TREE_CODE (TREE_TYPE (gnu_formal_type)) == ARRAY_TYPE
+ && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_formal_type)))
+ gnu_formal_type = TREE_TYPE (gnu_formal_type);
+
+ gnu_formal_type = TREE_TYPE (gnu_formal_type);
+ gnu_formal_type = build_pointer_type (gnu_formal_type);
+ gnu_actual
+ = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
+ }
+
+ /* Fat pointers are passed as thin pointers. */
+ else if (TYPE_IS_FAT_POINTER_P (gnu_formal_type))
+ gnu_formal_type
+ = make_type_from_size (gnu_formal_type,
+ size_int (POINTER_SIZE), 0);
+
+ /* If we were requested or muss pass by reference, do so.
+ If we were requested to pass by copy, do so.
+ Otherwise, pass In Out or Out parameters or aggregates by
+ reference. */
+ else if (mech == By_Reference
+ || must_pass_by_ref (gnu_formal_type)
+ || (mech != By_Copy
+ && (!in_param || AGGREGATE_TYPE_P (gnu_formal_type))))
+ {
+ gnu_formal_type = build_reference_type (gnu_formal_type);
+ gnu_actual
+ = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
+ }
+
+ /* Otherwise pass by copy after applying default C promotions. */
+ else
+ {
+ if (INTEGRAL_TYPE_P (gnu_formal_type)
+ && TYPE_PRECISION (gnu_formal_type)
+ < TYPE_PRECISION (integer_type_node))
+ gnu_formal_type = integer_type_node;
+
+ else if (SCALAR_FLOAT_TYPE_P (gnu_formal_type)
+ && TYPE_PRECISION (gnu_formal_type)
+ < TYPE_PRECISION (double_type_node))
+ gnu_formal_type = double_type_node;
}
gnu_actual = convert (gnu_formal_type, gnu_actual);
+ }
- /* If this is 'Null_Parameter, pass a zero even though we are
- dereferencing it. */
- if (TREE_CODE (gnu_actual) == INDIRECT_REF
- && TREE_PRIVATE (gnu_actual)
- && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
- && TREE_CODE (gnu_size) == INTEGER_CST
- && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
+ /* If we didn't create a PARM_DECL for the formal, this means that
+ it is an Out parameter not passed by reference and that need not
+ be copied in. In this case, the value of the actual need not be
+ read. However, we still need to make sure that its side-effects
+ are evaluated before the call, so we evaluate its address. */
+ else
+ {
+ if (!in_param)
+ gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
+
+ if (TREE_SIDE_EFFECTS (gnu_name))
{
- tree type_for_size
- = gnat_type_for_size (TREE_INT_CST_LOW (gnu_size), 1);
- gnu_actual
- = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
- build_int_cst (type_for_size, 0),
- false);
+ tree addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_name);
+ append_to_statement_list (addr, &gnu_stmt_list);
}
- /* If this is a front-end built-in function, there is no need to
- convert to the type used to pass the argument. */
- else if (!frontend_builtin)
- gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
+ continue;
}
gnu_actual_vec.safe_push (gnu_actual);
@@ -5630,11 +5065,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
tree gnu_actual
= maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
- /* If the result is a padded type, remove the padding. */
- if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
- gnu_result
- = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
- gnu_result);
+ /* If the result is padded, remove the padding. */
+ gnu_result = maybe_padded_object (gnu_result);
/* If the actual is a type conversion, the real target object is
denoted by the inner Expression and we need to convert the
@@ -6501,13 +5933,14 @@ static tree
Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
{
const Node_Kind kind = Nkind (gnat_node);
- const int reason = UI_To_Int (Reason (gnat_node));
const Node_Id gnat_cond = Condition (gnat_node);
+ const int reason = UI_To_Int (Reason (gnat_node));
const bool with_extra_info
= Exception_Extra_Info
&& !No_Exception_Handlers_Set ()
&& No (get_exception_label (kind));
tree gnu_result = NULL_TREE, gnu_cond = NULL_TREE;
+ Node_Id gnat_rcond;
/* The following processing is not required for correctness. Its purpose is
to give more precise error messages and to record some information. */
@@ -6521,51 +5954,51 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
case CE_Index_Check_Failed:
case CE_Range_Check_Failed:
case CE_Invalid_Data:
- if (Present (gnat_cond) && Nkind (gnat_cond) == N_Op_Not)
+ if (No (gnat_cond) || Nkind (gnat_cond) != N_Op_Not)
+ break;
+ gnat_rcond = Right_Opnd (gnat_cond);
+ if (Nkind (gnat_rcond) == N_In
+ || Nkind (gnat_rcond) == N_Op_Ge
+ || Nkind (gnat_rcond) == N_Op_Le)
{
- Node_Id gnat_index, gnat_type;
- tree gnu_type, gnu_index, gnu_low_bound, gnu_high_bound, disp;
- bool neg_p;
+ const Node_Id gnat_index = Left_Opnd (gnat_rcond);
+ const Node_Id gnat_type = Etype (gnat_index);
+ tree gnu_index = gnat_to_gnu (gnat_index);
+ tree gnu_type = get_unpadded_type (gnat_type);
+ tree gnu_low_bound, gnu_high_bound, disp;
struct loop_info_d *loop;
+ bool neg_p;
- switch (Nkind (Right_Opnd (gnat_cond)))
+ switch (Nkind (gnat_rcond))
{
case N_In:
- Range_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)),
+ Range_to_gnu (Right_Opnd (gnat_rcond),
&gnu_low_bound, &gnu_high_bound);
break;
case N_Op_Ge:
- gnu_low_bound = gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)));
- gnu_high_bound = NULL_TREE;
+ gnu_low_bound = gnat_to_gnu (Right_Opnd (gnat_rcond));
+ gnu_high_bound = TYPE_MAX_VALUE (gnu_type);
break;
case N_Op_Le:
- gnu_low_bound = NULL_TREE;
- gnu_high_bound = gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)));
+ gnu_low_bound = TYPE_MIN_VALUE (gnu_type);
+ gnu_high_bound = gnat_to_gnu (Right_Opnd (gnat_rcond));
break;
default:
- goto common;
+ gcc_unreachable ();
}
- gnat_index = Left_Opnd (Right_Opnd (gnat_cond));
- gnat_type = Etype (gnat_index);
- gnu_type = maybe_character_type (get_unpadded_type (gnat_type));
- gnu_index = gnat_to_gnu (gnat_index);
-
+ gnu_type = maybe_character_type (gnu_type);
if (TREE_TYPE (gnu_index) != gnu_type)
{
- if (gnu_low_bound)
- gnu_low_bound = convert (gnu_type, gnu_low_bound);
- if (gnu_high_bound)
- gnu_high_bound = convert (gnu_type, gnu_high_bound);
+ gnu_low_bound = convert (gnu_type, gnu_low_bound);
+ gnu_high_bound = convert (gnu_type, gnu_high_bound);
gnu_index = convert (gnu_type, gnu_index);
}
if (with_extra_info
- && gnu_low_bound
- && gnu_high_bound
&& Known_Esize (gnat_type)
&& UI_To_Int (Esize (gnat_type)) <= 32)
gnu_result
@@ -6630,8 +6063,8 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
break;
}
- /* The following processing does the common work. */
-common:
+ /* The following processing does the real work, but we must nevertheless make
+ sure not to override the result of the previous processing. */
if (!gnu_result)
gnu_result = build_call_raise (reason, gnat_node, kind);
set_expr_location_from_node (gnu_result, gnat_node);
@@ -6958,19 +6391,15 @@ gnat_to_gnu (Node_Id gnat_node)
int i;
char *string;
if (length >= ALLOCA_THRESHOLD)
- string = XNEWVEC (char, length + 1);
+ string = XNEWVEC (char, length);
else
- string = (char *) alloca (length + 1);
+ string = (char *) alloca (length);
/* Build the string with the characters in the literal. Note
that Ada strings are 1-origin. */
for (i = 0; i < length; i++)
string[i] = Get_String_Char (gnat_string, i + 1);
- /* Put a null at the end of the string in case it's in a context
- where GCC will want to treat it as a C string. */
- string[i] = 0;
-
gnu_result = build_string (length, string);
/* Strings in GCC don't normally have types, but we want
@@ -7105,31 +6534,19 @@ gnat_to_gnu (Node_Id gnat_node)
&& (Is_Array_Type (Etype (gnat_temp))
|| Is_Record_Type (Etype (gnat_temp))
|| Is_Concurrent_Type (Etype (gnat_temp)))))
- {
- tree gnu_temp
- = gnat_to_gnu_entity (gnat_temp,
- gnat_to_gnu (Renamed_Object (gnat_temp)),
- true);
- /* See case 2 of renaming in gnat_to_gnu_entity. */
- if (TREE_SIDE_EFFECTS (gnu_temp))
- gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_temp);
- }
+ gnat_to_gnu_entity (gnat_temp,
+ gnat_to_gnu (Renamed_Object (gnat_temp)),
+ true);
break;
case N_Exception_Renaming_Declaration:
gnat_temp = Defining_Entity (gnat_node);
gnu_result = alloc_stmt_list ();
- /* See the above case for the rationale. */
if (Present (Renamed_Entity (gnat_temp)))
- {
- tree gnu_temp
- = gnat_to_gnu_entity (gnat_temp,
- gnat_to_gnu (Renamed_Entity (gnat_temp)),
- true);
- if (TREE_SIDE_EFFECTS (gnu_temp))
- gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_temp);
- }
+ gnat_to_gnu_entity (gnat_temp,
+ gnat_to_gnu (Renamed_Entity (gnat_temp)),
+ true);
break;
case N_Subprogram_Renaming_Declaration:
@@ -7190,14 +6607,13 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Indexed_Component:
{
- tree gnu_array_object
- = gnat_to_gnu (adjust_for_implicit_deref (Prefix (gnat_node)));
+ tree gnu_array_object = gnat_to_gnu ((Prefix (gnat_node)));
tree gnu_type;
- int ndim;
- int i;
+ int ndim, i;
Node_Id *gnat_expr_array;
- gnu_array_object = maybe_implicit_deref (gnu_array_object);
+ gnu_array_object = maybe_padded_object (gnu_array_object);
+ gnu_array_object = maybe_unconstrained_array (gnu_array_object);
/* Convert vector inputs to their representative array type, to fit
what the code below expects. */
@@ -7208,14 +6624,6 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_array_object = maybe_vector_array (gnu_array_object);
}
- gnu_array_object = maybe_unconstrained_array (gnu_array_object);
-
- /* If we got a padded type, remove it too. */
- if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
- gnu_array_object
- = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
- gnu_array_object);
-
/* The failure of this assertion will very likely come from a missing
expansion for a packed array access. */
gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object)) == ARRAY_TYPE);
@@ -7268,12 +6676,11 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Slice:
{
- tree gnu_array_object
- = gnat_to_gnu (adjust_for_implicit_deref (Prefix (gnat_node)));
+ tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_array_object = maybe_implicit_deref (gnu_array_object);
+ gnu_array_object = maybe_padded_object (gnu_array_object);
gnu_array_object = maybe_unconstrained_array (gnu_array_object);
gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
@@ -7293,12 +6700,11 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Selected_Component:
{
- Entity_Id gnat_prefix
- = adjust_for_implicit_deref (Prefix (gnat_node));
+ const Entity_Id gnat_prefix = Prefix (gnat_node);
Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
tree gnu_prefix = gnat_to_gnu (gnat_prefix);
- gnu_prefix = maybe_implicit_deref (gnu_prefix);
+ gnu_prefix = maybe_padded_object (gnu_prefix);
/* gnat_to_gnu_entity does not save the GNU tree made for renamed
discriminants so avoid making recursive calls on each reference
@@ -7748,9 +7154,8 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Allocator:
{
- tree gnu_init = NULL_TREE;
- tree gnu_type;
- bool ignore_init_type = false;
+ tree gnu_type, gnu_init;
+ bool ignore_init_type;
gnat_temp = Expression (gnat_node);
@@ -7759,15 +7164,22 @@ gnat_to_gnu (Node_Id gnat_node)
contains both the type and an initial value for the object. */
if (Nkind (gnat_temp) == N_Identifier
|| Nkind (gnat_temp) == N_Expanded_Name)
- gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
+ {
+ ignore_init_type = false;
+ gnu_init = NULL_TREE;
+ gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
+ }
+
else if (Nkind (gnat_temp) == N_Qualified_Expression)
{
- Entity_Id gnat_desig_type
+ const Entity_Id gnat_desig_type
= Designated_Type (Underlying_Type (Etype (gnat_node)));
- ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
- gnu_init = gnat_to_gnu (Expression (gnat_temp));
+ /* The flag is effectively only set on the base types. */
+ ignore_init_type
+ = Has_Constrained_Partial_View (Base_Type (gnat_desig_type));
+ gnu_init = gnat_to_gnu (Expression (gnat_temp));
gnu_init = maybe_unconstrained_array (gnu_init);
gigi_checking_assert (!Do_Range_Check (Expression (gnat_temp)));
@@ -7849,25 +7261,27 @@ gnat_to_gnu (Node_Id gnat_node)
else
{
const Node_Id gnat_expr = Expression (gnat_node);
+ const Node_Id gnat_inner
+ = Nkind (gnat_expr) == N_Qualified_Expression
+ ? Expression (gnat_expr)
+ : gnat_expr;
const Entity_Id gnat_type
= Underlying_Type (Etype (Name (gnat_node)));
- const bool regular_array_type_p
- = (Is_Array_Type (gnat_type) && !Is_Bit_Packed_Array (gnat_type));
const bool use_memset_p
- = (regular_array_type_p
- && Nkind (gnat_expr) == N_Aggregate
- && Is_Others_Aggregate (gnat_expr));
+ = Is_Array_Type (gnat_type)
+ && Nkind (gnat_inner) == N_Aggregate
+ && Is_Single_Aggregate (gnat_inner);
- /* If we'll use memset, we need to find the inner expression. */
+ /* If we use memset, we need to find the innermost expression. */
if (use_memset_p)
{
- Node_Id gnat_inner
- = Expression (First (Component_Associations (gnat_expr)));
- while (Nkind (gnat_inner) == N_Aggregate
- && Is_Others_Aggregate (gnat_inner))
- gnat_inner
- = Expression (First (Component_Associations (gnat_inner)));
- gnu_rhs = gnat_to_gnu (gnat_inner);
+ gnat_temp = gnat_inner;
+ do {
+ gnat_temp
+ = Expression (First (Component_Associations (gnat_temp)));
+ } while (Nkind (gnat_temp) == N_Aggregate
+ && Is_Single_Aggregate (gnat_temp));
+ gnu_rhs = gnat_to_gnu (gnat_temp);
}
else
gnu_rhs = maybe_unconstrained_array (gnat_to_gnu (gnat_expr));
@@ -7925,7 +7339,8 @@ gnat_to_gnu (Node_Id gnat_node)
not completely disjoint, play safe and use memmove. But don't do
it for a bit-packed array as it might not be byte-aligned. */
if (TREE_CODE (gnu_result) == MODIFY_EXPR
- && regular_array_type_p
+ && Is_Array_Type (gnat_type)
+ && !Is_Bit_Packed_Array (gnat_type)
&& !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node)))
{
tree to = TREE_OPERAND (gnu_result, 0);
@@ -8612,12 +8027,21 @@ gnat_to_gnu (Node_Id gnat_node)
break;
case N_Free_Statement:
+ gnat_temp = Expression (gnat_node);
+
if (!type_annotate_only)
{
- tree gnu_ptr
- = gnat_to_gnu (adjust_for_implicit_deref (Expression (gnat_node)));
- tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
- tree gnu_obj_type, gnu_actual_obj_type;
+ tree gnu_ptr, gnu_ptr_type, gnu_obj_type, gnu_actual_obj_type;
+
+ const Entity_Id gnat_desig_type
+ = Designated_Type (Underlying_Type (Etype (gnat_temp)));
+
+ /* Make sure the designated type is complete before dereferencing,
+ in case it is a Taft Amendment type. */
+ (void) gnat_to_gnu_entity (gnat_desig_type, NULL_TREE, false);
+
+ gnu_ptr = gnat_to_gnu (gnat_temp);
+ gnu_ptr_type = TREE_TYPE (gnu_ptr);
/* If this is a thin pointer, we must first dereference it to create
a fat pointer, then go back below to a thin pointer. The reason
@@ -8727,8 +8151,9 @@ gnat_to_gnu (Node_Id gnat_node)
|| kind == N_Indexed_Component
|| kind == N_Selected_Component)
&& TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
- && !lvalue_required_p (gnat_node, gnu_result_type, false, false)
- && Nkind (Parent (gnat_node)) != N_Variant_Part)
+ && Nkind (Parent (gnat_node)) != N_Attribute_Reference
+ && Nkind (Parent (gnat_node)) != N_Variant_Part
+ && !lvalue_required_p (gnat_node, gnu_result_type, false, false))
{
gnu_result
= build_binary_op (NE_EXPR, gnu_result_type,
@@ -8789,7 +8214,8 @@ gnat_to_gnu (Node_Id gnat_node)
1. If this is the LHS of an assignment or an actual parameter of a
call, return the result almost unmodified since the RHS will have
to be converted to our type in that case, unless the result type
- has a simpler size. Likewise if there is just a no-op unchecked
+ has a simpler size or for array types because this size might be
+ changed in-between. Likewise if there is just a no-op unchecked
conversion in-between. Similarly, don't convert integral types
that are the operands of an unchecked conversion since we need
to ignore those conversions (for 'Valid).
@@ -8824,15 +8250,17 @@ gnat_to_gnu (Node_Id gnat_node)
&& !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
&& !(TYPE_SIZE (gnu_result_type)
&& TYPE_SIZE (TREE_TYPE (gnu_result))
- && (AGGREGATE_TYPE_P (gnu_result_type)
- == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
+ && AGGREGATE_TYPE_P (gnu_result_type)
+ == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))
&& ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
&& (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
!= INTEGER_CST))
|| (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
&& !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
&& (CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (gnu_result))))))
+ (TYPE_SIZE (TREE_TYPE (gnu_result)))))
+ || (TREE_CODE (gnu_result_type) == ARRAY_TYPE
+ && TREE_CODE (TREE_TYPE (gnu_result)) == ARRAY_TYPE))
&& !(TREE_CODE (gnu_result_type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
{
@@ -8854,9 +8282,7 @@ gnat_to_gnu (Node_Id gnat_node)
&& TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
{
/* Remove any padding. */
- if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
- gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
- gnu_result);
+ gnu_result = maybe_padded_object (gnu_result);
}
else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
@@ -9082,10 +8508,8 @@ add_decl_expr (tree gnu_decl, Node_Id gnat_node)
DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
}
- /* If GNU_DECL has a padded type, convert it to the unpadded
- type so the assignment is done properly. */
- if (TYPE_IS_PADDING_P (type))
- gnu_decl = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
+ /* Remove any padding so the assignment is done properly. */
+ gnu_decl = maybe_padded_object (gnu_decl);
gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_decl, gnu_init);
add_stmt_with_node (gnu_stmt, gnat_node);
@@ -9134,6 +8558,7 @@ add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
{
if (Present (gnat_node))
set_expr_location_from_node (gnu_cleanup, gnat_node, true);
+
/* An EH_ELSE_EXPR must be by itself, and that's all we need when we
use it. The assert below makes sure that is so. Should we ever
need more than that, we could combine EH_ELSE_EXPRs, and copy
@@ -10783,39 +10208,6 @@ validate_unchecked_conversion (Node_Id gnat_node)
}
}
-/* EXP is to be used in a context where access objects are implicitly
- dereferenced. Handle the cases when it is an access object. */
-
-static Node_Id
-adjust_for_implicit_deref (Node_Id exp)
-{
- Entity_Id type = Underlying_Type (Etype (exp));
-
- /* Make sure the designated type is complete before dereferencing. */
- if (Is_Access_Type (type))
- gnat_to_gnu_entity (Designated_Type (type), NULL_TREE, false);
-
- return exp;
-}
-
-/* EXP is to be treated as an array or record. Handle the cases when it is
- an access object and perform the required dereferences. */
-
-static tree
-maybe_implicit_deref (tree exp)
-{
- /* If the type is a pointer, dereference it. */
- if (POINTER_TYPE_P (TREE_TYPE (exp))
- || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp)))
- exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
-
- /* If we got a padded type, remove it too. */
- if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
- exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
-
- return exp;
-}
-
/* Convert SLOC into LOCUS. Return true if SLOC corresponds to a
source code location and false if it doesn't. If CLEAR_COLUMN is
true, set the column information to 0. If DECL is given and SLOC
diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c
index fa98a5a..a96fde6 100644
--- a/gcc/ada/gcc-interface/utils.c
+++ b/gcc/ada/gcc-interface/utils.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -50,6 +50,7 @@
#include "types.h"
#include "atree.h"
#include "nlists.h"
+#include "snames.h"
#include "uintp.h"
#include "fe.h"
#include "sinfo.h"
@@ -258,6 +259,29 @@ static GTY(()) vec<tree, va_gc> *builtin_decls;
/* A chain of unused BLOCK nodes. */
static GTY((deletable)) tree free_block_chain;
+/* A hash table of packable types. It is modelled on the generic type
+ hash table in tree.c, which must thus be used as a reference. */
+
+struct GTY((for_user)) packable_type_hash
+{
+ hashval_t hash;
+ tree type;
+};
+
+struct packable_type_hasher : ggc_cache_ptr_hash<packable_type_hash>
+{
+ static inline hashval_t hash (packable_type_hash *t) { return t->hash; }
+ static bool equal (packable_type_hash *a, packable_type_hash *b);
+
+ static int
+ keep_cache_entry (packable_type_hash *&t)
+ {
+ return ggc_marked_p (t->type);
+ }
+};
+
+static GTY ((cache)) hash_table<packable_type_hasher> *packable_type_hash_table;
+
/* A hash table of padded types. It is modelled on the generic type
hash table in tree.c, which must thus be used as a reference. */
@@ -333,6 +357,9 @@ init_gnat_utils (void)
/* Initialize the association of GNAT nodes to GCC trees as dummies. */
dummy_node_table = ggc_cleared_vec_alloc<tree> (max_gnat_nodes);
+ /* Initialize the hash table of packable types. */
+ packable_type_hash_table = hash_table<packable_type_hasher>::create_ggc (512);
+
/* Initialize the hash table of padded types. */
pad_type_hash_table = hash_table<pad_type_hasher>::create_ggc (512);
}
@@ -350,6 +377,10 @@ destroy_gnat_utils (void)
ggc_free (dummy_node_table);
dummy_node_table = NULL;
+ /* Destroy the hash table of packable types. */
+ packable_type_hash_table->empty ();
+ packable_type_hash_table = NULL;
+
/* Destroy the hash table of padded types. */
pad_type_hash_table->empty ();
pad_type_hash_table = NULL;
@@ -861,6 +892,9 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
their GNAT encodings. */
if (TREE_CODE (t) == ARRAY_TYPE && !TYPE_NAME (t))
TYPE_NAME (t) = DECL_NAME (decl);
+ /* Remark the canonical fat pointer type as artificial. */
+ if (TYPE_IS_FAT_POINTER_P (t))
+ TYPE_ARTIFICIAL (t) = 1;
t = NULL_TREE;
}
else if (TYPE_NAME (t)
@@ -983,6 +1017,71 @@ make_aligning_type (tree type, unsigned int align, tree size,
return record_type;
}
+/* Return true iff the packable types are equivalent. */
+
+bool
+packable_type_hasher::equal (packable_type_hash *t1, packable_type_hash *t2)
+{
+ tree type1, type2;
+
+ if (t1->hash != t2->hash)
+ return 0;
+
+ type1 = t1->type;
+ type2 = t2->type;
+
+ /* We consider that packable types are equivalent if they have the same name,
+ size, alignment, RM size and storage order. Taking the mode into account
+ is redundant since it is determined by the others. */
+ return
+ TYPE_NAME (type1) == TYPE_NAME (type2)
+ && TYPE_SIZE (type1) == TYPE_SIZE (type2)
+ && TYPE_ALIGN (type1) == TYPE_ALIGN (type2)
+ && TYPE_ADA_SIZE (type1) == TYPE_ADA_SIZE (type2)
+ && TYPE_REVERSE_STORAGE_ORDER (type1) == TYPE_REVERSE_STORAGE_ORDER (type2);
+}
+
+/* Compute the hash value for the packable TYPE. */
+
+static hashval_t
+hash_packable_type (tree type)
+{
+ hashval_t hashcode;
+
+ hashcode = iterative_hash_expr (TYPE_NAME (type), 0);
+ hashcode = iterative_hash_expr (TYPE_SIZE (type), hashcode);
+ hashcode = iterative_hash_hashval_t (TYPE_ALIGN (type), hashcode);
+ hashcode = iterative_hash_expr (TYPE_ADA_SIZE (type), hashcode);
+ hashcode
+ = iterative_hash_hashval_t (TYPE_REVERSE_STORAGE_ORDER (type), hashcode);
+
+ return hashcode;
+}
+
+/* Look up the packable TYPE in the hash table and return its canonical version
+ if it exists; otherwise, insert it into the hash table. */
+
+static tree
+canonicalize_packable_type (tree type)
+{
+ const hashval_t hashcode = hash_packable_type (type);
+ struct packable_type_hash in, *h, **slot;
+
+ in.hash = hashcode;
+ in.type = type;
+ slot = packable_type_hash_table->find_slot_with_hash (&in, hashcode, INSERT);
+ h = *slot;
+ if (!h)
+ {
+ h = ggc_alloc<packable_type_hash> ();
+ h->hash = hashcode;
+ h->type = type;
+ *slot = h;
+ }
+
+ return h->type;
+}
+
/* TYPE is an ARRAY_TYPE that is being used as the type of a field in a packed
record. See if we can rewrite it as a type that has non-BLKmode, which we
can pack tighter in the packed record. If so, return the new type; if not,
@@ -1062,16 +1161,16 @@ make_packable_type (tree type, bool in_record, unsigned int max_align)
}
else
{
- tree type_size = TYPE_ADA_SIZE (type);
+ tree ada_size = TYPE_ADA_SIZE (type);
+
/* Do not try to shrink the size if the RM size is not constant. */
- if (TYPE_CONTAINS_TEMPLATE_P (type)
- || !tree_fits_uhwi_p (type_size))
+ if (TYPE_CONTAINS_TEMPLATE_P (type) || !tree_fits_uhwi_p (ada_size))
return type;
/* Round the RM size up to a unit boundary to get the minimal size
for a BLKmode record. Give up if it's already the size and we
don't need to lower the alignment. */
- new_size = tree_to_uhwi (type_size);
+ new_size = tree_to_uhwi (ada_size);
new_size = (new_size + BITS_PER_UNIT - 1) & -BITS_PER_UNIT;
if (new_size == size && (max_align == 0 || align <= max_align))
return type;
@@ -1117,7 +1216,13 @@ make_packable_type (tree type, bool in_record, unsigned int max_align)
&& TYPE_ADA_SIZE (new_field_type))
new_field_size = TYPE_ADA_SIZE (new_field_type);
else
- new_field_size = DECL_SIZE (field);
+ {
+ new_field_size = DECL_SIZE (field);
+
+ /* Make sure not to use too small a type for the size. */
+ if (TYPE_MODE (new_field_type) == BLKmode)
+ new_field_type = TREE_TYPE (field);
+ }
/* This is a layout with full representation, alignment and size clauses
so we simply pass 0 as PACKED like gnat_to_gnu_field in this case. */
@@ -1160,8 +1265,8 @@ make_packable_type (tree type, bool in_record, unsigned int max_align)
SET_DECL_PARALLEL_TYPE (TYPE_STUB_DECL (new_type),
DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type)));
- /* Try harder to get a packable type if necessary, for example
- in case the record itself contains a BLKmode field. */
+ /* Try harder to get a packable type if necessary, for example in case
+ the record itself contains a BLKmode field. */
if (in_record && TYPE_MODE (new_type) == BLKmode)
SET_TYPE_MODE (new_type,
mode_for_size_tree (TYPE_SIZE (new_type),
@@ -1171,7 +1276,11 @@ make_packable_type (tree type, bool in_record, unsigned int max_align)
if (TYPE_MODE (new_type) == BLKmode && new_size >= size && max_align == 0)
return type;
- return new_type;
+ /* If the packable type is named, we canonicalize it by means of the hash
+ table. This is consistent with the language semantics and ensures that
+ gigi and the middle-end have a common view of these packable types. */
+ return
+ TYPE_NAME (new_type) ? canonicalize_packable_type (new_type) : new_type;
}
/* Return true if TYPE has an unsigned representation. This needs to be used
@@ -1230,9 +1339,9 @@ make_type_from_size (tree type, tree size_tree, bool for_biased)
if (size == 0)
size = 1;
- /* Only do something if the type isn't a packed array type and doesn't
- already have the proper size and the size isn't too large. */
- if (TYPE_IS_PACKED_ARRAY_TYPE_P (type)
+ /* Only do something if the type is not a bit-packed array type and does
+ not already have the proper size and the size is not too large. */
+ if (BIT_PACKED_ARRAY_TYPE_P (type)
|| (TYPE_PRECISION (type) == size && biased_p == for_biased)
|| size > LONG_LONG_TYPE_SIZE)
break;
@@ -1300,7 +1409,7 @@ pad_type_hasher::equal (pad_type_hash *t1, pad_type_hash *t2)
type1 = t1->type;
type2 = t2->type;
- /* We consider that the padded types are equivalent if they pad the same type
+ /* We consider that padded types are equivalent if they pad the same type
and have the same size, alignment, RM size and storage order. Taking the
mode into account is redundant since it is determined by the others. */
return
@@ -1323,6 +1432,8 @@ hash_pad_type (tree type)
hashcode = iterative_hash_expr (TYPE_SIZE (type), hashcode);
hashcode = iterative_hash_hashval_t (TYPE_ALIGN (type), hashcode);
hashcode = iterative_hash_expr (TYPE_ADA_SIZE (type), hashcode);
+ hashcode
+ = iterative_hash_hashval_t (TYPE_REVERSE_STORAGE_ORDER (type), hashcode);
return hashcode;
}
@@ -1355,15 +1466,14 @@ canonicalize_pad_type (tree type)
if needed. We have already verified that SIZE and ALIGN are large enough.
GNAT_ENTITY is used to name the resulting record and to issue a warning.
IS_COMPONENT_TYPE is true if this is being done for the component type of
- an array. IS_USER_TYPE is true if the original type needs to be completed.
- DEFINITION is true if this type is being defined. SET_RM_SIZE is true if
- the RM size of the resulting type is to be set to SIZE too; in this case,
- the padded type is canonicalized before being returned. */
+ an array. DEFINITION is true if this type is being defined. SET_RM_SIZE
+ is true if the RM size of the resulting type is to be set to SIZE too; in
+ this case, the padded type is canonicalized before being returned. */
tree
maybe_pad_type (tree type, tree size, unsigned int align,
Entity_Id gnat_entity, bool is_component_type,
- bool is_user_type, bool definition, bool set_rm_size)
+ bool definition, bool set_rm_size)
{
tree orig_size = TYPE_SIZE (type);
unsigned int orig_align = TYPE_ALIGN (type);
@@ -1407,31 +1517,13 @@ maybe_pad_type (tree type, tree size, unsigned int align,
if (align == 0 && !size)
return type;
- /* If requested, complete the original type and give it a name. */
- if (is_user_type)
- create_type_decl (get_entity_name (gnat_entity), type,
- !Comes_From_Source (gnat_entity),
- !(TYPE_NAME (type)
- && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
- && DECL_IGNORED_P (TYPE_NAME (type))),
- gnat_entity);
-
/* We used to modify the record in place in some cases, but that could
generate incorrect debugging information. So make a new record
type and name. */
record = make_node (RECORD_TYPE);
TYPE_PADDING_P (record) = 1;
- /* ??? Padding types around packed array implementation types will be
- considered as root types in the array descriptor language hook (see
- gnat_get_array_descr_info). Give them the original packed array type
- name so that the one coming from sources appears in the debugging
- information. */
- if (TYPE_IMPL_PACKED_ARRAY_P (type)
- && TYPE_ORIGINAL_PACKED_ARRAY (type)
- && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
- TYPE_NAME (record) = TYPE_NAME (TYPE_ORIGINAL_PACKED_ARRAY (type));
- else if (Present (gnat_entity))
+ if (Present (gnat_entity))
TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD");
SET_TYPE_ALIGN (record, align ? align : orig_align);
@@ -1499,6 +1591,7 @@ maybe_pad_type (tree type, tree size, unsigned int align,
}
}
+ /* Make the inner type the debug type of the padded type. */
if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
SET_TYPE_DEBUG_TYPE (record, maybe_debug_type (type));
@@ -2469,7 +2562,7 @@ copy_type (tree type)
}
/* And the contents of the language-specific slot if needed. */
- if ((INTEGRAL_TYPE_P (type) || TREE_CODE (type) == REAL_TYPE)
+ if ((INTEGRAL_TYPE_P (type) || SCALAR_FLOAT_TYPE_P (type))
&& TYPE_RM_VALUES (type))
{
TYPE_RM_VALUES (new_type) = NULL_TREE;
@@ -2924,7 +3017,7 @@ create_field_decl (tree name, tree type, tree record_type, tree size, tree pos,
unsigned int known_align;
if (tree_fits_uhwi_p (pos))
- known_align = tree_to_uhwi (pos) & - tree_to_uhwi (pos);
+ known_align = tree_to_uhwi (pos) & -tree_to_uhwi (pos);
else
known_align = BITS_PER_UNIT;
@@ -3127,7 +3220,7 @@ compute_deferred_decl_context (Entity_Id gnat_scope)
if (TREE_CODE (context) == TYPE_DECL)
{
- const tree context_type = TREE_TYPE (context);
+ tree context_type = TREE_TYPE (context);
/* Skip dummy types: only the final ones can appear in the context
chain. */
@@ -4078,7 +4171,6 @@ tree
build_unc_object_type (tree template_type, tree object_type, tree name,
bool debug_info_p)
{
- tree decl;
tree type = make_node (RECORD_TYPE);
tree template_field
= create_field_decl (get_identifier ("BOUNDS"), template_type, type,
@@ -4094,12 +4186,7 @@ build_unc_object_type (tree template_type, tree object_type, tree name,
/* Declare it now since it will never be declared otherwise. This is
necessary to ensure that its subtrees are properly marked. */
- decl = create_type_decl (name, type, true, debug_info_p, Empty);
-
- /* template_type will not be used elsewhere than here, so to keep the debug
- info clean and in order to avoid scoping issues, make decl its
- context. */
- gnat_set_type_context (template_type, decl);
+ create_type_decl (name, type, true, debug_info_p, Empty);
return type;
}
@@ -4773,7 +4860,7 @@ convert (tree type, tree expr)
&& smaller_form_type_p (etype, type))
{
expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
- false, false, false, true),
+ false, false, true),
expr);
return build1 (VIEW_CONVERT_EXPR, type, expr);
}
@@ -5155,11 +5242,9 @@ maybe_unconstrained_array (tree exp)
exp = build_component_ref (exp, DECL_CHAIN (TYPE_FIELDS (type)),
false);
- type = TREE_TYPE (exp);
- /* If the array type is padded, convert to the unpadded type. */
- if (TYPE_IS_PADDING_P (type))
- exp = convert (TREE_TYPE (TYPE_FIELDS (type)), exp);
+ /* If the array is padded, remove the padding. */
+ exp = maybe_padded_object (exp);
}
break;
@@ -5395,14 +5480,14 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
if (c < 0)
{
expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
- false, false, false, true),
+ false, false, true),
expr);
expr = unchecked_convert (type, expr, notrunc_p);
}
else
{
tree rec_type = maybe_pad_type (type, TYPE_SIZE (etype), 0, Empty,
- false, false, false, true);
+ false, false, true);
expr = unchecked_convert (rec_type, expr, notrunc_p);
expr = build_component_ref (expr, TYPE_FIELDS (rec_type), false);
}
@@ -5420,14 +5505,14 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
if (c < 0)
{
expr = convert (maybe_pad_type (etype, new_size, 0, Empty,
- false, false, false, true),
+ false, false, true),
expr);
expr = unchecked_convert (type, expr, notrunc_p);
}
else
{
tree rec_type = maybe_pad_type (type, TYPE_SIZE (etype), 0, Empty,
- false, false, false, true);
+ false, false, true);
expr = unchecked_convert (rec_type, expr, notrunc_p);
expr = build_component_ref (expr, TYPE_FIELDS (rec_type), false);
}
@@ -5472,7 +5557,7 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
&& TYPE_ALIGN (etype) < TYPE_ALIGN (type))
{
expr = convert (maybe_pad_type (etype, NULL_TREE, TYPE_ALIGN (type),
- Empty, false, false, false, true),
+ Empty, false, false, true),
expr);
return unchecked_convert (type, expr, notrunc_p);
}
@@ -5489,7 +5574,7 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
|| tree_int_cst_lt (TYPE_SIZE (etype), TYPE_SIZE (type))))
{
expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0,
- Empty, false, false, false, true),
+ Empty, false, false, true),
expr);
return unchecked_convert (type, expr, notrunc_p);
}
@@ -5795,7 +5880,16 @@ gnat_write_global_declarations (void)
}
}
- /* Output debug information for all global type declarations first. This
+ /* First output the integral global variables, so that they can be referenced
+ as bounds by the global dynamic types. Skip external variables, unless we
+ really need to emit debug info for them:, e.g. imported variables. */
+ FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter)
+ if (TREE_CODE (iter) == VAR_DECL
+ && INTEGRAL_TYPE_P (TREE_TYPE (iter))
+ && (!DECL_EXTERNAL (iter) || !DECL_IGNORED_P (iter)))
+ rest_of_decl_compilation (iter, true, 0);
+
+ /* Now output debug information for the global type declarations. This
ensures that global types whose compilation hasn't been finalized yet,
for example pointers to Taft amendment types, have their compilation
finalized in the right context. */
@@ -5803,30 +5897,29 @@ gnat_write_global_declarations (void)
if (TREE_CODE (iter) == TYPE_DECL && !DECL_IGNORED_P (iter))
debug_hooks->type_decl (iter, false);
- /* Output imported functions. */
+ /* Then output the other global variables. We need to do that after the
+ information for global types is emitted so that they are finalized. */
FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter)
- if (TREE_CODE (iter) == FUNCTION_DECL
- && DECL_EXTERNAL (iter)
- && DECL_INITIAL (iter) == NULL
- && !DECL_IGNORED_P (iter)
- && DECL_FUNCTION_IS_DEF (iter))
- debug_hooks->early_global_decl (iter);
+ if (TREE_CODE (iter) == VAR_DECL
+ && !INTEGRAL_TYPE_P (TREE_TYPE (iter))
+ && (!DECL_EXTERNAL (iter) || !DECL_IGNORED_P (iter)))
+ rest_of_decl_compilation (iter, true, 0);
- /* Output global constants. */
+ /* Output debug information for the global constants. */
FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter)
if (TREE_CODE (iter) == CONST_DECL && !DECL_IGNORED_P (iter))
debug_hooks->early_global_decl (iter);
- /* Then output the global variables. We need to do that after the debug
- information for global types is emitted so that they are finalized. Skip
- external global variables, unless we need to emit debug info for them:
- this is useful for imported variables, for instance. */
+ /* Output it for the imported functions. */
FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter)
- if (TREE_CODE (iter) == VAR_DECL
- && (!DECL_EXTERNAL (iter) || !DECL_IGNORED_P (iter)))
- rest_of_decl_compilation (iter, true, 0);
+ if (TREE_CODE (iter) == FUNCTION_DECL
+ && DECL_EXTERNAL (iter)
+ && DECL_INITIAL (iter) == NULL
+ && !DECL_IGNORED_P (iter)
+ && DECL_FUNCTION_IS_DEF (iter))
+ debug_hooks->early_global_decl (iter);
- /* Output the imported modules/declarations. In GNAT, these are only
+ /* Output it for the imported modules/declarations. In GNAT, these are only
materializing subprogram. */
FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter)
if (TREE_CODE (iter) == IMPORTED_DECL && !DECL_IGNORED_P (iter))
diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c
index 6ff1372..c8a2d7c 100644
--- a/gcc/ada/gcc-interface/utils2.c
+++ b/gcc/ada/gcc-interface/utils2.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -32,6 +32,7 @@
#include "alias.h"
#include "tree.h"
#include "inchash.h"
+#include "builtins.h"
#include "fold-const.h"
#include "stor-layout.h"
#include "stringpool.h"
@@ -167,7 +168,10 @@ known_alignment (tree exp)
break;
case ADDR_EXPR:
- this_alignment = expr_align (TREE_OPERAND (exp, 0));
+ if (DECL_P (TREE_OPERAND (exp, 0)))
+ this_alignment = DECL_ALIGN (TREE_OPERAND (exp, 0));
+ else
+ this_alignment = get_object_alignment (TREE_OPERAND (exp, 0));
break;
case CALL_EXPR:
@@ -871,31 +875,21 @@ build_binary_op (enum tree_code op_code, tree result_type,
/* If there were integral or pointer conversions on the LHS, remove
them; we'll be putting them back below if needed. Likewise for
- conversions between array and record types, except for justified
- modular types. But don't do this if the right operand is not
- BLKmode (for packed arrays) unless we are not changing the mode. */
+ conversions between record types, except for justified modular types.
+ But don't do this if the right operand is not BLKmode (for packed
+ arrays) unless we are not changing the mode. */
while ((CONVERT_EXPR_P (left_operand)
|| TREE_CODE (left_operand) == VIEW_CONVERT_EXPR)
&& (((INTEGRAL_TYPE_P (left_type)
|| POINTER_TYPE_P (left_type))
- && (INTEGRAL_TYPE_P (TREE_TYPE
- (TREE_OPERAND (left_operand, 0)))
- || POINTER_TYPE_P (TREE_TYPE
- (TREE_OPERAND (left_operand, 0)))))
- || (((TREE_CODE (left_type) == RECORD_TYPE
- && !TYPE_JUSTIFIED_MODULAR_P (left_type))
- || TREE_CODE (left_type) == ARRAY_TYPE)
- && ((TREE_CODE (TREE_TYPE
- (TREE_OPERAND (left_operand, 0)))
- == RECORD_TYPE)
- || (TREE_CODE (TREE_TYPE
- (TREE_OPERAND (left_operand, 0)))
- == ARRAY_TYPE))
+ && (INTEGRAL_TYPE_P (operand_type (left_operand))
+ || POINTER_TYPE_P (operand_type (left_operand))))
+ || (TREE_CODE (left_type) == RECORD_TYPE
+ && !TYPE_JUSTIFIED_MODULAR_P (left_type)
+ && TREE_CODE (operand_type (left_operand)) == RECORD_TYPE
&& (TYPE_MODE (right_type) == BLKmode
- || (TYPE_MODE (left_type)
- == TYPE_MODE (TREE_TYPE
- (TREE_OPERAND
- (left_operand, 0))))))))
+ || TYPE_MODE (left_type)
+ == TYPE_MODE (operand_type (left_operand))))))
{
left_operand = TREE_OPERAND (left_operand, 0);
left_type = TREE_TYPE (left_operand);
@@ -917,8 +911,7 @@ build_binary_op (enum tree_code op_code, tree result_type,
&& TREE_CONSTANT (TYPE_SIZE (left_type))
&& ((TREE_CODE (right_operand) == COMPONENT_REF
&& TYPE_MAIN_VARIANT (left_type)
- == TYPE_MAIN_VARIANT
- (TREE_TYPE (TREE_OPERAND (right_operand, 0))))
+ == TYPE_MAIN_VARIANT (operand_type (right_operand)))
|| (TREE_CODE (right_operand) == CONSTRUCTOR
&& !CONTAINS_PLACEHOLDER_P
(DECL_SIZE (TYPE_FIELDS (left_type)))))
@@ -972,22 +965,23 @@ build_binary_op (enum tree_code op_code, tree result_type,
|| TREE_CODE (result) == ARRAY_RANGE_REF)
while (handled_component_p (result))
result = TREE_OPERAND (result, 0);
+
else if (TREE_CODE (result) == REALPART_EXPR
|| TREE_CODE (result) == IMAGPART_EXPR
|| (CONVERT_EXPR_P (result)
&& (((TREE_CODE (restype)
- == TREE_CODE (TREE_TYPE
- (TREE_OPERAND (result, 0))))
- && (TYPE_MODE (TREE_TYPE
- (TREE_OPERAND (result, 0)))
- == TYPE_MODE (restype)))
+ == TREE_CODE (operand_type (result))
+ && TYPE_MODE (restype)
+ == TYPE_MODE (operand_type (result))))
|| TYPE_ALIGN_OK (restype))))
result = TREE_OPERAND (result, 0);
+
else if (TREE_CODE (result) == VIEW_CONVERT_EXPR)
{
TREE_ADDRESSABLE (result) = 1;
result = TREE_OPERAND (result, 0);
}
+
else
break;
}
@@ -1036,8 +1030,15 @@ build_binary_op (enum tree_code op_code, tree result_type,
/* For a range, make sure the element type is consistent. */
if (op_code == ARRAY_RANGE_REF
&& TREE_TYPE (operation_type) != TREE_TYPE (left_type))
- operation_type = build_array_type (TREE_TYPE (left_type),
- TYPE_DOMAIN (operation_type));
+ {
+ operation_type
+ = build_nonshared_array_type (TREE_TYPE (left_type),
+ TYPE_DOMAIN (operation_type));
+ /* Declare it now since it will never be declared otherwise. This
+ is necessary to ensure that its subtrees are properly marked. */
+ create_type_decl (TYPE_NAME (operation_type), operation_type, true,
+ false, Empty);
+ }
/* Then convert the right operand to its base type. This will prevent
unneeded sign conversions when sizetype is wider than integer. */
@@ -1996,6 +1997,8 @@ build_simple_component_ref (tree record, tree field, bool no_fold)
tree type = TYPE_MAIN_VARIANT (TREE_TYPE (record));
tree ref;
+ /* The failure of this assertion will very likely come from a missing
+ insertion of an explicit dereference. */
gcc_assert (RECORD_OR_UNION_TYPE_P (type) && COMPLETE_TYPE_P (type));
/* Try to fold a conversion from another record or union type unless the type
@@ -2916,7 +2919,7 @@ is_simple_additive_expression (tree expr, tree *add, tree *cst, bool *minus_p)
tree
gnat_invariant_expr (tree expr)
{
- const tree type = TREE_TYPE (expr);
+ tree type = TREE_TYPE (expr);
tree add, cst;
bool minus_p;
@@ -2930,8 +2933,7 @@ gnat_invariant_expr (tree expr)
{
expr = DECL_INITIAL (expr);
/* Look into CONSTRUCTORs built to initialize padded types. */
- if (TYPE_IS_PADDING_P (TREE_TYPE (expr)))
- expr = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))), expr);
+ expr = maybe_padded_object (expr);
expr = remove_conversions (expr, false);
}
diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb
index bf6df5e..703d572 100644
--- a/gcc/ada/get_scos.adb
+++ b/gcc/ada/get_scos.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/get_scos.ads b/gcc/ada/get_scos.ads
index e3b4bdc..277c604 100644
--- a/gcc/ada/get_scos.ads
+++ b/gcc/ada/get_scos.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/get_targ.adb b/gcc/ada/get_targ.adb
index 5f5673c..ef307f2 100644
--- a/gcc/ada/get_targ.adb
+++ b/gcc/ada/get_targ.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/get_targ.ads b/gcc/ada/get_targ.ads
index 25005eb..5a21418 100644
--- a/gcc/ada/get_targ.ads
+++ b/gcc/ada/get_targ.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb
index c29b183..54d52ba 100644
--- a/gcc/ada/ghost.adb
+++ b/gcc/ada/ghost.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -370,12 +370,12 @@ package body Ghost is
-- treated as Ghost when they contain a reference to a Ghost
-- entity (SPARK RM 6.9(11)).
- elsif Nam_In (Prag_Nam, Name_Global,
- Name_Depends,
- Name_Initializes,
- Name_Refined_Global,
- Name_Refined_Depends,
- Name_Refined_State)
+ elsif Prag_Nam in Name_Global
+ | Name_Depends
+ | Name_Initializes
+ | Name_Refined_Global
+ | Name_Refined_Depends
+ | Name_Refined_State
then
return True;
end if;
@@ -1124,15 +1124,14 @@ package body Ghost is
-- When the context is a [generic] package declaration, pragma Ghost
-- resides in the visible declarations.
- if Nkind_In (N, N_Generic_Package_Declaration,
- N_Package_Declaration)
+ if Nkind (N) in N_Generic_Package_Declaration | N_Package_Declaration
then
Decl := First (Visible_Declarations (Specification (N)));
-- When the context is a package or a subprogram body, pragma Ghost
-- resides in the declarative part.
- elsif Nkind_In (N, N_Package_Body, N_Subprogram_Body) then
+ elsif Nkind (N) in N_Package_Body | N_Subprogram_Body then
Decl := First (Declarations (N));
-- Otherwise pragma Ghost appears in the declarations following N
@@ -1363,15 +1362,15 @@ package body Ghost is
-- A child package or subprogram declaration becomes Ghost when its
-- parent is Ghost (SPARK RM 6.9(2)).
- elsif Nkind_In (N, N_Generic_Function_Renaming_Declaration,
- N_Generic_Package_Declaration,
- N_Generic_Package_Renaming_Declaration,
- N_Generic_Procedure_Renaming_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Package_Declaration,
- N_Package_Renaming_Declaration,
- N_Subprogram_Declaration,
- N_Subprogram_Renaming_Declaration)
+ elsif Nkind (N) in N_Generic_Function_Renaming_Declaration
+ | N_Generic_Package_Declaration
+ | N_Generic_Package_Renaming_Declaration
+ | N_Generic_Procedure_Renaming_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Package_Declaration
+ | N_Package_Renaming_Declaration
+ | N_Subprogram_Declaration
+ | N_Subprogram_Renaming_Declaration
and then Present (Parent_Spec (N))
then
Par_Id := Defining_Entity (Unit (Parent_Spec (N)));
@@ -1569,14 +1568,14 @@ package body Ghost is
-- ??? could extra formal parameters cause a Ghost leak?
if Mark_Formals
- and then Nkind_In (N, N_Abstract_Subprogram_Declaration,
- N_Formal_Abstract_Subprogram_Declaration,
- N_Formal_Concrete_Subprogram_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Subprogram_Body,
- N_Subprogram_Body_Stub,
- N_Subprogram_Declaration,
- N_Subprogram_Renaming_Declaration)
+ and then Nkind (N) in N_Abstract_Subprogram_Declaration
+ | N_Formal_Abstract_Subprogram_Declaration
+ | N_Formal_Concrete_Subprogram_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Subprogram_Body
+ | N_Subprogram_Body_Stub
+ | N_Subprogram_Declaration
+ | N_Subprogram_Renaming_Declaration
then
Param := First (Parameter_Specifications (Specification (N)));
while Present (Param) loop
@@ -1659,7 +1658,7 @@ package body Ghost is
-- subject to any Ghost annotation.
else
- pragma Assert (Nam_In (Mode, Name_Disable, Name_None, No_Name));
+ pragma Assert (Mode in Name_Disable | Name_None | No_Name);
return None;
end if;
end Name_To_Ghost_Mode;
@@ -1678,20 +1677,20 @@ package body Ghost is
if Is_Body (N)
or else Is_Declaration (N)
or else Nkind (N) in N_Generic_Instantiation
- or else Nkind (N) in N_Push_Pop_xxx_Label
- or else Nkind (N) in N_Raise_xxx_Error
- or else Nkind (N) in N_Representation_Clause
- or else Nkind (N) in N_Statement_Other_Than_Procedure_Call
- or else Nkind_In (N, N_Call_Marker,
- N_Freeze_Entity,
- N_Freeze_Generic_Entity,
- N_Itype_Reference,
- N_Pragma,
- N_Procedure_Call_Statement,
- N_Use_Package_Clause,
- N_Use_Type_Clause,
- N_Variable_Reference_Marker,
- N_With_Clause)
+ | N_Push_Pop_xxx_Label
+ | N_Raise_xxx_Error
+ | N_Representation_Clause
+ | N_Statement_Other_Than_Procedure_Call
+ | N_Call_Marker
+ | N_Freeze_Entity
+ | N_Freeze_Generic_Entity
+ | N_Itype_Reference
+ | N_Pragma
+ | N_Procedure_Call_Statement
+ | N_Use_Package_Clause
+ | N_Use_Type_Clause
+ | N_Variable_Reference_Marker
+ | N_With_Clause
then
-- Only ignored Ghost nodes must be recorded in the table
@@ -1815,7 +1814,7 @@ package body Ghost is
-- The Ghost mode of a [generic] freeze node depends on the Ghost mode
-- of the entity being frozen.
- elsif Nkind_In (N, N_Freeze_Entity, N_Freeze_Generic_Entity) then
+ elsif Nkind (N) in N_Freeze_Entity | N_Freeze_Generic_Entity then
Set_Ghost_Mode_From_Entity (Entity (N));
-- The Ghost mode of a pragma depends on the associated entity. The
diff --git a/gcc/ada/ghost.ads b/gcc/ada/ghost.ads
index 5e8ec07..12b52c4 100644
--- a/gcc/ada/ghost.ads
+++ b/gcc/ada/ghost.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index 7d507aa..a9f48ce 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -74,7 +74,6 @@ with Stringt;
with Stylesw; use Stylesw;
with Targparm; use Targparm;
with Tbuild;
-with Tree_Gen;
with Treepr; use Treepr;
with Ttypes;
with Types; use Types;
@@ -217,32 +216,6 @@ procedure Gnat1drv is
CodePeer_Mode := False;
end if;
- -- Set ASIS mode if -gnatt and -gnatc are set
-
- if Operating_Mode = Check_Semantics and then Tree_Output then
- ASIS_Mode := True;
-
- -- Set ASIS GNSA mode if -gnatd.H is set
-
- if Debug_Flag_Dot_HH then
- ASIS_GNSA_Mode := True;
- end if;
-
- -- Turn off inlining in ASIS mode, since ASIS cannot handle the extra
- -- information in the trees caused by inlining being active.
-
- -- More specifically, the tree seems to be malformed from the ASIS
- -- point of view if -gnatc and -gnatn appear together???
-
- Inline_Active := False;
-
- -- Turn off SCIL generation and CodePeer mode in semantics mode,
- -- since SCIL requires front-end expansion.
-
- Generate_SCIL := False;
- CodePeer_Mode := False;
- end if;
-
-- SCIL mode needs to disable front-end inlining since the generated
-- trees (in particular order and consistency between specs compiled
-- as part of a main unit or as part of a with-clause) are causing
@@ -406,7 +379,7 @@ procedure Gnat1drv is
-- Always perform semantics and generate ali files in CodePeer mode,
-- so that a gnatmake -c -k will proceed further when possible.
- Force_ALI_Tree_File := True;
+ Force_ALI_File := True;
Try_Semantics := True;
-- Make the Ada front end more liberal so that the compiler will
@@ -655,11 +628,11 @@ procedure Gnat1drv is
-- Set and check exception mechanism. This is only meaningful when
-- compiling, and in particular not meaningful for special modes used
- -- for program analysis rather than compilation: ASIS mode, CodePeer
- -- mode and GNATprove mode.
+ -- for program analysis rather than compilation: CodePeer mode and
+ -- GNATprove mode.
if Operating_Mode = Generate_Code
- and then not (ASIS_Mode or CodePeer_Mode or GNATprove_Mode)
+ and then not (CodePeer_Mode or GNATprove_Mode)
then
case Targparm.Frontend_Exceptions_On_Target is
when True =>
@@ -803,10 +776,6 @@ procedure Gnat1drv is
not Generate_C_Code
- -- No back-end inlining available in ASIS mode
-
- and then not ASIS_Mode
-
-- No back-end inlining in GNATprove mode, since it just confuses
-- the formal verification process.
@@ -1301,9 +1270,8 @@ begin
-- Generate ALI file if specially requested
- if Opt.Force_ALI_Tree_File then
+ if Opt.Force_ALI_File then
Write_ALI (Object => False);
- Tree_Gen;
end if;
Exit_Program (E_Errors);
@@ -1338,7 +1306,6 @@ begin
Treepr.Tree_Dump;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
- Tree_Gen;
Namet.Finalize;
Check_Rep_Info;
@@ -1379,8 +1346,7 @@ begin
-- We can generate code for a package declaration or a subprogram
-- declaration only if it does not required a body.
- elsif Nkind_In (Main_Unit_Kind, N_Package_Declaration,
- N_Subprogram_Declaration)
+ elsif Main_Unit_Kind in N_Package_Declaration | N_Subprogram_Declaration
and then
(not Body_Required (Main_Unit_Node)
or else Distribution_Stub_Mode = Generate_Caller_Stub_Body)
@@ -1390,8 +1356,8 @@ begin
-- We can generate code for a generic package declaration of a generic
-- subprogram declaration only if does not require a body.
- elsif Nkind_In (Main_Unit_Kind, N_Generic_Package_Declaration,
- N_Generic_Subprogram_Declaration)
+ elsif Main_Unit_Kind in
+ N_Generic_Package_Declaration | N_Generic_Subprogram_Declaration
and then not Body_Required (Main_Unit_Node)
then
Back_End_Mode := Generate_Object;
@@ -1399,8 +1365,8 @@ begin
-- Compilation units that are renamings do not require bodies, so we can
-- generate code for them.
- elsif Nkind_In (Main_Unit_Kind, N_Package_Renaming_Declaration,
- N_Subprogram_Renaming_Declaration)
+ elsif Main_Unit_Kind in N_Package_Renaming_Declaration |
+ N_Subprogram_Renaming_Declaration
then
Back_End_Mode := Generate_Object;
@@ -1491,7 +1457,7 @@ begin
-- Force generation of ALI file, for backward compatibility
- Opt.Force_ALI_Tree_File := True;
+ Opt.Force_ALI_File := True;
elsif Main_Unit_Kind = N_Subunit then
Write_Str (" (subunit)");
@@ -1513,7 +1479,7 @@ begin
-- Force generation of ALI file, for backward compatibility
- Opt.Force_ALI_Tree_File := True;
+ Opt.Force_ALI_File := True;
-- Only other case is a package spec
@@ -1529,7 +1495,6 @@ begin
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Treepr.Tree_Dump;
- Tree_Gen;
-- Generate ALI file if specially requested, or for missing subunits,
-- subunits or predefined generic. For ignored ghost code, the object
@@ -1538,7 +1503,7 @@ begin
-- an object file without an ALI file.
if Is_Ignored_Ghost_Unit (Main_Unit_Node)
- or else Opt.Force_ALI_Tree_File
+ or else Opt.Force_ALI_File
then
Write_ALI (Object => Is_Ignored_Ghost_Unit (Main_Unit_Node));
end if;
@@ -1553,8 +1518,8 @@ begin
Exit_Program (Ecode);
end if;
- -- In -gnatc mode we only do annotation if -gnatt or -gnatR is also set,
- -- or if -gnatwz is enabled (default setting) and there is an unchecked
+ -- In -gnatc mode we only do annotation if -gnatR is also set, or if
+ -- -gnatwz is enabled (default setting) and there is an unchecked
-- conversion that involves a type whose size is not statically known,
-- as indicated by Back_Annotate_Rep_Info being set to True.
@@ -1564,25 +1529,19 @@ begin
-- Annotation is suppressed for targets where front-end layout is
-- enabled, because the front end determines representations.
- -- The back end is not invoked in ASIS mode with GNSA because all type
- -- representation information will be provided by the GNSA back end, not
- -- gigi.
-
-- A special back end is always called in CodePeer and GNATprove modes,
-- unless this is a subunit.
if Back_End_Mode = Declarations_Only
and then
(not (Back_Annotate_Rep_Info or Generate_SCIL or GNATprove_Mode)
- or else Main_Unit_Kind = N_Subunit
- or else ASIS_GNSA_Mode)
+ or else Main_Unit_Kind = N_Subunit)
then
Post_Compilation_Validation_Checks;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Write_ALI (Object => False);
Tree_Dump;
- Tree_Gen;
Namet.Finalize;
if not (Generate_SCIL or GNATprove_Mode) then
@@ -1701,13 +1660,12 @@ begin
Back_End.Gen_Or_Update_Object_File;
end if;
- -- Generate ASIS tree after writing the ALI file, since in ASIS mode,
- -- Write_ALI may in fact result in further tree decoration from the
- -- original tree file. Note that we dump the tree just before generating
- -- it, so that the dump will exactly reflect what is written out.
+ -- Generate tree after writing the ALI file, since Write_ALI may in
+ -- fact result in further tree decoration from the original tree file.
+ -- Note that we dump the tree just before generating it, so that the
+ -- dump will exactly reflect what is written out.
Treepr.Tree_Dump;
- Tree_Gen;
-- Finalize name table and we are all done
diff --git a/gcc/ada/gnat1drv.ads b/gcc/ada/gnat1drv.ads
index bc78698..baefe8a 100644
--- a/gcc/ada/gnat1drv.ads
+++ b/gcc/ada/gnat1drv.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index bd9c86e..882f9e2 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -21,7 +21,7 @@
@copying
@quotation
-GNAT Reference Manual , Dec 10, 2019
+GNAT Reference Manual , Jul 01, 2020
AdaCore
@@ -97,10 +97,6 @@ Implementation Defined Pragmas
* Pragma Abort_Defer::
* Pragma Abstract_State::
-* Pragma Acc_Parallel::
-* Pragma Acc_Loop::
-* Pragma Acc_Kernels::
-* Pragma Acc_Data::
* Pragma Ada_83::
* Pragma Ada_95::
* Pragma Ada_05::
@@ -346,6 +342,7 @@ Implementation Defined Aspects
* Aspect Refined_Global::
* Aspect Refined_Post::
* Aspect Refined_State::
+* Aspect Relaxed_Initialization::
* Aspect Remote_Access_Type::
* Aspect Secondary_Stack_Size::
* Aspect Scalar_Storage_Order::
@@ -399,6 +396,7 @@ Implementation Defined Attributes
* Attribute Has_Access_Values::
* Attribute Has_Discriminants::
* Attribute Img::
+* Attribute Initialized::
* Attribute Integer_Value::
* Attribute Invalid_Value::
* Attribute Iterable::
@@ -1174,10 +1172,6 @@ consideration, the use of these pragmas should be minimized.
@menu
* Pragma Abort_Defer::
* Pragma Abstract_State::
-* Pragma Acc_Parallel::
-* Pragma Acc_Loop::
-* Pragma Acc_Kernels::
-* Pragma Acc_Data::
* Pragma Ada_83::
* Pragma Ada_95::
* Pragma Ada_05::
@@ -1402,7 +1396,7 @@ the effect of deferring aborts for the sequence of statements (but not
for the declarations or handlers, if any, associated with this statement
sequence).
-@node Pragma Abstract_State,Pragma Acc_Parallel,Pragma Abort_Defer,Implementation Defined Pragmas
+@node Pragma Abstract_State,Pragma Ada_83,Pragma Abort_Defer,Implementation Defined Pragmas
@anchor{gnat_rm/implementation_defined_pragmas pragma-abstract-state}@anchor{1c}@anchor{gnat_rm/implementation_defined_pragmas id2}@anchor{1d}
@section Pragma Abstract_State
@@ -1452,171 +1446,8 @@ ABSTRACT_STATE ::= name
For the semantics of this pragma, see the entry for aspect @code{Abstract_State} in
the SPARK 2014 Reference Manual, section 7.1.4.
-@node Pragma Acc_Parallel,Pragma Acc_Loop,Pragma Abstract_State,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-acc-parallel}@anchor{1e}
-@section Pragma Acc_Parallel
-
-
-Syntax:
-
-@example
-pragma Acc_Parallel [( ACC_PARALLEL_CLAUSE [, ACC_PARALLEL_CLAUSE... ])];
-
-ACC_PARALLEL_CLAUSE ::=
- Acc_If => boolean_EXPRESSION
- | Acc_Private => IDENTIFIERS
- | Async => integer_EXPRESSION
- | Copy => IDENTIFIERS
- | Copy_In => IDENTIFIERS
- | Copy_Out => IDENTIFIERS
- | Create => IDENTIFIERS
- | Default => None
- | Device_Ptr => IDENTIFIERS
- | First_Private => IDENTIFIERS
- | Num_Gangs => integer_EXPRESSION
- | Num_Workers => integer_EXPRESSION
- | Present => IDENTIFIERS
- | Reduction => (REDUCTION_RECORD)
- | Vector_Length => integer_EXPRESSION
- | Wait => INTEGERS
-
-REDUCTION_RECORD ::=
- "+" => IDENTIFIERS
- | "*" => IDENTIFIERS
- | "min" => IDENTIFIERS
- | "max" => IDENTIFIERS
- | "or" => IDENTIFIERS
- | "and" => IDENTIFIERS
-
-IDENTIFIERS ::=
- | IDENTIFIER
- | (IDENTIFIER, IDENTIFIERS)
-
-INTEGERS ::=
- | integer_EXPRESSION
- | (integer_EXPRESSION, INTEGERS)
-@end example
-
-Requires the @code{-fopenacc} flag.
-
-Equivalent to the @code{parallel} directive of the OpenAcc standard. This pragma
-should be placed in loops. It offloads the content of the loop to an
-accelerator device.
-
-For more information about the effect of the clauses, see the OpenAcc
-specification.
-
-@node Pragma Acc_Loop,Pragma Acc_Kernels,Pragma Acc_Parallel,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-acc-loop}@anchor{1f}
-@section Pragma Acc_Loop
-
-
-Syntax:
-
-@example
-pragma Acc_Loop [( ACC_LOOP_CLAUSE [, ACC_LOOP_CLAUSE... ])];
-
-ACC_LOOP_CLAUSE ::=
- Auto
- | Collapse => INTEGER_LITERAL
- | Gang [=> GANG_ARG]
- | Independent
- | Private => IDENTIFIERS
- | Reduction => (REDUCTION_RECORD)
- | Seq
- | Tile => SIZE_EXPRESSION
- | Vector [=> integer_EXPRESSION]
- | Worker [=> integer_EXPRESSION]
-
-GANG_ARG ::=
- integer_EXPRESSION
- | Static => SIZE_EXPRESSION
-
-SIZE_EXPRESSION ::=
- *
- | integer_EXPRESSION
-@end example
-
-Requires the @code{-fopenacc} flag.
-
-Equivalent to the @code{loop} directive of the OpenAcc standard. This pragma
-should be placed in for loops after the "Acc_Parallel" pragma. It tells the
-compiler how to parallelize the loop.
-
-For more information about the effect of the clauses, see the OpenAcc
-specification.
-
-@node Pragma Acc_Kernels,Pragma Acc_Data,Pragma Acc_Loop,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-acc-kernels}@anchor{20}
-@section Pragma Acc_Kernels
-
-
-Syntax:
-
-@example
-pragma Acc_Kernels [( ACC_KERNELS_CLAUSE [, ACC_KERNELS_CLAUSE...])];
-
-ACC_KERNELS_CLAUSE ::=
- Acc_If => boolean_EXPRESSION
- | Async => integer_EXPRESSION
- | Copy => IDENTIFIERS
- | Copy_In => IDENTIFIERS
- | Copy_Out => IDENTIFIERS
- | Create => IDENTIFIERS
- | Default => None
- | Device_Ptr => IDENTIFIERS
- | Num_Gangs => integer_EXPRESSION
- | Num_Workers => integer_EXPRESSION
- | Present => IDENTIFIERS
- | Vector_Length => integer_EXPRESSION
- | Wait => INTEGERS
-
-IDENTIFIERS ::=
- | IDENTIFIER
- | (IDENTIFIER, IDENTIFIERS)
-
-INTEGERS ::=
- | integer_EXPRESSION
- | (integer_EXPRESSION, INTEGERS)
-@end example
-
-Requires the @code{-fopenacc} flag.
-
-Equivalent to the kernels directive of the OpenAcc standard. This pragma should
-be placed in loops.
-
-For more information about the effect of the clauses, see the OpenAcc
-specification.
-
-@node Pragma Acc_Data,Pragma Ada_83,Pragma Acc_Kernels,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-acc-data}@anchor{21}
-@section Pragma Acc_Data
-
-
-Syntax:
-
-@example
-pragma Acc_Data ([ ACC_DATA_CLAUSE [, ACC_DATA_CLAUSE...]]);
-
-ACC_DATA_CLAUSE ::=
- Copy => IDENTIFIERS
- | Copy_In => IDENTIFIERS
- | Copy_Out => IDENTIFIERS
- | Create => IDENTIFIERS
- | Device_Ptr => IDENTIFIERS
- | Present => IDENTIFIERS
-@end example
-
-Requires the @code{-fopenacc} flag.
-
-Equivalent to the @code{data} directive of the OpenAcc standard. This pragma
-should be placed in loops.
-
-For more information about the effect of the clauses, see the OpenAcc
-specification.
-
-@node Pragma Ada_83,Pragma Ada_95,Pragma Acc_Data,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-83}@anchor{22}
+@node Pragma Ada_83,Pragma Ada_95,Pragma Abstract_State,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-83}@anchor{1e}
@section Pragma Ada_83
@@ -1645,7 +1476,7 @@ by GNAT in Ada 83 mode will in fact compile and execute with an Ada
required by Ada 83.
@node Pragma Ada_95,Pragma Ada_05,Pragma Ada_83,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-95}@anchor{23}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-95}@anchor{1f}
@section Pragma Ada_95
@@ -1664,7 +1495,7 @@ itself uses Ada 95 features, but which is intended to be usable from
either Ada 83 or Ada 95 programs.
@node Pragma Ada_05,Pragma Ada_2005,Pragma Ada_95,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-05}@anchor{24}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-05}@anchor{20}
@section Pragma Ada_05
@@ -1693,7 +1524,7 @@ otherwise legal pre-Ada_2005 programs. The one argument form is
intended for exclusive use in the GNAT run-time library.
@node Pragma Ada_2005,Pragma Ada_12,Pragma Ada_05,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-2005}@anchor{25}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-2005}@anchor{21}
@section Pragma Ada_2005
@@ -1707,7 +1538,7 @@ This configuration pragma is a synonym for pragma Ada_05 and has the
same syntax and effect.
@node Pragma Ada_12,Pragma Ada_2012,Pragma Ada_2005,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-12}@anchor{26}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-12}@anchor{22}
@section Pragma Ada_12
@@ -1738,7 +1569,7 @@ otherwise legal pre-Ada_2012 programs. The one argument form is
intended for exclusive use in the GNAT run-time library.
@node Pragma Ada_2012,Pragma Aggregate_Individually_Assign,Pragma Ada_12,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-2012}@anchor{27}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-2012}@anchor{23}
@section Pragma Ada_2012
@@ -1752,7 +1583,7 @@ This configuration pragma is a synonym for pragma Ada_12 and has the
same syntax and effect.
@node Pragma Aggregate_Individually_Assign,Pragma Allow_Integer_Address,Pragma Ada_2012,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-aggregate-individually-assign}@anchor{28}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-aggregate-individually-assign}@anchor{24}
@section Pragma Aggregate_Individually_Assign
@@ -1768,7 +1599,7 @@ this behavior so that record aggregates are instead always converted into
individual assignment statements.
@node Pragma Allow_Integer_Address,Pragma Annotate,Pragma Aggregate_Individually_Assign,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-allow-integer-address}@anchor{29}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-allow-integer-address}@anchor{25}
@section Pragma Allow_Integer_Address
@@ -1818,7 +1649,7 @@ rather than rejected to allow common sets of sources to be used
in the two situations.
@node Pragma Annotate,Pragma Assert,Pragma Allow_Integer_Address,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-annotate}@anchor{2a}@anchor{gnat_rm/implementation_defined_pragmas id3}@anchor{2b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-annotate}@anchor{26}@anchor{gnat_rm/implementation_defined_pragmas id3}@anchor{27}
@section Pragma Annotate
@@ -1853,7 +1684,7 @@ affect the compilation process in any way. This pragma may be used as
a configuration pragma.
@node Pragma Assert,Pragma Assert_And_Cut,Pragma Annotate,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-assert}@anchor{2c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-assert}@anchor{28}
@section Pragma Assert
@@ -1919,7 +1750,7 @@ of Ada, and the DISABLE policy is an implementation-defined
addition.
@node Pragma Assert_And_Cut,Pragma Assertion_Policy,Pragma Assert,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-assert-and-cut}@anchor{2d}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-assert-and-cut}@anchor{29}
@section Pragma Assert_And_Cut
@@ -1946,7 +1777,7 @@ formal verification. The pragma also serves as useful
documentation.
@node Pragma Assertion_Policy,Pragma Assume,Pragma Assert_And_Cut,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-assertion-policy}@anchor{2e}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-assertion-policy}@anchor{2a}
@section Pragma Assertion_Policy
@@ -2030,7 +1861,7 @@ applies to @code{Assert}, @code{Assert_And_Cut},
@code{Assume}, @code{Loop_Invariant}, and @code{Loop_Variant}.
@node Pragma Assume,Pragma Assume_No_Invalid_Values,Pragma Assertion_Policy,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-assume}@anchor{2f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-assume}@anchor{2b}
@section Pragma Assume
@@ -2064,7 +1895,7 @@ is met, and documents the need to ensure that it is met by
reference to information outside the program.
@node Pragma Assume_No_Invalid_Values,Pragma Async_Readers,Pragma Assume,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-assume-no-invalid-values}@anchor{30}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-assume-no-invalid-values}@anchor{2c}
@section Pragma Assume_No_Invalid_Values
@@ -2117,7 +1948,7 @@ is erroneous so there are no guarantees that this will always be the
case, and it is recommended that these two options not be used together.
@node Pragma Async_Readers,Pragma Async_Writers,Pragma Assume_No_Invalid_Values,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-async-readers}@anchor{31}@anchor{gnat_rm/implementation_defined_pragmas id4}@anchor{32}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-async-readers}@anchor{2d}@anchor{gnat_rm/implementation_defined_pragmas id4}@anchor{2e}
@section Pragma Async_Readers
@@ -2131,7 +1962,7 @@ For the semantics of this pragma, see the entry for aspect @code{Async_Readers}
the SPARK 2014 Reference Manual, section 7.1.2.
@node Pragma Async_Writers,Pragma Attribute_Definition,Pragma Async_Readers,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id5}@anchor{33}@anchor{gnat_rm/implementation_defined_pragmas pragma-async-writers}@anchor{34}
+@anchor{gnat_rm/implementation_defined_pragmas id5}@anchor{2f}@anchor{gnat_rm/implementation_defined_pragmas pragma-async-writers}@anchor{30}
@section Pragma Async_Writers
@@ -2145,7 +1976,7 @@ For the semantics of this pragma, see the entry for aspect @code{Async_Writers}
the SPARK 2014 Reference Manual, section 7.1.2.
@node Pragma Attribute_Definition,Pragma C_Pass_By_Copy,Pragma Async_Writers,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-attribute-definition}@anchor{35}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-attribute-definition}@anchor{31}
@section Pragma Attribute_Definition
@@ -2171,7 +2002,7 @@ code to be written that takes advantage of some new attribute, while remaining
compilable with earlier compilers.
@node Pragma C_Pass_By_Copy,Pragma Check,Pragma Attribute_Definition,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-c-pass-by-copy}@anchor{36}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-c-pass-by-copy}@anchor{32}
@section Pragma C_Pass_By_Copy
@@ -2215,7 +2046,7 @@ You can also pass records by copy by specifying the convention
passing mechanisms on a parameter by parameter basis.
@node Pragma Check,Pragma Check_Float_Overflow,Pragma C_Pass_By_Copy,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-check}@anchor{37}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-check}@anchor{33}
@section Pragma Check
@@ -2254,7 +2085,7 @@ of these identifiers in @code{Assertion_Policy} and @code{Check_Policy}
pragmas, where they are used to refer to sets of assertions.
@node Pragma Check_Float_Overflow,Pragma Check_Name,Pragma Check,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-check-float-overflow}@anchor{38}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-check-float-overflow}@anchor{34}
@section Pragma Check_Float_Overflow
@@ -2310,7 +2141,7 @@ This mode can also be set by use of the compiler
switch @emph{-gnateF}.
@node Pragma Check_Name,Pragma Check_Policy,Pragma Check_Float_Overflow,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-check-name}@anchor{39}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-check-name}@anchor{35}
@section Pragma Check_Name
@@ -2346,7 +2177,7 @@ Check names introduced by this pragma are subject to control by compiler
switches (in particular -gnatp) in the usual manner.
@node Pragma Check_Policy,Pragma Comment,Pragma Check_Name,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-check-policy}@anchor{3a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-check-policy}@anchor{36}
@section Pragma Check_Policy
@@ -2426,7 +2257,7 @@ policy setting @code{DISABLE} causes the second argument of a corresponding
@code{Check} pragma to be completely ignored and not analyzed.
@node Pragma Comment,Pragma Common_Object,Pragma Check_Policy,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-comment}@anchor{3b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-comment}@anchor{37}
@section Pragma Comment
@@ -2445,7 +2276,7 @@ anywhere in the main source unit), and if more than one pragma
is used, all comments are retained.
@node Pragma Common_Object,Pragma Compile_Time_Error,Pragma Comment,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-common-object}@anchor{3c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-common-object}@anchor{38}
@section Pragma Common_Object
@@ -2477,7 +2308,7 @@ indicating that the necessary attribute for implementation of this
pragma is not available.
@node Pragma Compile_Time_Error,Pragma Compile_Time_Warning,Pragma Common_Object,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-error}@anchor{3d}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-error}@anchor{39}@anchor{gnat_rm/implementation_defined_pragmas compile-time-error}@anchor{3a}
@section Pragma Compile_Time_Error
@@ -2492,19 +2323,19 @@ This pragma can be used to generate additional compile time
error messages. It
is particularly useful in generics, where errors can be issued for
specific problematic instantiations. The first parameter is a boolean
-expression. The pragma is effective only if the value of this expression
-is known at compile time, and has the value True. The set of expressions
+expression. The pragma ensures that the value of an expression
+is known at compile time, and has the value False. The set of expressions
whose values are known at compile time includes all static boolean
expressions, and also other values which the compiler can determine
at compile time (e.g., the size of a record type set by an explicit
size representation clause, or the value of a variable which was
initialized to a constant and is known not to have been modified).
-If these conditions are met, an error message is generated using
+If these conditions are not met, an error message is generated using
the value given as the second argument. This string value may contain
embedded ASCII.LF characters to break the message into multiple lines.
@node Pragma Compile_Time_Warning,Pragma Compiler_Unit,Pragma Compile_Time_Error,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-warning}@anchor{3e}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-warning}@anchor{3b}
@section Pragma Compile_Time_Warning
@@ -2516,7 +2347,10 @@ pragma Compile_Time_Warning
@end example
Same as pragma Compile_Time_Error, except a warning is issued instead
-of an error message. Note that if this pragma is used in a package that
+of an error message. If switch @emph{-gnatw_C} is used, a warning is only issued
+if the value of the expression is known to be True at compile time, not when
+the value of the expression is not known at compile time.
+Note that if this pragma is used in a package that
is with'ed by a client, the client will get the warning even though it
is issued by a with'ed package (normally warnings in with'ed units are
suppressed, but this is a special exception to that rule).
@@ -2526,8 +2360,13 @@ of formal parameters are tested, and warnings given appropriately. Another use
with a first parameter of True is to warn a client about use of a package,
for example that it is not fully implemented.
+In previous versions of the compiler, combining @emph{-gnatwe} with
+Compile_Time_Warning resulted in a fatal error. Now the compiler always emits
+a warning. You can use @ref{3a,,Pragma Compile_Time_Error} to force the generation of
+an error.
+
@node Pragma Compiler_Unit,Pragma Compiler_Unit_Warning,Pragma Compile_Time_Warning,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-compiler-unit}@anchor{3f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-compiler-unit}@anchor{3c}
@section Pragma Compiler_Unit
@@ -2542,7 +2381,7 @@ retained so that old versions of the GNAT run-time that use this pragma can
be compiled with newer versions of the compiler.
@node Pragma Compiler_Unit_Warning,Pragma Complete_Representation,Pragma Compiler_Unit,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-compiler-unit-warning}@anchor{40}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-compiler-unit-warning}@anchor{3d}
@section Pragma Compiler_Unit_Warning
@@ -2560,7 +2399,7 @@ version of GNAT. For the exact list of restrictions, see the compiler sources
and references to Check_Compiler_Unit.
@node Pragma Complete_Representation,Pragma Complex_Representation,Pragma Compiler_Unit_Warning,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-complete-representation}@anchor{41}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-complete-representation}@anchor{3e}
@section Pragma Complete_Representation
@@ -2579,7 +2418,7 @@ complete, and that this invariant is maintained if fields are
added to the record in the future.
@node Pragma Complex_Representation,Pragma Component_Alignment,Pragma Complete_Representation,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-complex-representation}@anchor{42}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-complex-representation}@anchor{3f}
@section Pragma Complex_Representation
@@ -2601,7 +2440,7 @@ records by pointer, and the use of this pragma may result in passing
this type in floating-point registers.
@node Pragma Component_Alignment,Pragma Constant_After_Elaboration,Pragma Complex_Representation,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-component-alignment}@anchor{43}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-component-alignment}@anchor{40}
@section Pragma Component_Alignment
@@ -2692,7 +2531,7 @@ pragma @code{Pack}, pragma @code{Component_Alignment}, or a record rep
clause), the GNAT uses the default alignment as described previously.
@node Pragma Constant_After_Elaboration,Pragma Contract_Cases,Pragma Component_Alignment,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id6}@anchor{44}@anchor{gnat_rm/implementation_defined_pragmas pragma-constant-after-elaboration}@anchor{45}
+@anchor{gnat_rm/implementation_defined_pragmas id6}@anchor{41}@anchor{gnat_rm/implementation_defined_pragmas pragma-constant-after-elaboration}@anchor{42}
@section Pragma Constant_After_Elaboration
@@ -2706,7 +2545,7 @@ For the semantics of this pragma, see the entry for aspect
@code{Constant_After_Elaboration} in the SPARK 2014 Reference Manual, section 3.3.1.
@node Pragma Contract_Cases,Pragma Convention_Identifier,Pragma Constant_After_Elaboration,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id7}@anchor{46}@anchor{gnat_rm/implementation_defined_pragmas pragma-contract-cases}@anchor{47}
+@anchor{gnat_rm/implementation_defined_pragmas id7}@anchor{43}@anchor{gnat_rm/implementation_defined_pragmas pragma-contract-cases}@anchor{44}
@section Pragma Contract_Cases
@@ -2791,7 +2630,7 @@ and that the consequence for this case should hold when the subprogram
returns.
@node Pragma Convention_Identifier,Pragma CPP_Class,Pragma Contract_Cases,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-convention-identifier}@anchor{48}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-convention-identifier}@anchor{45}
@section Pragma Convention_Identifier
@@ -2827,7 +2666,7 @@ define a convention identifier @code{Library} and use a single
would be used system-wide.
@node Pragma CPP_Class,Pragma CPP_Constructor,Pragma Convention_Identifier,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-class}@anchor{49}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-class}@anchor{46}
@section Pragma CPP_Class
@@ -2852,14 +2691,14 @@ functions (see pragma @code{CPP_Constructor}). Such types are implicitly
limited if not explicitly declared as limited or derived from a limited
type, and an error is issued in that case.
-See @ref{4a,,Interfacing to C++} for related information.
+See @ref{47,,Interfacing to C++} for related information.
Note: Pragma @code{CPP_Class} is currently obsolete. It is supported
for backward compatibility but its functionality is available
using pragma @code{Import} with @code{Convention} = @code{CPP}.
@node Pragma CPP_Constructor,Pragma CPP_Virtual,Pragma CPP_Class,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-constructor}@anchor{4b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-constructor}@anchor{48}
@section Pragma CPP_Constructor
@@ -2910,7 +2749,7 @@ on the Ada side and the type is implicitly declared abstract.
Pragma @code{CPP_Constructor} is intended primarily for automatic generation
using an automatic binding generator tool (such as the @code{-fdump-ada-spec}
GCC switch).
-See @ref{4a,,Interfacing to C++} for more related information.
+See @ref{47,,Interfacing to C++} for more related information.
Note: The use of functions returning class-wide types for constructors is
currently obsolete. They are supported for backward compatibility. The
@@ -2919,7 +2758,7 @@ because the imported C++ constructors always return an object of type T;
that is, they never return an object whose type is a descendant of type T.
@node Pragma CPP_Virtual,Pragma CPP_Vtable,Pragma CPP_Constructor,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-virtual}@anchor{4c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-virtual}@anchor{49}
@section Pragma CPP_Virtual
@@ -2932,10 +2771,10 @@ purposes. It used to be required to ensure compoatibility with C++, but
is no longer required for that purpose because GNAT generates
the same object layout as the G++ compiler by default.
-See @ref{4a,,Interfacing to C++} for related information.
+See @ref{47,,Interfacing to C++} for related information.
@node Pragma CPP_Vtable,Pragma CPU,Pragma CPP_Virtual,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-vtable}@anchor{4d}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-vtable}@anchor{4a}
@section Pragma CPP_Vtable
@@ -2947,10 +2786,10 @@ It used to be required to ensure compatibility with C++, but
is no longer required for that purpose because GNAT generates
the same object layout as the G++ compiler by default.
-See @ref{4a,,Interfacing to C++} for related information.
+See @ref{47,,Interfacing to C++} for related information.
@node Pragma CPU,Pragma Deadline_Floor,Pragma CPP_Vtable,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-cpu}@anchor{4e}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-cpu}@anchor{4b}
@section Pragma CPU
@@ -2965,7 +2804,7 @@ versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
@node Pragma Deadline_Floor,Pragma Default_Initial_Condition,Pragma CPU,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-deadline-floor}@anchor{4f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-deadline-floor}@anchor{4c}
@section Pragma Deadline_Floor
@@ -2980,7 +2819,7 @@ deadline inherited by a task when the task enters a protected object.
It is effective only when the EDF scheduling policy is used.
@node Pragma Default_Initial_Condition,Pragma Debug,Pragma Deadline_Floor,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id8}@anchor{50}@anchor{gnat_rm/implementation_defined_pragmas pragma-default-initial-condition}@anchor{51}
+@anchor{gnat_rm/implementation_defined_pragmas id8}@anchor{4d}@anchor{gnat_rm/implementation_defined_pragmas pragma-default-initial-condition}@anchor{4e}
@section Pragma Default_Initial_Condition
@@ -2994,7 +2833,7 @@ For the semantics of this pragma, see the entry for aspect
@code{Default_Initial_Condition} in the SPARK 2014 Reference Manual, section 7.3.3.
@node Pragma Debug,Pragma Debug_Policy,Pragma Default_Initial_Condition,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-debug}@anchor{52}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-debug}@anchor{4f}
@section Pragma Debug
@@ -3022,7 +2861,7 @@ or by use of the pragma @code{Check_Policy} with a first argument of
@code{Debug}.
@node Pragma Debug_Policy,Pragma Default_Scalar_Storage_Order,Pragma Debug,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-debug-policy}@anchor{53}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-debug-policy}@anchor{50}
@section Pragma Debug_Policy
@@ -3037,7 +2876,7 @@ with a first argument of @code{Debug}. It is retained for historical
compatibility reasons.
@node Pragma Default_Scalar_Storage_Order,Pragma Default_Storage_Pool,Pragma Debug_Policy,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-default-scalar-storage-order}@anchor{54}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-default-scalar-storage-order}@anchor{51}
@section Pragma Default_Scalar_Storage_Order
@@ -3110,7 +2949,7 @@ it may significantly degrade the run-time performance of the software, instead
the default scalar storage order ought to be changed only on a local basis.
@node Pragma Default_Storage_Pool,Pragma Depends,Pragma Default_Scalar_Storage_Order,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-default-storage-pool}@anchor{55}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-default-storage-pool}@anchor{52}
@section Pragma Default_Storage_Pool
@@ -3127,7 +2966,7 @@ versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
@node Pragma Depends,Pragma Detect_Blocking,Pragma Default_Storage_Pool,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-depends}@anchor{56}@anchor{gnat_rm/implementation_defined_pragmas id9}@anchor{57}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-depends}@anchor{53}@anchor{gnat_rm/implementation_defined_pragmas id9}@anchor{54}
@section Pragma Depends
@@ -3160,7 +2999,7 @@ For the semantics of this pragma, see the entry for aspect @code{Depends} in the
SPARK 2014 Reference Manual, section 6.1.5.
@node Pragma Detect_Blocking,Pragma Disable_Atomic_Synchronization,Pragma Depends,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-detect-blocking}@anchor{58}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-detect-blocking}@anchor{55}
@section Pragma Detect_Blocking
@@ -3178,7 +3017,7 @@ blocking operations within a protected operation, and to raise Program_Error
if that happens.
@node Pragma Disable_Atomic_Synchronization,Pragma Dispatching_Domain,Pragma Detect_Blocking,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-disable-atomic-synchronization}@anchor{59}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-disable-atomic-synchronization}@anchor{56}
@section Pragma Disable_Atomic_Synchronization
@@ -3204,7 +3043,7 @@ till the end of the scope. If an @code{Entity} argument is present,
the action applies only to that entity.
@node Pragma Dispatching_Domain,Pragma Effective_Reads,Pragma Disable_Atomic_Synchronization,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-dispatching-domain}@anchor{5a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-dispatching-domain}@anchor{57}
@section Pragma Dispatching_Domain
@@ -3219,7 +3058,7 @@ versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
@node Pragma Effective_Reads,Pragma Effective_Writes,Pragma Dispatching_Domain,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id10}@anchor{5b}@anchor{gnat_rm/implementation_defined_pragmas pragma-effective-reads}@anchor{5c}
+@anchor{gnat_rm/implementation_defined_pragmas id10}@anchor{58}@anchor{gnat_rm/implementation_defined_pragmas pragma-effective-reads}@anchor{59}
@section Pragma Effective_Reads
@@ -3233,7 +3072,7 @@ For the semantics of this pragma, see the entry for aspect @code{Effective_Reads
the SPARK 2014 Reference Manual, section 7.1.2.
@node Pragma Effective_Writes,Pragma Elaboration_Checks,Pragma Effective_Reads,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id11}@anchor{5d}@anchor{gnat_rm/implementation_defined_pragmas pragma-effective-writes}@anchor{5e}
+@anchor{gnat_rm/implementation_defined_pragmas id11}@anchor{5a}@anchor{gnat_rm/implementation_defined_pragmas pragma-effective-writes}@anchor{5b}
@section Pragma Effective_Writes
@@ -3247,7 +3086,7 @@ For the semantics of this pragma, see the entry for aspect @code{Effective_Write
in the SPARK 2014 Reference Manual, section 7.1.2.
@node Pragma Elaboration_Checks,Pragma Eliminate,Pragma Effective_Writes,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-elaboration-checks}@anchor{5f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-elaboration-checks}@anchor{5c}
@section Pragma Elaboration_Checks
@@ -3284,7 +3123,7 @@ effect. If the pragma argument is @code{Static}, then the static elaboration mod
is in effect.
@node Pragma Eliminate,Pragma Enable_Atomic_Synchronization,Pragma Elaboration_Checks,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-eliminate}@anchor{60}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-eliminate}@anchor{5d}
@section Pragma Eliminate
@@ -3444,7 +3283,7 @@ pragma Eliminate (Q, Proc,
@end quotation
@node Pragma Enable_Atomic_Synchronization,Pragma Export_Function,Pragma Eliminate,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-enable-atomic-synchronization}@anchor{61}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-enable-atomic-synchronization}@anchor{5e}
@section Pragma Enable_Atomic_Synchronization
@@ -3472,7 +3311,7 @@ till the end of the scope. If an @code{Entity} argument is present,
the action applies only to that entity.
@node Pragma Export_Function,Pragma Export_Object,Pragma Enable_Atomic_Synchronization,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-export-function}@anchor{62}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-export-function}@anchor{5f}
@section Pragma Export_Function
@@ -3544,7 +3383,7 @@ string. In this case, no external name is generated. This form
still allows the specification of parameter mechanisms.
@node Pragma Export_Object,Pragma Export_Procedure,Pragma Export_Function,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-export-object}@anchor{63}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-export-object}@anchor{60}
@section Pragma Export_Object
@@ -3569,7 +3408,7 @@ of portability), but it is not required. @code{Size} is syntax checked,
but otherwise ignored by GNAT.
@node Pragma Export_Procedure,Pragma Export_Value,Pragma Export_Object,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-export-procedure}@anchor{64}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-export-procedure}@anchor{61}
@section Pragma Export_Procedure
@@ -3622,7 +3461,7 @@ string. In this case, no external name is generated. This form
still allows the specification of parameter mechanisms.
@node Pragma Export_Value,Pragma Export_Valued_Procedure,Pragma Export_Procedure,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-export-value}@anchor{65}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-export-value}@anchor{62}
@section Pragma Export_Value
@@ -3643,7 +3482,7 @@ the application. This pragma is currently supported only for the
AAMP target and is ignored for other targets.
@node Pragma Export_Valued_Procedure,Pragma Extend_System,Pragma Export_Value,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-export-valued-procedure}@anchor{66}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-export-valued-procedure}@anchor{63}
@section Pragma Export_Valued_Procedure
@@ -3701,7 +3540,7 @@ string. In this case, no external name is generated. This form
still allows the specification of parameter mechanisms.
@node Pragma Extend_System,Pragma Extensions_Allowed,Pragma Export_Valued_Procedure,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-extend-system}@anchor{67}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-extend-system}@anchor{64}
@section Pragma Extend_System
@@ -3752,7 +3591,7 @@ for compiling System units, as explained in the
GNAT User's Guide.
@node Pragma Extensions_Allowed,Pragma Extensions_Visible,Pragma Extend_System,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-allowed}@anchor{68}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-allowed}@anchor{65}
@section Pragma Extensions_Allowed
@@ -3771,21 +3610,41 @@ extension mode (the use of Off as a parameter cancels the effect
of the @emph{-gnatX} command switch).
In extension mode, the latest version of the Ada language is
-implemented (currently Ada 2012), and in addition a small number
+implemented (currently Ada 202x), and in addition a small number
of GNAT specific extensions are recognized as follows:
-@table @asis
+@itemize *
-@item @emph{Constrained attribute for generic objects}
+@item
+Constrained attribute for generic objects
The @code{Constrained} attribute is permitted for objects of
generic types. The result indicates if the corresponding actual
is constrained.
-@end table
+
+@item
+@code{Static} aspect on intrinsic functions
+
+The Ada 202x @code{Static} aspect can be specified on Intrinsic imported
+functions and the compiler will evaluate some of these intrinsic statically,
+in particular the @code{Shift_Left} and @code{Shift_Right} intrinsics.
+
+@item
+@code{'Reduce} attribute
+
+This attribute part of the Ada 202x language definition is provided for
+now under -gnatX to confirm and potentially refine its usage and syntax.
+
+@item
+@code{[]} aggregates
+
+This new aggregate syntax for arrays and containers is provided under -gnatX
+to experiment and confirm this new language syntax.
+@end itemize
@node Pragma Extensions_Visible,Pragma External,Pragma Extensions_Allowed,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id12}@anchor{69}@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-visible}@anchor{6a}
+@anchor{gnat_rm/implementation_defined_pragmas id12}@anchor{66}@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-visible}@anchor{67}
@section Pragma Extensions_Visible
@@ -3799,7 +3658,7 @@ For the semantics of this pragma, see the entry for aspect @code{Extensions_Visi
in the SPARK 2014 Reference Manual, section 6.1.7.
@node Pragma External,Pragma External_Name_Casing,Pragma Extensions_Visible,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-external}@anchor{6b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-external}@anchor{68}
@section Pragma External
@@ -3820,7 +3679,7 @@ used this pragma for exactly the same purposes as pragma
@code{Export} before the latter was standardized.
@node Pragma External_Name_Casing,Pragma Fast_Math,Pragma External,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-external-name-casing}@anchor{6c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-external-name-casing}@anchor{69}
@section Pragma External_Name_Casing
@@ -3909,7 +3768,7 @@ pragma External_Name_Casing (Uppercase, Uppercase);
to enforce the upper casing of all external symbols.
@node Pragma Fast_Math,Pragma Favor_Top_Level,Pragma External_Name_Casing,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-fast-math}@anchor{6d}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-fast-math}@anchor{6a}
@section Pragma Fast_Math
@@ -3938,7 +3797,7 @@ under control of the pragma, rather than use the preinstantiated versions.
@end table
@node Pragma Favor_Top_Level,Pragma Finalize_Storage_Only,Pragma Fast_Math,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id13}@anchor{6e}@anchor{gnat_rm/implementation_defined_pragmas pragma-favor-top-level}@anchor{6f}
+@anchor{gnat_rm/implementation_defined_pragmas id13}@anchor{6b}@anchor{gnat_rm/implementation_defined_pragmas pragma-favor-top-level}@anchor{6c}
@section Pragma Favor_Top_Level
@@ -3957,7 +3816,7 @@ When this pragma is used, dynamically generated trampolines may be used on some
targets for nested subprograms. See restriction @code{No_Implicit_Dynamic_Code}.
@node Pragma Finalize_Storage_Only,Pragma Float_Representation,Pragma Favor_Top_Level,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-finalize-storage-only}@anchor{70}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-finalize-storage-only}@anchor{6d}
@section Pragma Finalize_Storage_Only
@@ -3977,7 +3836,7 @@ name. Note that this pragma does not suppress Finalize calls for library-level
heap-allocated objects (see pragma @code{No_Heap_Finalization}).
@node Pragma Float_Representation,Pragma Ghost,Pragma Finalize_Storage_Only,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-float-representation}@anchor{71}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-float-representation}@anchor{6e}
@section Pragma Float_Representation
@@ -4012,7 +3871,7 @@ No other value of digits is permitted.
@end itemize
@node Pragma Ghost,Pragma Global,Pragma Float_Representation,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ghost}@anchor{72}@anchor{gnat_rm/implementation_defined_pragmas id14}@anchor{73}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ghost}@anchor{6f}@anchor{gnat_rm/implementation_defined_pragmas id14}@anchor{70}
@section Pragma Ghost
@@ -4026,7 +3885,7 @@ For the semantics of this pragma, see the entry for aspect @code{Ghost} in the S
2014 Reference Manual, section 6.9.
@node Pragma Global,Pragma Ident,Pragma Ghost,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-global}@anchor{74}@anchor{gnat_rm/implementation_defined_pragmas id15}@anchor{75}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-global}@anchor{71}@anchor{gnat_rm/implementation_defined_pragmas id15}@anchor{72}
@section Pragma Global
@@ -4051,7 +3910,7 @@ For the semantics of this pragma, see the entry for aspect @code{Global} in the
SPARK 2014 Reference Manual, section 6.1.4.
@node Pragma Ident,Pragma Ignore_Pragma,Pragma Global,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ident}@anchor{76}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ident}@anchor{73}
@section Pragma Ident
@@ -4065,7 +3924,7 @@ This pragma is identical in effect to pragma @code{Comment}. It is provided
for compatibility with other Ada compilers providing this pragma.
@node Pragma Ignore_Pragma,Pragma Implementation_Defined,Pragma Ident,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ignore-pragma}@anchor{77}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ignore-pragma}@anchor{74}
@section Pragma Ignore_Pragma
@@ -4085,7 +3944,7 @@ pragma allows such pragmas to be ignored, which may be useful in CodePeer
mode, or during porting of legacy code.
@node Pragma Implementation_Defined,Pragma Implemented,Pragma Ignore_Pragma,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-implementation-defined}@anchor{78}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-implementation-defined}@anchor{75}
@section Pragma Implementation_Defined
@@ -4112,7 +3971,7 @@ for the purpose of implementing the No_Implementation_Identifiers
restriction.
@node Pragma Implemented,Pragma Implicit_Packing,Pragma Implementation_Defined,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-implemented}@anchor{79}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-implemented}@anchor{76}
@section Pragma Implemented
@@ -4158,7 +4017,7 @@ By_Any shares the behavior of By_Entry and By_Protected_Procedure depending on
the target's overriding subprogram kind.
@node Pragma Implicit_Packing,Pragma Import_Function,Pragma Implemented,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-implicit-packing}@anchor{7a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-implicit-packing}@anchor{77}
@section Pragma Implicit_Packing
@@ -4212,7 +4071,7 @@ sufficient. The use of pragma Implicit_Packing allows this record
declaration to compile without an explicit pragma Pack.
@node Pragma Import_Function,Pragma Import_Object,Pragma Implicit_Packing,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-import-function}@anchor{7b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-import-function}@anchor{78}
@section Pragma Import_Function
@@ -4277,7 +4136,7 @@ notation. If the mechanism is not specified, the default mechanism
is used.
@node Pragma Import_Object,Pragma Import_Procedure,Pragma Import_Function,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-import-object}@anchor{7c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-import-object}@anchor{79}
@section Pragma Import_Object
@@ -4303,7 +4162,7 @@ point of view). @code{size} is syntax checked, but otherwise ignored by
GNAT.
@node Pragma Import_Procedure,Pragma Import_Valued_Procedure,Pragma Import_Object,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-import-procedure}@anchor{7d}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-import-procedure}@anchor{7a}
@section Pragma Import_Procedure
@@ -4343,7 +4202,7 @@ applies to a procedure rather than a function and the parameters
@code{Result_Type} and @code{Result_Mechanism} are not permitted.
@node Pragma Import_Valued_Procedure,Pragma Independent,Pragma Import_Procedure,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-import-valued-procedure}@anchor{7e}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-import-valued-procedure}@anchor{7b}
@section Pragma Import_Valued_Procedure
@@ -4396,7 +4255,7 @@ pragma Import that specifies the desired convention, since otherwise the
default convention is Ada, which is almost certainly not what is required.
@node Pragma Independent,Pragma Independent_Components,Pragma Import_Valued_Procedure,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-independent}@anchor{7f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-independent}@anchor{7c}
@section Pragma Independent
@@ -4418,7 +4277,7 @@ constraints on the representation of the object (for instance prohibiting
tight packing).
@node Pragma Independent_Components,Pragma Initial_Condition,Pragma Independent,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-independent-components}@anchor{80}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-independent-components}@anchor{7d}
@section Pragma Independent_Components
@@ -4439,7 +4298,7 @@ constraints on the representation of the object (for instance prohibiting
tight packing).
@node Pragma Initial_Condition,Pragma Initialize_Scalars,Pragma Independent_Components,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id16}@anchor{81}@anchor{gnat_rm/implementation_defined_pragmas pragma-initial-condition}@anchor{82}
+@anchor{gnat_rm/implementation_defined_pragmas id16}@anchor{7e}@anchor{gnat_rm/implementation_defined_pragmas pragma-initial-condition}@anchor{7f}
@section Pragma Initial_Condition
@@ -4453,7 +4312,7 @@ For the semantics of this pragma, see the entry for aspect @code{Initial_Conditi
in the SPARK 2014 Reference Manual, section 7.1.6.
@node Pragma Initialize_Scalars,Pragma Initializes,Pragma Initial_Condition,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-initialize-scalars}@anchor{83}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-initialize-scalars}@anchor{80}
@section Pragma Initialize_Scalars
@@ -4562,7 +4421,7 @@ good idea to turn on stack checking (see description of stack checking in the
GNAT User's Guide) when using this pragma.
@node Pragma Initializes,Pragma Inline_Always,Pragma Initialize_Scalars,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-initializes}@anchor{84}@anchor{gnat_rm/implementation_defined_pragmas id17}@anchor{85}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-initializes}@anchor{81}@anchor{gnat_rm/implementation_defined_pragmas id17}@anchor{82}
@section Pragma Initializes
@@ -4589,7 +4448,7 @@ For the semantics of this pragma, see the entry for aspect @code{Initializes} in
SPARK 2014 Reference Manual, section 7.1.5.
@node Pragma Inline_Always,Pragma Inline_Generic,Pragma Initializes,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id18}@anchor{86}@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-always}@anchor{87}
+@anchor{gnat_rm/implementation_defined_pragmas id18}@anchor{83}@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-always}@anchor{84}
@section Pragma Inline_Always
@@ -4608,7 +4467,7 @@ apply this pragma to a primitive operation of a tagged type. Thanks to such
restrictions, the compiler is allowed to remove the out-of-line body of @code{NAME}.
@node Pragma Inline_Generic,Pragma Interface,Pragma Inline_Always,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-generic}@anchor{88}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-generic}@anchor{85}
@section Pragma Inline_Generic
@@ -4626,7 +4485,7 @@ than to check that the given names are all names of generic units or
generic instances.
@node Pragma Interface,Pragma Interface_Name,Pragma Inline_Generic,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-interface}@anchor{89}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-interface}@anchor{86}
@section Pragma Interface
@@ -4653,7 +4512,7 @@ maintaining Ada 83/Ada 95 compatibility and is compatible with other
Ada 83 compilers.
@node Pragma Interface_Name,Pragma Interrupt_Handler,Pragma Interface,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-interface-name}@anchor{8a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-interface-name}@anchor{87}
@section Pragma Interface_Name
@@ -4672,7 +4531,7 @@ for an interfaced subprogram, and is provided for compatibility with Ada
least one of @code{External_Name} or @code{Link_Name}.
@node Pragma Interrupt_Handler,Pragma Interrupt_State,Pragma Interface_Name,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-handler}@anchor{8b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-handler}@anchor{88}
@section Pragma Interrupt_Handler
@@ -4692,7 +4551,7 @@ when this pragma is applied to a nonprotected procedure, the instruction
maskable interrupts, in place of the normal return instruction.
@node Pragma Interrupt_State,Pragma Invariant,Pragma Interrupt_Handler,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-state}@anchor{8c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-state}@anchor{89}
@section Pragma Interrupt_State
@@ -4778,7 +4637,7 @@ with an application's runtime behavior in the cases of the synchronous signals,
and in the case of the signal used to implement the @code{abort} statement.
@node Pragma Invariant,Pragma Keep_Names,Pragma Interrupt_State,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id19}@anchor{8d}@anchor{gnat_rm/implementation_defined_pragmas pragma-invariant}@anchor{8e}
+@anchor{gnat_rm/implementation_defined_pragmas id19}@anchor{8a}@anchor{gnat_rm/implementation_defined_pragmas pragma-invariant}@anchor{8b}
@section Pragma Invariant
@@ -4817,7 +4676,7 @@ For further details on the use of this pragma, see the Ada 2012 documentation
of the Type_Invariant aspect.
@node Pragma Keep_Names,Pragma License,Pragma Invariant,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-keep-names}@anchor{8f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-keep-names}@anchor{8c}
@section Pragma Keep_Names
@@ -4837,7 +4696,7 @@ use a @code{Discard_Names} pragma in the @code{gnat.adc} file, but you
want to retain the names for specific enumeration types.
@node Pragma License,Pragma Link_With,Pragma Keep_Names,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-license}@anchor{90}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-license}@anchor{8d}
@section Pragma License
@@ -4932,7 +4791,7 @@ GPL, but no warning for @code{GNAT.Sockets} which is part of the GNAT
run time, and is therefore licensed under the modified GPL.
@node Pragma Link_With,Pragma Linker_Alias,Pragma License,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-link-with}@anchor{91}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-link-with}@anchor{8e}
@section Pragma Link_With
@@ -4956,7 +4815,7 @@ separate arguments to the linker. In addition pragma Link_With allows
multiple arguments, with the same effect as successive pragmas.
@node Pragma Linker_Alias,Pragma Linker_Constructor,Pragma Link_With,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-alias}@anchor{92}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-alias}@anchor{8f}
@section Pragma Linker_Alias
@@ -4997,7 +4856,7 @@ end p;
@end example
@node Pragma Linker_Constructor,Pragma Linker_Destructor,Pragma Linker_Alias,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-constructor}@anchor{93}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-constructor}@anchor{90}
@section Pragma Linker_Constructor
@@ -5027,7 +4886,7 @@ listed above. Where possible, the use of Stand Alone Libraries is preferable
to the use of this pragma.
@node Pragma Linker_Destructor,Pragma Linker_Section,Pragma Linker_Constructor,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-destructor}@anchor{94}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-destructor}@anchor{91}
@section Pragma Linker_Destructor
@@ -5050,7 +4909,7 @@ See @code{pragma Linker_Constructor} for the set of restrictions that apply
because of these specific contexts.
@node Pragma Linker_Section,Pragma Lock_Free,Pragma Linker_Destructor,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id20}@anchor{95}@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-section}@anchor{96}
+@anchor{gnat_rm/implementation_defined_pragmas id20}@anchor{92}@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-section}@anchor{93}
@section Pragma Linker_Section
@@ -5124,7 +4983,7 @@ end IO_Card;
@end example
@node Pragma Lock_Free,Pragma Loop_Invariant,Pragma Linker_Section,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id21}@anchor{97}@anchor{gnat_rm/implementation_defined_pragmas pragma-lock-free}@anchor{98}
+@anchor{gnat_rm/implementation_defined_pragmas id21}@anchor{94}@anchor{gnat_rm/implementation_defined_pragmas pragma-lock-free}@anchor{95}
@section Pragma Lock_Free
@@ -5176,7 +5035,7 @@ Function calls and attribute references must be static
@end itemize
@node Pragma Loop_Invariant,Pragma Loop_Optimize,Pragma Lock_Free,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-invariant}@anchor{99}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-invariant}@anchor{96}
@section Pragma Loop_Invariant
@@ -5209,7 +5068,7 @@ attribute can only be used within the expression of a @code{Loop_Invariant}
pragma. For full details, see documentation of attribute @code{Loop_Entry}.
@node Pragma Loop_Optimize,Pragma Loop_Variant,Pragma Loop_Invariant,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-optimize}@anchor{9a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-optimize}@anchor{97}
@section Pragma Loop_Optimize
@@ -5271,7 +5130,7 @@ compiler in order to enable the relevant optimizations, that is to say
vectorization.
@node Pragma Loop_Variant,Pragma Machine_Attribute,Pragma Loop_Optimize,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-variant}@anchor{9b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-variant}@anchor{98}
@section Pragma Loop_Variant
@@ -5318,7 +5177,7 @@ The @code{Loop_Entry} attribute may be used within the expressions of the
@code{Loop_Variant} pragma to refer to values on entry to the loop.
@node Pragma Machine_Attribute,Pragma Main,Pragma Loop_Variant,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-machine-attribute}@anchor{9c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-machine-attribute}@anchor{99}
@section Pragma Machine_Attribute
@@ -5344,7 +5203,7 @@ which may make this pragma unusable for some attributes.
For further information see @cite{GNU Compiler Collection (GCC) Internals}.
@node Pragma Main,Pragma Main_Storage,Pragma Machine_Attribute,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-main}@anchor{9d}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-main}@anchor{9a}
@section Pragma Main
@@ -5364,7 +5223,7 @@ This pragma is provided for compatibility with OpenVMS VAX Systems. It has
no effect in GNAT, other than being syntax checked.
@node Pragma Main_Storage,Pragma Max_Queue_Length,Pragma Main,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-main-storage}@anchor{9e}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-main-storage}@anchor{9b}
@section Pragma Main_Storage
@@ -5383,7 +5242,7 @@ This pragma is provided for compatibility with OpenVMS VAX Systems. It has
no effect in GNAT, other than being syntax checked.
@node Pragma Max_Queue_Length,Pragma No_Body,Pragma Main_Storage,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id22}@anchor{9f}@anchor{gnat_rm/implementation_defined_pragmas pragma-max-queue-length}@anchor{a0}
+@anchor{gnat_rm/implementation_defined_pragmas id22}@anchor{9c}@anchor{gnat_rm/implementation_defined_pragmas pragma-max-queue-length}@anchor{9d}
@section Pragma Max_Queue_Length
@@ -5401,7 +5260,7 @@ entry.
A value of -1 represents no additional restriction on queue length.
@node Pragma No_Body,Pragma No_Caching,Pragma Max_Queue_Length,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-no-body}@anchor{a1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-body}@anchor{9e}
@section Pragma No_Body
@@ -5424,7 +5283,7 @@ dummy body with a No_Body pragma ensures that there is no interference from
earlier versions of the package body.
@node Pragma No_Caching,Pragma No_Component_Reordering,Pragma No_Body,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-no-caching}@anchor{a2}@anchor{gnat_rm/implementation_defined_pragmas id23}@anchor{a3}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-caching}@anchor{9f}@anchor{gnat_rm/implementation_defined_pragmas id23}@anchor{a0}
@section Pragma No_Caching
@@ -5438,7 +5297,7 @@ For the semantics of this pragma, see the entry for aspect @code{No_Caching} in
the SPARK 2014 Reference Manual, section 7.1.2.
@node Pragma No_Component_Reordering,Pragma No_Elaboration_Code_All,Pragma No_Caching,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-no-component-reordering}@anchor{a4}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-component-reordering}@anchor{a1}
@section Pragma No_Component_Reordering
@@ -5457,7 +5316,7 @@ declared in units to which the pragma applies and there is a requirement
that this pragma be used consistently within a partition.
@node Pragma No_Elaboration_Code_All,Pragma No_Heap_Finalization,Pragma No_Component_Reordering,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id24}@anchor{a5}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-elaboration-code-all}@anchor{a6}
+@anchor{gnat_rm/implementation_defined_pragmas id24}@anchor{a2}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-elaboration-code-all}@anchor{a3}
@section Pragma No_Elaboration_Code_All
@@ -5476,7 +5335,7 @@ current unit, it must also have the No_Elaboration_Code_All aspect set.
It may be applied to package or subprogram specs or their generic versions.
@node Pragma No_Heap_Finalization,Pragma No_Inline,Pragma No_Elaboration_Code_All,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-no-heap-finalization}@anchor{a7}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-heap-finalization}@anchor{a4}
@section Pragma No_Heap_Finalization
@@ -5508,7 +5367,7 @@ lose its @code{No_Heap_Finalization} pragma when the corresponding instance does
appear at the library level.
@node Pragma No_Inline,Pragma No_Return,Pragma No_Heap_Finalization,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id25}@anchor{a8}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-inline}@anchor{a9}
+@anchor{gnat_rm/implementation_defined_pragmas id25}@anchor{a5}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-inline}@anchor{a6}
@section Pragma No_Inline
@@ -5526,7 +5385,7 @@ in particular it is not subject to the use of option @emph{-gnatn} or
pragma @code{Inline_Always} for the same @code{NAME}.
@node Pragma No_Return,Pragma No_Strict_Aliasing,Pragma No_Inline,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-no-return}@anchor{aa}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-return}@anchor{a7}
@section Pragma No_Return
@@ -5553,7 +5412,7 @@ available in all earlier versions of Ada as an implementation-defined
pragma.
@node Pragma No_Strict_Aliasing,Pragma No_Tagged_Streams,Pragma No_Return,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-no-strict-aliasing}@anchor{ab}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-strict-aliasing}@anchor{a8}
@section Pragma No_Strict_Aliasing
@@ -5575,7 +5434,7 @@ in the @cite{GNAT User's Guide}.
This pragma currently has no effects on access to unconstrained array types.
@node Pragma No_Tagged_Streams,Pragma Normalize_Scalars,Pragma No_Strict_Aliasing,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-no-tagged-streams}@anchor{ac}@anchor{gnat_rm/implementation_defined_pragmas id26}@anchor{ad}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-tagged-streams}@anchor{a9}@anchor{gnat_rm/implementation_defined_pragmas id26}@anchor{aa}
@section Pragma No_Tagged_Streams
@@ -5614,7 +5473,7 @@ with empty strings. This is useful to avoid exposing entity names at binary
level but has a negative impact on the debuggability of tagged types.
@node Pragma Normalize_Scalars,Pragma Obsolescent,Pragma No_Tagged_Streams,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-normalize-scalars}@anchor{ae}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-normalize-scalars}@anchor{ab}
@section Pragma Normalize_Scalars
@@ -5696,7 +5555,7 @@ will always generate an invalid value if one exists.
@end table
@node Pragma Obsolescent,Pragma Optimize_Alignment,Pragma Normalize_Scalars,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-obsolescent}@anchor{af}@anchor{gnat_rm/implementation_defined_pragmas id27}@anchor{b0}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-obsolescent}@anchor{ac}@anchor{gnat_rm/implementation_defined_pragmas id27}@anchor{ad}
@section Pragma Obsolescent
@@ -5792,7 +5651,7 @@ So if you specify @code{Entity =>} for the @code{Entity} argument, and a @code{M
argument is present, it must be preceded by @code{Message =>}.
@node Pragma Optimize_Alignment,Pragma Ordered,Pragma Obsolescent,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-optimize-alignment}@anchor{b1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-optimize-alignment}@anchor{ae}
@section Pragma Optimize_Alignment
@@ -5878,7 +5737,7 @@ latter are compiled by default in pragma Optimize_Alignment (Off) mode if no
pragma appears at the start of the file.
@node Pragma Ordered,Pragma Overflow_Mode,Pragma Optimize_Alignment,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ordered}@anchor{b2}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ordered}@anchor{af}
@section Pragma Ordered
@@ -5970,7 +5829,7 @@ For additional information please refer to the description of the
@emph{-gnatw.u} switch in the GNAT User's Guide.
@node Pragma Overflow_Mode,Pragma Overriding_Renamings,Pragma Ordered,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-overflow-mode}@anchor{b3}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-overflow-mode}@anchor{b0}
@section Pragma Overflow_Mode
@@ -6009,7 +5868,7 @@ The pragma @code{Unsuppress (Overflow_Check)} unsuppresses (enables)
overflow checking, but does not affect the overflow mode.
@node Pragma Overriding_Renamings,Pragma Partition_Elaboration_Policy,Pragma Overflow_Mode,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-overriding-renamings}@anchor{b4}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-overriding-renamings}@anchor{b1}
@section Pragma Overriding_Renamings
@@ -6044,7 +5903,7 @@ RM 8.3 (15) stipulates that an overridden operation is not visible within the
declaration of the overriding operation.
@node Pragma Partition_Elaboration_Policy,Pragma Part_Of,Pragma Overriding_Renamings,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-partition-elaboration-policy}@anchor{b5}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-partition-elaboration-policy}@anchor{b2}
@section Pragma Partition_Elaboration_Policy
@@ -6061,7 +5920,7 @@ versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
@node Pragma Part_Of,Pragma Passive,Pragma Partition_Elaboration_Policy,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id28}@anchor{b6}@anchor{gnat_rm/implementation_defined_pragmas pragma-part-of}@anchor{b7}
+@anchor{gnat_rm/implementation_defined_pragmas id28}@anchor{b3}@anchor{gnat_rm/implementation_defined_pragmas pragma-part-of}@anchor{b4}
@section Pragma Part_Of
@@ -6077,7 +5936,7 @@ For the semantics of this pragma, see the entry for aspect @code{Part_Of} in the
SPARK 2014 Reference Manual, section 7.2.6.
@node Pragma Passive,Pragma Persistent_BSS,Pragma Part_Of,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-passive}@anchor{b8}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-passive}@anchor{b5}
@section Pragma Passive
@@ -6101,7 +5960,7 @@ For more information on the subject of passive tasks, see the section
'Passive Task Optimization' in the GNAT Users Guide.
@node Pragma Persistent_BSS,Pragma Polling,Pragma Passive,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id29}@anchor{b9}@anchor{gnat_rm/implementation_defined_pragmas pragma-persistent-bss}@anchor{ba}
+@anchor{gnat_rm/implementation_defined_pragmas id29}@anchor{b6}@anchor{gnat_rm/implementation_defined_pragmas pragma-persistent-bss}@anchor{b7}
@section Pragma Persistent_BSS
@@ -6132,7 +5991,7 @@ If this pragma is used on a target where this feature is not supported,
then the pragma will be ignored. See also @code{pragma Linker_Section}.
@node Pragma Polling,Pragma Post,Pragma Persistent_BSS,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-polling}@anchor{bb}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-polling}@anchor{b8}
@section Pragma Polling
@@ -6174,7 +6033,7 @@ Note that polling can also be enabled by use of the @emph{-gnatP} switch.
See the section on switches for gcc in the @cite{GNAT User's Guide}.
@node Pragma Post,Pragma Postcondition,Pragma Polling,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-post}@anchor{bc}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-post}@anchor{b9}
@section Pragma Post
@@ -6199,7 +6058,7 @@ appear at the start of the declarations in a subprogram body
(preceded only by other pragmas).
@node Pragma Postcondition,Pragma Post_Class,Pragma Post,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-postcondition}@anchor{bd}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-postcondition}@anchor{ba}
@section Pragma Postcondition
@@ -6364,7 +6223,7 @@ Ada 2012, and has been retained in its original form for
compatibility purposes.
@node Pragma Post_Class,Pragma Rename_Pragma,Pragma Postcondition,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-post-class}@anchor{be}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-post-class}@anchor{bb}
@section Pragma Post_Class
@@ -6399,7 +6258,7 @@ policy that controls this pragma is @code{Post'Class}, not
@code{Post_Class}.
@node Pragma Rename_Pragma,Pragma Pre,Pragma Post_Class,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-rename-pragma}@anchor{bf}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-rename-pragma}@anchor{bc}
@section Pragma Rename_Pragma
@@ -6438,7 +6297,7 @@ Pragma Inline_Only will not necessarily mean the same thing as the other Ada
compiler; it's up to you to make sure the semantics are close enough.
@node Pragma Pre,Pragma Precondition,Pragma Rename_Pragma,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-pre}@anchor{c0}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-pre}@anchor{bd}
@section Pragma Pre
@@ -6463,7 +6322,7 @@ appear at the start of the declarations in a subprogram body
(preceded only by other pragmas).
@node Pragma Precondition,Pragma Predicate,Pragma Pre,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-precondition}@anchor{c1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-precondition}@anchor{be}
@section Pragma Precondition
@@ -6522,7 +6381,7 @@ Ada 2012, and has been retained in its original form for
compatibility purposes.
@node Pragma Predicate,Pragma Predicate_Failure,Pragma Precondition,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate}@anchor{c2}@anchor{gnat_rm/implementation_defined_pragmas id30}@anchor{c3}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate}@anchor{bf}@anchor{gnat_rm/implementation_defined_pragmas id30}@anchor{c0}
@section Pragma Predicate
@@ -6576,7 +6435,7 @@ defined for subtype B). When following this approach, the
use of predicates should be avoided.
@node Pragma Predicate_Failure,Pragma Preelaborable_Initialization,Pragma Predicate,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate-failure}@anchor{c4}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate-failure}@anchor{c1}
@section Pragma Predicate_Failure
@@ -6593,7 +6452,7 @@ the language-defined
@code{Predicate_Failure} aspect, and shares its restrictions and semantics.
@node Pragma Preelaborable_Initialization,Pragma Prefix_Exception_Messages,Pragma Predicate_Failure,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-preelaborable-initialization}@anchor{c5}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-preelaborable-initialization}@anchor{c2}
@section Pragma Preelaborable_Initialization
@@ -6608,7 +6467,7 @@ versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
@node Pragma Prefix_Exception_Messages,Pragma Pre_Class,Pragma Preelaborable_Initialization,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-prefix-exception-messages}@anchor{c6}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-prefix-exception-messages}@anchor{c3}
@section Pragma Prefix_Exception_Messages
@@ -6639,7 +6498,7 @@ prefixing in this case, you can always call
@code{GNAT.Source_Info.Enclosing_Entity} and prepend the string manually.
@node Pragma Pre_Class,Pragma Priority_Specific_Dispatching,Pragma Prefix_Exception_Messages,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-pre-class}@anchor{c7}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-pre-class}@anchor{c4}
@section Pragma Pre_Class
@@ -6674,7 +6533,7 @@ policy that controls this pragma is @code{Pre'Class}, not
@code{Pre_Class}.
@node Pragma Priority_Specific_Dispatching,Pragma Profile,Pragma Pre_Class,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-priority-specific-dispatching}@anchor{c8}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-priority-specific-dispatching}@anchor{c5}
@section Pragma Priority_Specific_Dispatching
@@ -6698,7 +6557,7 @@ versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
@node Pragma Profile,Pragma Profile_Warnings,Pragma Priority_Specific_Dispatching,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-profile}@anchor{c9}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-profile}@anchor{c6}
@section Pragma Profile
@@ -6972,7 +6831,7 @@ conforming Ada constructs. The profile enables the following three pragmas:
@end itemize
@node Pragma Profile_Warnings,Pragma Propagate_Exceptions,Pragma Profile,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-profile-warnings}@anchor{ca}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-profile-warnings}@anchor{c7}
@section Pragma Profile_Warnings
@@ -6990,7 +6849,7 @@ violations of the profile generate warning messages instead
of error messages.
@node Pragma Propagate_Exceptions,Pragma Provide_Shift_Operators,Pragma Profile_Warnings,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-propagate-exceptions}@anchor{cb}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-propagate-exceptions}@anchor{c8}
@section Pragma Propagate_Exceptions
@@ -7009,7 +6868,7 @@ purposes. It used to be used in connection with optimization of
a now-obsolete mechanism for implementation of exceptions.
@node Pragma Provide_Shift_Operators,Pragma Psect_Object,Pragma Propagate_Exceptions,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-provide-shift-operators}@anchor{cc}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-provide-shift-operators}@anchor{c9}
@section Pragma Provide_Shift_Operators
@@ -7029,7 +6888,7 @@ including the function declarations for these five operators, together
with the pragma Import (Intrinsic, ...) statements.
@node Pragma Psect_Object,Pragma Pure_Function,Pragma Provide_Shift_Operators,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-psect-object}@anchor{cd}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-psect-object}@anchor{ca}
@section Pragma Psect_Object
@@ -7049,7 +6908,7 @@ EXTERNAL_SYMBOL ::=
This pragma is identical in effect to pragma @code{Common_Object}.
@node Pragma Pure_Function,Pragma Rational,Pragma Psect_Object,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-pure-function}@anchor{ce}@anchor{gnat_rm/implementation_defined_pragmas id31}@anchor{cf}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-pure-function}@anchor{cb}@anchor{gnat_rm/implementation_defined_pragmas id31}@anchor{cc}
@section Pragma Pure_Function
@@ -7111,7 +6970,7 @@ unit is not a Pure unit in the categorization sense. So for example, a function
thus marked is free to @code{with} non-pure units.
@node Pragma Rational,Pragma Ravenscar,Pragma Pure_Function,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-rational}@anchor{d0}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-rational}@anchor{cd}
@section Pragma Rational
@@ -7129,7 +6988,7 @@ pragma Profile (Rational);
@end example
@node Pragma Ravenscar,Pragma Refined_Depends,Pragma Rational,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ravenscar}@anchor{d1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ravenscar}@anchor{ce}
@section Pragma Ravenscar
@@ -7149,7 +7008,7 @@ pragma Profile (Ravenscar);
which is the preferred method of setting the @code{Ravenscar} profile.
@node Pragma Refined_Depends,Pragma Refined_Global,Pragma Ravenscar,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-depends}@anchor{d2}@anchor{gnat_rm/implementation_defined_pragmas id32}@anchor{d3}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-depends}@anchor{cf}@anchor{gnat_rm/implementation_defined_pragmas id32}@anchor{d0}
@section Pragma Refined_Depends
@@ -7182,7 +7041,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_Depends
the SPARK 2014 Reference Manual, section 6.1.5.
@node Pragma Refined_Global,Pragma Refined_Post,Pragma Refined_Depends,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-global}@anchor{d4}@anchor{gnat_rm/implementation_defined_pragmas id33}@anchor{d5}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-global}@anchor{d1}@anchor{gnat_rm/implementation_defined_pragmas id33}@anchor{d2}
@section Pragma Refined_Global
@@ -7207,7 +7066,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_Global}
the SPARK 2014 Reference Manual, section 6.1.4.
@node Pragma Refined_Post,Pragma Refined_State,Pragma Refined_Global,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-post}@anchor{d6}@anchor{gnat_rm/implementation_defined_pragmas id34}@anchor{d7}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-post}@anchor{d3}@anchor{gnat_rm/implementation_defined_pragmas id34}@anchor{d4}
@section Pragma Refined_Post
@@ -7221,7 +7080,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_Post} i
the SPARK 2014 Reference Manual, section 7.2.7.
@node Pragma Refined_State,Pragma Relative_Deadline,Pragma Refined_Post,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-state}@anchor{d8}@anchor{gnat_rm/implementation_defined_pragmas id35}@anchor{d9}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-state}@anchor{d5}@anchor{gnat_rm/implementation_defined_pragmas id35}@anchor{d6}
@section Pragma Refined_State
@@ -7247,7 +7106,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_State}
the SPARK 2014 Reference Manual, section 7.2.2.
@node Pragma Relative_Deadline,Pragma Remote_Access_Type,Pragma Refined_State,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-relative-deadline}@anchor{da}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-relative-deadline}@anchor{d7}
@section Pragma Relative_Deadline
@@ -7262,7 +7121,7 @@ versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
@node Pragma Remote_Access_Type,Pragma Restricted_Run_Time,Pragma Relative_Deadline,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id36}@anchor{db}@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{dc}
+@anchor{gnat_rm/implementation_defined_pragmas id36}@anchor{d8}@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{d9}
@section Pragma Remote_Access_Type
@@ -7288,7 +7147,7 @@ pertaining to remote access to class-wide types. At instantiation, the
actual type must be a remote access to class-wide type.
@node Pragma Restricted_Run_Time,Pragma Restriction_Warnings,Pragma Remote_Access_Type,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-restricted-run-time}@anchor{dd}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-restricted-run-time}@anchor{da}
@section Pragma Restricted_Run_Time
@@ -7309,7 +7168,7 @@ which is the preferred method of setting the restricted run time
profile.
@node Pragma Restriction_Warnings,Pragma Reviewable,Pragma Restricted_Run_Time,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-restriction-warnings}@anchor{de}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-restriction-warnings}@anchor{db}
@section Pragma Restriction_Warnings
@@ -7347,7 +7206,7 @@ generating a warning, but any other use of implementation
defined pragmas will cause a warning to be generated.
@node Pragma Reviewable,Pragma Secondary_Stack_Size,Pragma Restriction_Warnings,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-reviewable}@anchor{df}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-reviewable}@anchor{dc}
@section Pragma Reviewable
@@ -7451,7 +7310,7 @@ comprehensive messages identifying possible problems based on this
information.
@node Pragma Secondary_Stack_Size,Pragma Share_Generic,Pragma Reviewable,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id37}@anchor{e0}@anchor{gnat_rm/implementation_defined_pragmas pragma-secondary-stack-size}@anchor{e1}
+@anchor{gnat_rm/implementation_defined_pragmas id37}@anchor{dd}@anchor{gnat_rm/implementation_defined_pragmas pragma-secondary-stack-size}@anchor{de}
@section Pragma Secondary_Stack_Size
@@ -7487,7 +7346,7 @@ Note the pragma cannot appear when the restriction @code{No_Secondary_Stack}
is in effect.
@node Pragma Share_Generic,Pragma Shared,Pragma Secondary_Stack_Size,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-share-generic}@anchor{e2}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-share-generic}@anchor{df}
@section Pragma Share_Generic
@@ -7505,7 +7364,7 @@ than to check that the given names are all names of generic units or
generic instances.
@node Pragma Shared,Pragma Short_Circuit_And_Or,Pragma Share_Generic,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id38}@anchor{e3}@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{e4}
+@anchor{gnat_rm/implementation_defined_pragmas id38}@anchor{e0}@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{e1}
@section Pragma Shared
@@ -7513,7 +7372,7 @@ This pragma is provided for compatibility with Ada 83. The syntax and
semantics are identical to pragma Atomic.
@node Pragma Short_Circuit_And_Or,Pragma Short_Descriptors,Pragma Shared,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-short-circuit-and-or}@anchor{e5}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-short-circuit-and-or}@anchor{e2}
@section Pragma Short_Circuit_And_Or
@@ -7532,7 +7391,7 @@ within the file being compiled, it applies only to the file being compiled.
There is no requirement that all units in a partition use this option.
@node Pragma Short_Descriptors,Pragma Simple_Storage_Pool_Type,Pragma Short_Circuit_And_Or,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-short-descriptors}@anchor{e6}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-short-descriptors}@anchor{e3}
@section Pragma Short_Descriptors
@@ -7546,7 +7405,7 @@ This pragma is provided for compatibility with other Ada implementations. It
is recognized but ignored by all current versions of GNAT.
@node Pragma Simple_Storage_Pool_Type,Pragma Source_File_Name,Pragma Short_Descriptors,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{e7}@anchor{gnat_rm/implementation_defined_pragmas id39}@anchor{e8}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{e4}@anchor{gnat_rm/implementation_defined_pragmas id39}@anchor{e5}
@section Pragma Simple_Storage_Pool_Type
@@ -7600,7 +7459,7 @@ storage-management discipline).
An object of a simple storage pool type can be associated with an access
type by specifying the attribute
-@ref{e9,,Simple_Storage_Pool}. For example:
+@ref{e6,,Simple_Storage_Pool}. For example:
@example
My_Pool : My_Simple_Storage_Pool_Type;
@@ -7610,11 +7469,11 @@ type Acc is access My_Data_Type;
for Acc'Simple_Storage_Pool use My_Pool;
@end example
-See attribute @ref{e9,,Simple_Storage_Pool}
+See attribute @ref{e6,,Simple_Storage_Pool}
for further details.
@node Pragma Source_File_Name,Pragma Source_File_Name_Project,Pragma Simple_Storage_Pool_Type,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{ea}@anchor{gnat_rm/implementation_defined_pragmas id40}@anchor{eb}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{e7}@anchor{gnat_rm/implementation_defined_pragmas id40}@anchor{e8}
@section Pragma Source_File_Name
@@ -7706,20 +7565,20 @@ aware of these pragmas, and so other tools that use the projet file would not
be aware of the intended naming conventions. If you are using project files,
file naming is controlled by Source_File_Name_Project pragmas, which are
usually supplied automatically by the project manager. A pragma
-Source_File_Name cannot appear after a @ref{ec,,Pragma Source_File_Name_Project}.
+Source_File_Name cannot appear after a @ref{e9,,Pragma Source_File_Name_Project}.
For more details on the use of the @code{Source_File_Name} pragma, see the
sections on @cite{Using Other File Names} and @cite{Alternative File Naming Schemes}
in the @cite{GNAT User's Guide}.
@node Pragma Source_File_Name_Project,Pragma Source_Reference,Pragma Source_File_Name,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{ec}@anchor{gnat_rm/implementation_defined_pragmas id41}@anchor{ed}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{e9}@anchor{gnat_rm/implementation_defined_pragmas id41}@anchor{ea}
@section Pragma Source_File_Name_Project
This pragma has the same syntax and semantics as pragma Source_File_Name.
It is only allowed as a stand-alone configuration pragma.
-It cannot appear after a @ref{ea,,Pragma Source_File_Name}, and
+It cannot appear after a @ref{e7,,Pragma Source_File_Name}, and
most importantly, once pragma Source_File_Name_Project appears,
no further Source_File_Name pragmas are allowed.
@@ -7731,7 +7590,7 @@ Source_File_Name or Source_File_Name_Project pragmas (which would not be
known to the project manager).
@node Pragma Source_Reference,Pragma SPARK_Mode,Pragma Source_File_Name_Project,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-source-reference}@anchor{ee}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-source-reference}@anchor{eb}
@section Pragma Source_Reference
@@ -7755,7 +7614,7 @@ string expression other than a string literal. This is because its value
is needed for error messages issued by all phases of the compiler.
@node Pragma SPARK_Mode,Pragma Static_Elaboration_Desired,Pragma Source_Reference,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{ef}@anchor{gnat_rm/implementation_defined_pragmas id42}@anchor{f0}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{ec}@anchor{gnat_rm/implementation_defined_pragmas id42}@anchor{ed}
@section Pragma SPARK_Mode
@@ -7837,7 +7696,7 @@ SPARK_Mode (@code{Off}), then that pragma will need to be repeated in
the package body.
@node Pragma Static_Elaboration_Desired,Pragma Stream_Convert,Pragma SPARK_Mode,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-static-elaboration-desired}@anchor{f1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-static-elaboration-desired}@anchor{ee}
@section Pragma Static_Elaboration_Desired
@@ -7861,7 +7720,7 @@ construction of larger aggregates with static components that include an others
choice.)
@node Pragma Stream_Convert,Pragma Style_Checks,Pragma Static_Elaboration_Desired,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-stream-convert}@anchor{f2}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-stream-convert}@anchor{ef}
@section Pragma Stream_Convert
@@ -7938,7 +7797,7 @@ the pragma is silently ignored, and the default implementation of the stream
attributes is used instead.
@node Pragma Style_Checks,Pragma Subtitle,Pragma Stream_Convert,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-style-checks}@anchor{f3}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-style-checks}@anchor{f0}
@section Pragma Style_Checks
@@ -8011,7 +7870,7 @@ Rf2 : Integer := ARG; -- OK, no error
@end example
@node Pragma Subtitle,Pragma Suppress,Pragma Style_Checks,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-subtitle}@anchor{f4}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-subtitle}@anchor{f1}
@section Pragma Subtitle
@@ -8025,7 +7884,7 @@ This pragma is recognized for compatibility with other Ada compilers
but is ignored by GNAT.
@node Pragma Suppress,Pragma Suppress_All,Pragma Subtitle,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress}@anchor{f5}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress}@anchor{f2}
@section Pragma Suppress
@@ -8098,7 +7957,7 @@ Of course, run-time checks are omitted whenever the compiler can prove
that they will not fail, whether or not checks are suppressed.
@node Pragma Suppress_All,Pragma Suppress_Debug_Info,Pragma Suppress,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-all}@anchor{f6}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-all}@anchor{f3}
@section Pragma Suppress_All
@@ -8117,7 +7976,7 @@ The use of the standard Ada pragma @code{Suppress (All_Checks)}
as a normal configuration pragma is the preferred usage in GNAT.
@node Pragma Suppress_Debug_Info,Pragma Suppress_Exception_Locations,Pragma Suppress_All,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{f7}@anchor{gnat_rm/implementation_defined_pragmas id43}@anchor{f8}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{f4}@anchor{gnat_rm/implementation_defined_pragmas id43}@anchor{f5}
@section Pragma Suppress_Debug_Info
@@ -8132,7 +7991,7 @@ for the specified entity. It is intended primarily for use in debugging
the debugger, and navigating around debugger problems.
@node Pragma Suppress_Exception_Locations,Pragma Suppress_Initialization,Pragma Suppress_Debug_Info,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-exception-locations}@anchor{f9}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-exception-locations}@anchor{f6}
@section Pragma Suppress_Exception_Locations
@@ -8155,7 +8014,7 @@ a partition, so it is fine to have some units within a partition compiled
with this pragma and others compiled in normal mode without it.
@node Pragma Suppress_Initialization,Pragma Task_Name,Pragma Suppress_Exception_Locations,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id44}@anchor{fa}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{fb}
+@anchor{gnat_rm/implementation_defined_pragmas id44}@anchor{f7}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{f8}
@section Pragma Suppress_Initialization
@@ -8200,7 +8059,7 @@ is suppressed, just as though its subtype had been given in a pragma
Suppress_Initialization, as described above.
@node Pragma Task_Name,Pragma Task_Storage,Pragma Suppress_Initialization,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-task-name}@anchor{fc}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-task-name}@anchor{f9}
@section Pragma Task_Name
@@ -8256,7 +8115,7 @@ end;
@end example
@node Pragma Task_Storage,Pragma Test_Case,Pragma Task_Name,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-task-storage}@anchor{fd}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-task-storage}@anchor{fa}
@section Pragma Task_Storage
@@ -8276,7 +8135,7 @@ created, depending on the target. This pragma can appear anywhere a
type.
@node Pragma Test_Case,Pragma Thread_Local_Storage,Pragma Task_Storage,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{fe}@anchor{gnat_rm/implementation_defined_pragmas id45}@anchor{ff}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{fb}@anchor{gnat_rm/implementation_defined_pragmas id45}@anchor{fc}
@section Pragma Test_Case
@@ -8332,7 +8191,7 @@ postcondition. Mode @code{Robustness} indicates that the precondition and
postcondition of the subprogram should be ignored for this test case.
@node Pragma Thread_Local_Storage,Pragma Time_Slice,Pragma Test_Case,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{100}@anchor{gnat_rm/implementation_defined_pragmas id46}@anchor{101}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{fd}@anchor{gnat_rm/implementation_defined_pragmas id46}@anchor{fe}
@section Pragma Thread_Local_Storage
@@ -8370,7 +8229,7 @@ If this pragma is used on a system where @code{TLS} is not supported,
then an error message will be generated and the program will be rejected.
@node Pragma Time_Slice,Pragma Title,Pragma Thread_Local_Storage,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-time-slice}@anchor{102}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-time-slice}@anchor{ff}
@section Pragma Time_Slice
@@ -8386,7 +8245,7 @@ It is ignored if it is used in a system that does not allow this control,
or if it appears in other than the main program unit.
@node Pragma Title,Pragma Type_Invariant,Pragma Time_Slice,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-title}@anchor{103}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-title}@anchor{100}
@section Pragma Title
@@ -8411,7 +8270,7 @@ notation is used, and named and positional notation can be mixed
following the normal rules for procedure calls in Ada.
@node Pragma Type_Invariant,Pragma Type_Invariant_Class,Pragma Title,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant}@anchor{104}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant}@anchor{101}
@section Pragma Type_Invariant
@@ -8432,7 +8291,7 @@ controlled by the assertion identifier @code{Type_Invariant}
rather than @code{Invariant}.
@node Pragma Type_Invariant_Class,Pragma Unchecked_Union,Pragma Type_Invariant,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id47}@anchor{105}@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{106}
+@anchor{gnat_rm/implementation_defined_pragmas id47}@anchor{102}@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{103}
@section Pragma Type_Invariant_Class
@@ -8459,7 +8318,7 @@ policy that controls this pragma is @code{Type_Invariant'Class},
not @code{Type_Invariant_Class}.
@node Pragma Unchecked_Union,Pragma Unevaluated_Use_Of_Old,Pragma Type_Invariant_Class,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unchecked-union}@anchor{107}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unchecked-union}@anchor{104}
@section Pragma Unchecked_Union
@@ -8479,7 +8338,7 @@ version in all language modes (Ada 83, Ada 95, and Ada 2005). For full
details, consult the Ada 2012 Reference Manual, section B.3.3.
@node Pragma Unevaluated_Use_Of_Old,Pragma Unimplemented_Unit,Pragma Unchecked_Union,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unevaluated-use-of-old}@anchor{108}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unevaluated-use-of-old}@anchor{105}
@section Pragma Unevaluated_Use_Of_Old
@@ -8534,7 +8393,7 @@ uses up to the end of the corresponding statement sequence or
sequence of package declarations.
@node Pragma Unimplemented_Unit,Pragma Universal_Aliasing,Pragma Unevaluated_Use_Of_Old,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unimplemented-unit}@anchor{109}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unimplemented-unit}@anchor{106}
@section Pragma Unimplemented_Unit
@@ -8554,7 +8413,7 @@ The abort only happens if code is being generated. Thus you can use
specs of unimplemented packages in syntax or semantic checking mode.
@node Pragma Universal_Aliasing,Pragma Universal_Data,Pragma Unimplemented_Unit,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{10a}@anchor{gnat_rm/implementation_defined_pragmas id48}@anchor{10b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{107}@anchor{gnat_rm/implementation_defined_pragmas id48}@anchor{108}
@section Pragma Universal_Aliasing
@@ -8573,7 +8432,7 @@ situations in which it must be suppressed, see the section on
@code{Optimization and Strict Aliasing} in the @cite{GNAT User's Guide}.
@node Pragma Universal_Data,Pragma Unmodified,Pragma Universal_Aliasing,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-data}@anchor{10c}@anchor{gnat_rm/implementation_defined_pragmas id49}@anchor{10d}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-data}@anchor{109}@anchor{gnat_rm/implementation_defined_pragmas id49}@anchor{10a}
@section Pragma Universal_Data
@@ -8597,7 +8456,7 @@ of this pragma is also available by applying the -univ switch on the
compilations of units where universal addressing of the data is desired.
@node Pragma Unmodified,Pragma Unreferenced,Pragma Universal_Data,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id50}@anchor{10e}@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{10f}
+@anchor{gnat_rm/implementation_defined_pragmas id50}@anchor{10b}@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{10c}
@section Pragma Unmodified
@@ -8631,7 +8490,7 @@ Thus it is never necessary to use @code{pragma Unmodified} for such
variables, though it is harmless to do so.
@node Pragma Unreferenced,Pragma Unreferenced_Objects,Pragma Unmodified,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{110}@anchor{gnat_rm/implementation_defined_pragmas id51}@anchor{111}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{10d}@anchor{gnat_rm/implementation_defined_pragmas id51}@anchor{10e}
@section Pragma Unreferenced
@@ -8675,7 +8534,7 @@ Note that if a warning is desired for all calls to a given subprogram,
regardless of whether they occur in the same unit as the subprogram
declaration, then this pragma should not be used (calls from another
unit would not be flagged); pragma Obsolescent can be used instead
-for this purpose, see @ref{af,,Pragma Obsolescent}.
+for this purpose, see @ref{ac,,Pragma Obsolescent}.
The second form of pragma @code{Unreferenced} is used within a context
clause. In this case the arguments must be unit names of units previously
@@ -8691,7 +8550,7 @@ Thus it is never necessary to use @code{pragma Unreferenced} for such
variables, though it is harmless to do so.
@node Pragma Unreferenced_Objects,Pragma Unreserve_All_Interrupts,Pragma Unreferenced,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{112}@anchor{gnat_rm/implementation_defined_pragmas id52}@anchor{113}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{10f}@anchor{gnat_rm/implementation_defined_pragmas id52}@anchor{110}
@section Pragma Unreferenced_Objects
@@ -8716,7 +8575,7 @@ compiler will automatically suppress unwanted warnings about these variables
not being referenced.
@node Pragma Unreserve_All_Interrupts,Pragma Unsuppress,Pragma Unreferenced_Objects,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unreserve-all-interrupts}@anchor{114}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unreserve-all-interrupts}@anchor{111}
@section Pragma Unreserve_All_Interrupts
@@ -8752,7 +8611,7 @@ handled, see pragma @code{Interrupt_State}, which subsumes the functionality
of the @code{Unreserve_All_Interrupts} pragma.
@node Pragma Unsuppress,Pragma Use_VADS_Size,Pragma Unreserve_All_Interrupts,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unsuppress}@anchor{115}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unsuppress}@anchor{112}
@section Pragma Unsuppress
@@ -8788,7 +8647,7 @@ number of implementation-defined check names. See the description of pragma
@code{Suppress} for full details.
@node Pragma Use_VADS_Size,Pragma Unused,Pragma Unsuppress,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-use-vads-size}@anchor{116}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-use-vads-size}@anchor{113}
@section Pragma Use_VADS_Size
@@ -8812,7 +8671,7 @@ as implemented in the VADS compiler. See description of the VADS_Size
attribute for further details.
@node Pragma Unused,Pragma Validity_Checks,Pragma Use_VADS_Size,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unused}@anchor{117}@anchor{gnat_rm/implementation_defined_pragmas id53}@anchor{118}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unused}@anchor{114}@anchor{gnat_rm/implementation_defined_pragmas id53}@anchor{115}
@section Pragma Unused
@@ -8846,7 +8705,7 @@ Thus it is never necessary to use @code{pragma Unmodified} for such
variables, though it is harmless to do so.
@node Pragma Validity_Checks,Pragma Volatile,Pragma Unused,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-validity-checks}@anchor{119}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-validity-checks}@anchor{116}
@section Pragma Validity_Checks
@@ -8902,7 +8761,7 @@ A := C; -- C will be validity checked
@end example
@node Pragma Volatile,Pragma Volatile_Full_Access,Pragma Validity_Checks,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id54}@anchor{11a}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{11b}
+@anchor{gnat_rm/implementation_defined_pragmas id54}@anchor{117}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{118}
@section Pragma Volatile
@@ -8920,7 +8779,7 @@ implementation of pragma Volatile is upwards compatible with the
implementation in DEC Ada 83.
@node Pragma Volatile_Full_Access,Pragma Volatile_Function,Pragma Volatile,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id55}@anchor{11c}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{11d}
+@anchor{gnat_rm/implementation_defined_pragmas id55}@anchor{119}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{11a}
@section Pragma Volatile_Full_Access
@@ -8952,7 +8811,7 @@ It is not permissible to specify @code{Volatile_Full_Access} for a composite
(record or array) type or object that has an @code{Aliased} subcomponent.
@node Pragma Volatile_Function,Pragma Warning_As_Error,Pragma Volatile_Full_Access,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id56}@anchor{11e}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{11f}
+@anchor{gnat_rm/implementation_defined_pragmas id56}@anchor{11b}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{11c}
@section Pragma Volatile_Function
@@ -8966,7 +8825,7 @@ For the semantics of this pragma, see the entry for aspect @code{Volatile_Functi
in the SPARK 2014 Reference Manual, section 7.1.2.
@node Pragma Warning_As_Error,Pragma Warnings,Pragma Volatile_Function,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-warning-as-error}@anchor{120}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-warning-as-error}@anchor{11d}
@section Pragma Warning_As_Error
@@ -9006,7 +8865,7 @@ you can use multiple pragma Warning_As_Error.
The above use of patterns to match the message applies only to warning
messages generated by the front end. This pragma can also be applied to
-warnings provided by the back end and mentioned in @ref{121,,Pragma Warnings}.
+warnings provided by the back end and mentioned in @ref{11e,,Pragma Warnings}.
By using a single full @emph{-Wxxx} switch in the pragma, such warnings
can also be treated as errors.
@@ -9056,7 +8915,7 @@ the tag is changed from "warning:" to "error:" and the string
"[warning-as-error]" is appended to the end of the message.
@node Pragma Warnings,Pragma Weak_External,Pragma Warning_As_Error,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id57}@anchor{122}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{121}
+@anchor{gnat_rm/implementation_defined_pragmas id57}@anchor{11f}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{11e}
@section Pragma Warnings
@@ -9070,7 +8929,7 @@ DETAILS ::= On | Off, local_NAME
DETAILS ::= static_string_EXPRESSION
DETAILS ::= On | Off, static_string_EXPRESSION
-TOOL_NAME ::= GNAT | GNATProve
+TOOL_NAME ::= GNAT | GNATprove
REASON ::= Reason => STRING_LITERAL @{& STRING_LITERAL@}
@end example
@@ -9212,7 +9071,7 @@ selectively for each tool, and as a consequence to detect useless pragma
Warnings with switch @code{-gnatw.w}.
@node Pragma Weak_External,Pragma Wide_Character_Encoding,Pragma Warnings,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-weak-external}@anchor{123}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-weak-external}@anchor{120}
@section Pragma Weak_External
@@ -9263,7 +9122,7 @@ end External_Module;
@end example
@node Pragma Wide_Character_Encoding,,Pragma Weak_External,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-wide-character-encoding}@anchor{124}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-wide-character-encoding}@anchor{121}
@section Pragma Wide_Character_Encoding
@@ -9294,7 +9153,7 @@ encoding within that file, and does not affect withed units, specs,
or subunits.
@node Implementation Defined Aspects,Implementation Defined Attributes,Implementation Defined Pragmas,Top
-@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{125}@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{126}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{127}
+@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{122}@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{123}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{124}
@chapter Implementation Defined Aspects
@@ -9389,6 +9248,7 @@ or attribute definition clause.
* Aspect Refined_Global::
* Aspect Refined_Post::
* Aspect Refined_State::
+* Aspect Relaxed_Initialization::
* Aspect Remote_Access_Type::
* Aspect Secondary_Stack_Size::
* Aspect Scalar_Storage_Order::
@@ -9413,7 +9273,7 @@ or attribute definition clause.
@end menu
@node Aspect Abstract_State,Aspect Annotate,,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-abstract-state}@anchor{128}
+@anchor{gnat_rm/implementation_defined_aspects aspect-abstract-state}@anchor{125}
@section Aspect Abstract_State
@@ -9422,7 +9282,7 @@ or attribute definition clause.
This aspect is equivalent to @ref{1c,,pragma Abstract_State}.
@node Aspect Annotate,Aspect Async_Readers,Aspect Abstract_State,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-annotate}@anchor{129}
+@anchor{gnat_rm/implementation_defined_aspects aspect-annotate}@anchor{126}
@section Aspect Annotate
@@ -9430,7 +9290,7 @@ This aspect is equivalent to @ref{1c,,pragma Abstract_State}.
There are three forms of this aspect (where ID is an identifier,
and ARG is a general expression),
-corresponding to @ref{2a,,pragma Annotate}.
+corresponding to @ref{26,,pragma Annotate}.
@table @asis
@@ -9449,63 +9309,63 @@ Equivalent to @code{pragma Annotate (ID, ID @{, ARG@}, Entity => Name);}
@end table
@node Aspect Async_Readers,Aspect Async_Writers,Aspect Annotate,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-async-readers}@anchor{12a}
+@anchor{gnat_rm/implementation_defined_aspects aspect-async-readers}@anchor{127}
@section Aspect Async_Readers
@geindex Async_Readers
-This boolean aspect is equivalent to @ref{31,,pragma Async_Readers}.
+This boolean aspect is equivalent to @ref{2d,,pragma Async_Readers}.
@node Aspect Async_Writers,Aspect Constant_After_Elaboration,Aspect Async_Readers,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-async-writers}@anchor{12b}
+@anchor{gnat_rm/implementation_defined_aspects aspect-async-writers}@anchor{128}
@section Aspect Async_Writers
@geindex Async_Writers
-This boolean aspect is equivalent to @ref{34,,pragma Async_Writers}.
+This boolean aspect is equivalent to @ref{30,,pragma Async_Writers}.
@node Aspect Constant_After_Elaboration,Aspect Contract_Cases,Aspect Async_Writers,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-constant-after-elaboration}@anchor{12c}
+@anchor{gnat_rm/implementation_defined_aspects aspect-constant-after-elaboration}@anchor{129}
@section Aspect Constant_After_Elaboration
@geindex Constant_After_Elaboration
-This aspect is equivalent to @ref{45,,pragma Constant_After_Elaboration}.
+This aspect is equivalent to @ref{42,,pragma Constant_After_Elaboration}.
@node Aspect Contract_Cases,Aspect Depends,Aspect Constant_After_Elaboration,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-contract-cases}@anchor{12d}
+@anchor{gnat_rm/implementation_defined_aspects aspect-contract-cases}@anchor{12a}
@section Aspect Contract_Cases
@geindex Contract_Cases
-This aspect is equivalent to @ref{47,,pragma Contract_Cases}, the sequence
+This aspect is equivalent to @ref{44,,pragma Contract_Cases}, the sequence
of clauses being enclosed in parentheses so that syntactically it is an
aggregate.
@node Aspect Depends,Aspect Default_Initial_Condition,Aspect Contract_Cases,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-depends}@anchor{12e}
+@anchor{gnat_rm/implementation_defined_aspects aspect-depends}@anchor{12b}
@section Aspect Depends
@geindex Depends
-This aspect is equivalent to @ref{56,,pragma Depends}.
+This aspect is equivalent to @ref{53,,pragma Depends}.
@node Aspect Default_Initial_Condition,Aspect Dimension,Aspect Depends,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-default-initial-condition}@anchor{12f}
+@anchor{gnat_rm/implementation_defined_aspects aspect-default-initial-condition}@anchor{12c}
@section Aspect Default_Initial_Condition
@geindex Default_Initial_Condition
-This aspect is equivalent to @ref{51,,pragma Default_Initial_Condition}.
+This aspect is equivalent to @ref{4e,,pragma Default_Initial_Condition}.
@node Aspect Dimension,Aspect Dimension_System,Aspect Default_Initial_Condition,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-dimension}@anchor{130}
+@anchor{gnat_rm/implementation_defined_aspects aspect-dimension}@anchor{12d}
@section Aspect Dimension
@@ -9541,7 +9401,7 @@ Note that when the dimensioned type is an integer type, then any
dimension value must be an integer literal.
@node Aspect Dimension_System,Aspect Disable_Controlled,Aspect Dimension,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-dimension-system}@anchor{131}
+@anchor{gnat_rm/implementation_defined_aspects aspect-dimension-system}@anchor{12e}
@section Aspect Dimension_System
@@ -9601,7 +9461,7 @@ See section 'Performing Dimensionality Analysis in GNAT' in the GNAT Users
Guide for detailed examples of use of the dimension system.
@node Aspect Disable_Controlled,Aspect Effective_Reads,Aspect Dimension_System,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-disable-controlled}@anchor{132}
+@anchor{gnat_rm/implementation_defined_aspects aspect-disable-controlled}@anchor{12f}
@section Aspect Disable_Controlled
@@ -9614,110 +9474,110 @@ where for example you might want a record to be controlled or not depending on
whether some run-time check is enabled or suppressed.
@node Aspect Effective_Reads,Aspect Effective_Writes,Aspect Disable_Controlled,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-effective-reads}@anchor{133}
+@anchor{gnat_rm/implementation_defined_aspects aspect-effective-reads}@anchor{130}
@section Aspect Effective_Reads
@geindex Effective_Reads
-This aspect is equivalent to @ref{5c,,pragma Effective_Reads}.
+This aspect is equivalent to @ref{59,,pragma Effective_Reads}.
@node Aspect Effective_Writes,Aspect Extensions_Visible,Aspect Effective_Reads,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-effective-writes}@anchor{134}
+@anchor{gnat_rm/implementation_defined_aspects aspect-effective-writes}@anchor{131}
@section Aspect Effective_Writes
@geindex Effective_Writes
-This aspect is equivalent to @ref{5e,,pragma Effective_Writes}.
+This aspect is equivalent to @ref{5b,,pragma Effective_Writes}.
@node Aspect Extensions_Visible,Aspect Favor_Top_Level,Aspect Effective_Writes,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-extensions-visible}@anchor{135}
+@anchor{gnat_rm/implementation_defined_aspects aspect-extensions-visible}@anchor{132}
@section Aspect Extensions_Visible
@geindex Extensions_Visible
-This aspect is equivalent to @ref{6a,,pragma Extensions_Visible}.
+This aspect is equivalent to @ref{67,,pragma Extensions_Visible}.
@node Aspect Favor_Top_Level,Aspect Ghost,Aspect Extensions_Visible,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-favor-top-level}@anchor{136}
+@anchor{gnat_rm/implementation_defined_aspects aspect-favor-top-level}@anchor{133}
@section Aspect Favor_Top_Level
@geindex Favor_Top_Level
-This boolean aspect is equivalent to @ref{6f,,pragma Favor_Top_Level}.
+This boolean aspect is equivalent to @ref{6c,,pragma Favor_Top_Level}.
@node Aspect Ghost,Aspect Global,Aspect Favor_Top_Level,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-ghost}@anchor{137}
+@anchor{gnat_rm/implementation_defined_aspects aspect-ghost}@anchor{134}
@section Aspect Ghost
@geindex Ghost
-This aspect is equivalent to @ref{72,,pragma Ghost}.
+This aspect is equivalent to @ref{6f,,pragma Ghost}.
@node Aspect Global,Aspect Initial_Condition,Aspect Ghost,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{138}
+@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{135}
@section Aspect Global
@geindex Global
-This aspect is equivalent to @ref{74,,pragma Global}.
+This aspect is equivalent to @ref{71,,pragma Global}.
@node Aspect Initial_Condition,Aspect Initializes,Aspect Global,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{139}
+@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{136}
@section Aspect Initial_Condition
@geindex Initial_Condition
-This aspect is equivalent to @ref{82,,pragma Initial_Condition}.
+This aspect is equivalent to @ref{7f,,pragma Initial_Condition}.
@node Aspect Initializes,Aspect Inline_Always,Aspect Initial_Condition,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{13a}
+@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{137}
@section Aspect Initializes
@geindex Initializes
-This aspect is equivalent to @ref{84,,pragma Initializes}.
+This aspect is equivalent to @ref{81,,pragma Initializes}.
@node Aspect Inline_Always,Aspect Invariant,Aspect Initializes,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{13b}
+@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{138}
@section Aspect Inline_Always
@geindex Inline_Always
-This boolean aspect is equivalent to @ref{87,,pragma Inline_Always}.
+This boolean aspect is equivalent to @ref{84,,pragma Inline_Always}.
@node Aspect Invariant,Aspect Invariant'Class,Aspect Inline_Always,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{13c}
+@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{139}
@section Aspect Invariant
@geindex Invariant
-This aspect is equivalent to @ref{8e,,pragma Invariant}. It is a
+This aspect is equivalent to @ref{8b,,pragma Invariant}. It is a
synonym for the language defined aspect @code{Type_Invariant} except
that it is separately controllable using pragma @code{Assertion_Policy}.
@node Aspect Invariant'Class,Aspect Iterable,Aspect Invariant,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-invariant-class}@anchor{13d}
+@anchor{gnat_rm/implementation_defined_aspects aspect-invariant-class}@anchor{13a}
@section Aspect Invariant'Class
@geindex Invariant'Class
-This aspect is equivalent to @ref{106,,pragma Type_Invariant_Class}. It is a
+This aspect is equivalent to @ref{103,,pragma Type_Invariant_Class}. It is a
synonym for the language defined aspect @code{Type_Invariant'Class} except
that it is separately controllable using pragma @code{Assertion_Policy}.
@node Aspect Iterable,Aspect Linker_Section,Aspect Invariant'Class,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-iterable}@anchor{13e}
+@anchor{gnat_rm/implementation_defined_aspects aspect-iterable}@anchor{13b}
@section Aspect Iterable
@@ -9797,117 +9657,117 @@ function Get_Element (Cont : Container; Position : Cursor) return Element_Type;
This aspect is used in the GNAT-defined formal container packages.
@node Aspect Linker_Section,Aspect Lock_Free,Aspect Iterable,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-linker-section}@anchor{13f}
+@anchor{gnat_rm/implementation_defined_aspects aspect-linker-section}@anchor{13c}
@section Aspect Linker_Section
@geindex Linker_Section
-This aspect is equivalent to @ref{96,,pragma Linker_Section}.
+This aspect is equivalent to @ref{93,,pragma Linker_Section}.
@node Aspect Lock_Free,Aspect Max_Queue_Length,Aspect Linker_Section,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-lock-free}@anchor{140}
+@anchor{gnat_rm/implementation_defined_aspects aspect-lock-free}@anchor{13d}
@section Aspect Lock_Free
@geindex Lock_Free
-This boolean aspect is equivalent to @ref{98,,pragma Lock_Free}.
+This boolean aspect is equivalent to @ref{95,,pragma Lock_Free}.
@node Aspect Max_Queue_Length,Aspect No_Caching,Aspect Lock_Free,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-max-queue-length}@anchor{141}
+@anchor{gnat_rm/implementation_defined_aspects aspect-max-queue-length}@anchor{13e}
@section Aspect Max_Queue_Length
@geindex Max_Queue_Length
-This aspect is equivalent to @ref{a0,,pragma Max_Queue_Length}.
+This aspect is equivalent to @ref{9d,,pragma Max_Queue_Length}.
@node Aspect No_Caching,Aspect No_Elaboration_Code_All,Aspect Max_Queue_Length,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-no-caching}@anchor{142}
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-caching}@anchor{13f}
@section Aspect No_Caching
@geindex No_Caching
-This boolean aspect is equivalent to @ref{a2,,pragma No_Caching}.
+This boolean aspect is equivalent to @ref{9f,,pragma No_Caching}.
@node Aspect No_Elaboration_Code_All,Aspect No_Inline,Aspect No_Caching,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-no-elaboration-code-all}@anchor{143}
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-elaboration-code-all}@anchor{140}
@section Aspect No_Elaboration_Code_All
@geindex No_Elaboration_Code_All
-This aspect is equivalent to @ref{a6,,pragma No_Elaboration_Code_All}
+This aspect is equivalent to @ref{a3,,pragma No_Elaboration_Code_All}
for a program unit.
@node Aspect No_Inline,Aspect No_Tagged_Streams,Aspect No_Elaboration_Code_All,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-no-inline}@anchor{144}
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-inline}@anchor{141}
@section Aspect No_Inline
@geindex No_Inline
-This boolean aspect is equivalent to @ref{a9,,pragma No_Inline}.
+This boolean aspect is equivalent to @ref{a6,,pragma No_Inline}.
@node Aspect No_Tagged_Streams,Aspect Object_Size,Aspect No_Inline,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{145}
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{142}
@section Aspect No_Tagged_Streams
@geindex No_Tagged_Streams
-This aspect is equivalent to @ref{ac,,pragma No_Tagged_Streams} with an
+This aspect is equivalent to @ref{a9,,pragma No_Tagged_Streams} with an
argument specifying a root tagged type (thus this aspect can only be
applied to such a type).
@node Aspect Object_Size,Aspect Obsolescent,Aspect No_Tagged_Streams,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{146}
+@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{143}
@section Aspect Object_Size
@geindex Object_Size
-This aspect is equivalent to @ref{147,,attribute Object_Size}.
+This aspect is equivalent to @ref{144,,attribute Object_Size}.
@node Aspect Obsolescent,Aspect Part_Of,Aspect Object_Size,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{148}
+@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{145}
@section Aspect Obsolescent
@geindex Obsolsecent
-This aspect is equivalent to @ref{af,,pragma Obsolescent}. Note that the
+This aspect is equivalent to @ref{ac,,pragma Obsolescent}. Note that the
evaluation of this aspect happens at the point of occurrence, it is not
delayed until the freeze point.
@node Aspect Part_Of,Aspect Persistent_BSS,Aspect Obsolescent,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-part-of}@anchor{149}
+@anchor{gnat_rm/implementation_defined_aspects aspect-part-of}@anchor{146}
@section Aspect Part_Of
@geindex Part_Of
-This aspect is equivalent to @ref{b7,,pragma Part_Of}.
+This aspect is equivalent to @ref{b4,,pragma Part_Of}.
@node Aspect Persistent_BSS,Aspect Predicate,Aspect Part_Of,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-persistent-bss}@anchor{14a}
+@anchor{gnat_rm/implementation_defined_aspects aspect-persistent-bss}@anchor{147}
@section Aspect Persistent_BSS
@geindex Persistent_BSS
-This boolean aspect is equivalent to @ref{ba,,pragma Persistent_BSS}.
+This boolean aspect is equivalent to @ref{b7,,pragma Persistent_BSS}.
@node Aspect Predicate,Aspect Pure_Function,Aspect Persistent_BSS,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{14b}
+@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{148}
@section Aspect Predicate
@geindex Predicate
-This aspect is equivalent to @ref{c2,,pragma Predicate}. It is thus
+This aspect is equivalent to @ref{bf,,pragma Predicate}. It is thus
similar to the language defined aspects @code{Dynamic_Predicate}
and @code{Static_Predicate} except that whether the resulting
predicate is static or dynamic is controlled by the form of the
@@ -9915,239 +9775,249 @@ expression. It is also separately controllable using pragma
@code{Assertion_Policy}.
@node Aspect Pure_Function,Aspect Refined_Depends,Aspect Predicate,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-pure-function}@anchor{14c}
+@anchor{gnat_rm/implementation_defined_aspects aspect-pure-function}@anchor{149}
@section Aspect Pure_Function
@geindex Pure_Function
-This boolean aspect is equivalent to @ref{ce,,pragma Pure_Function}.
+This boolean aspect is equivalent to @ref{cb,,pragma Pure_Function}.
@node Aspect Refined_Depends,Aspect Refined_Global,Aspect Pure_Function,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-refined-depends}@anchor{14d}
+@anchor{gnat_rm/implementation_defined_aspects aspect-refined-depends}@anchor{14a}
@section Aspect Refined_Depends
@geindex Refined_Depends
-This aspect is equivalent to @ref{d2,,pragma Refined_Depends}.
+This aspect is equivalent to @ref{cf,,pragma Refined_Depends}.
@node Aspect Refined_Global,Aspect Refined_Post,Aspect Refined_Depends,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-refined-global}@anchor{14e}
+@anchor{gnat_rm/implementation_defined_aspects aspect-refined-global}@anchor{14b}
@section Aspect Refined_Global
@geindex Refined_Global
-This aspect is equivalent to @ref{d4,,pragma Refined_Global}.
+This aspect is equivalent to @ref{d1,,pragma Refined_Global}.
@node Aspect Refined_Post,Aspect Refined_State,Aspect Refined_Global,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-refined-post}@anchor{14f}
+@anchor{gnat_rm/implementation_defined_aspects aspect-refined-post}@anchor{14c}
@section Aspect Refined_Post
@geindex Refined_Post
-This aspect is equivalent to @ref{d6,,pragma Refined_Post}.
+This aspect is equivalent to @ref{d3,,pragma Refined_Post}.
-@node Aspect Refined_State,Aspect Remote_Access_Type,Aspect Refined_Post,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{150}
+@node Aspect Refined_State,Aspect Relaxed_Initialization,Aspect Refined_Post,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{14d}
@section Aspect Refined_State
@geindex Refined_State
-This aspect is equivalent to @ref{d8,,pragma Refined_State}.
+This aspect is equivalent to @ref{d5,,pragma Refined_State}.
+
+@node Aspect Relaxed_Initialization,Aspect Remote_Access_Type,Aspect Refined_State,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-relaxed-initialization}@anchor{14e}
+@section Aspect Relaxed_Initialization
+
+
+@geindex Refined_Initialization
-@node Aspect Remote_Access_Type,Aspect Secondary_Stack_Size,Aspect Refined_State,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-remote-access-type}@anchor{151}
+For the syntax and semantics of this aspect, see the SPARK 2014 Reference
+Manual, section 6.10.
+
+@node Aspect Remote_Access_Type,Aspect Secondary_Stack_Size,Aspect Relaxed_Initialization,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-remote-access-type}@anchor{14f}
@section Aspect Remote_Access_Type
@geindex Remote_Access_Type
-This aspect is equivalent to @ref{dc,,pragma Remote_Access_Type}.
+This aspect is equivalent to @ref{d9,,pragma Remote_Access_Type}.
@node Aspect Secondary_Stack_Size,Aspect Scalar_Storage_Order,Aspect Remote_Access_Type,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-secondary-stack-size}@anchor{152}
+@anchor{gnat_rm/implementation_defined_aspects aspect-secondary-stack-size}@anchor{150}
@section Aspect Secondary_Stack_Size
@geindex Secondary_Stack_Size
-This aspect is equivalent to @ref{e1,,pragma Secondary_Stack_Size}.
+This aspect is equivalent to @ref{de,,pragma Secondary_Stack_Size}.
@node Aspect Scalar_Storage_Order,Aspect Shared,Aspect Secondary_Stack_Size,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-scalar-storage-order}@anchor{153}
+@anchor{gnat_rm/implementation_defined_aspects aspect-scalar-storage-order}@anchor{151}
@section Aspect Scalar_Storage_Order
@geindex Scalar_Storage_Order
-This aspect is equivalent to a @ref{154,,attribute Scalar_Storage_Order}.
+This aspect is equivalent to a @ref{152,,attribute Scalar_Storage_Order}.
@node Aspect Shared,Aspect Simple_Storage_Pool,Aspect Scalar_Storage_Order,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-shared}@anchor{155}
+@anchor{gnat_rm/implementation_defined_aspects aspect-shared}@anchor{153}
@section Aspect Shared
@geindex Shared
-This boolean aspect is equivalent to @ref{e4,,pragma Shared}
+This boolean aspect is equivalent to @ref{e1,,pragma Shared}
and is thus a synonym for aspect @code{Atomic}.
@node Aspect Simple_Storage_Pool,Aspect Simple_Storage_Pool_Type,Aspect Shared,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool}@anchor{156}
+@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool}@anchor{154}
@section Aspect Simple_Storage_Pool
@geindex Simple_Storage_Pool
-This aspect is equivalent to @ref{e9,,attribute Simple_Storage_Pool}.
+This aspect is equivalent to @ref{e6,,attribute Simple_Storage_Pool}.
@node Aspect Simple_Storage_Pool_Type,Aspect SPARK_Mode,Aspect Simple_Storage_Pool,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool-type}@anchor{157}
+@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool-type}@anchor{155}
@section Aspect Simple_Storage_Pool_Type
@geindex Simple_Storage_Pool_Type
-This boolean aspect is equivalent to @ref{e7,,pragma Simple_Storage_Pool_Type}.
+This boolean aspect is equivalent to @ref{e4,,pragma Simple_Storage_Pool_Type}.
@node Aspect SPARK_Mode,Aspect Suppress_Debug_Info,Aspect Simple_Storage_Pool_Type,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-spark-mode}@anchor{158}
+@anchor{gnat_rm/implementation_defined_aspects aspect-spark-mode}@anchor{156}
@section Aspect SPARK_Mode
@geindex SPARK_Mode
-This aspect is equivalent to @ref{ef,,pragma SPARK_Mode} and
+This aspect is equivalent to @ref{ec,,pragma SPARK_Mode} and
may be specified for either or both of the specification and body
of a subprogram or package.
@node Aspect Suppress_Debug_Info,Aspect Suppress_Initialization,Aspect SPARK_Mode,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-debug-info}@anchor{159}
+@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-debug-info}@anchor{157}
@section Aspect Suppress_Debug_Info
@geindex Suppress_Debug_Info
-This boolean aspect is equivalent to @ref{f7,,pragma Suppress_Debug_Info}.
+This boolean aspect is equivalent to @ref{f4,,pragma Suppress_Debug_Info}.
@node Aspect Suppress_Initialization,Aspect Test_Case,Aspect Suppress_Debug_Info,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-initialization}@anchor{15a}
+@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-initialization}@anchor{158}
@section Aspect Suppress_Initialization
@geindex Suppress_Initialization
-This boolean aspect is equivalent to @ref{fb,,pragma Suppress_Initialization}.
+This boolean aspect is equivalent to @ref{f8,,pragma Suppress_Initialization}.
@node Aspect Test_Case,Aspect Thread_Local_Storage,Aspect Suppress_Initialization,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-test-case}@anchor{15b}
+@anchor{gnat_rm/implementation_defined_aspects aspect-test-case}@anchor{159}
@section Aspect Test_Case
@geindex Test_Case
-This aspect is equivalent to @ref{fe,,pragma Test_Case}.
+This aspect is equivalent to @ref{fb,,pragma Test_Case}.
@node Aspect Thread_Local_Storage,Aspect Universal_Aliasing,Aspect Test_Case,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-thread-local-storage}@anchor{15c}
+@anchor{gnat_rm/implementation_defined_aspects aspect-thread-local-storage}@anchor{15a}
@section Aspect Thread_Local_Storage
@geindex Thread_Local_Storage
-This boolean aspect is equivalent to @ref{100,,pragma Thread_Local_Storage}.
+This boolean aspect is equivalent to @ref{fd,,pragma Thread_Local_Storage}.
@node Aspect Universal_Aliasing,Aspect Universal_Data,Aspect Thread_Local_Storage,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{15d}
+@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{15b}
@section Aspect Universal_Aliasing
@geindex Universal_Aliasing
-This boolean aspect is equivalent to @ref{10a,,pragma Universal_Aliasing}.
+This boolean aspect is equivalent to @ref{107,,pragma Universal_Aliasing}.
@node Aspect Universal_Data,Aspect Unmodified,Aspect Universal_Aliasing,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-universal-data}@anchor{15e}
+@anchor{gnat_rm/implementation_defined_aspects aspect-universal-data}@anchor{15c}
@section Aspect Universal_Data
@geindex Universal_Data
-This aspect is equivalent to @ref{10c,,pragma Universal_Data}.
+This aspect is equivalent to @ref{109,,pragma Universal_Data}.
@node Aspect Unmodified,Aspect Unreferenced,Aspect Universal_Data,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{15f}
+@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{15d}
@section Aspect Unmodified
@geindex Unmodified
-This boolean aspect is equivalent to @ref{10f,,pragma Unmodified}.
+This boolean aspect is equivalent to @ref{10c,,pragma Unmodified}.
@node Aspect Unreferenced,Aspect Unreferenced_Objects,Aspect Unmodified,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{160}
+@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{15e}
@section Aspect Unreferenced
@geindex Unreferenced
-This boolean aspect is equivalent to @ref{110,,pragma Unreferenced}. Note that
+This boolean aspect is equivalent to @ref{10d,,pragma Unreferenced}. Note that
in the case of formal parameters, it is not permitted to have aspects for
a formal parameter, so in this case the pragma form must be used.
@node Aspect Unreferenced_Objects,Aspect Value_Size,Aspect Unreferenced,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{161}
+@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{15f}
@section Aspect Unreferenced_Objects
@geindex Unreferenced_Objects
-This boolean aspect is equivalent to @ref{112,,pragma Unreferenced_Objects}.
+This boolean aspect is equivalent to @ref{10f,,pragma Unreferenced_Objects}.
@node Aspect Value_Size,Aspect Volatile_Full_Access,Aspect Unreferenced_Objects,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-value-size}@anchor{162}
+@anchor{gnat_rm/implementation_defined_aspects aspect-value-size}@anchor{160}
@section Aspect Value_Size
@geindex Value_Size
-This aspect is equivalent to @ref{163,,attribute Value_Size}.
+This aspect is equivalent to @ref{161,,attribute Value_Size}.
@node Aspect Volatile_Full_Access,Aspect Volatile_Function,Aspect Value_Size,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-full-access}@anchor{164}
+@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-full-access}@anchor{162}
@section Aspect Volatile_Full_Access
@geindex Volatile_Full_Access
-This boolean aspect is equivalent to @ref{11d,,pragma Volatile_Full_Access}.
+This boolean aspect is equivalent to @ref{11a,,pragma Volatile_Full_Access}.
@node Aspect Volatile_Function,Aspect Warnings,Aspect Volatile_Full_Access,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-function}@anchor{165}
+@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-function}@anchor{163}
@section Aspect Volatile_Function
@geindex Volatile_Function
-This boolean aspect is equivalent to @ref{11f,,pragma Volatile_Function}.
+This boolean aspect is equivalent to @ref{11c,,pragma Volatile_Function}.
@node Aspect Warnings,,Aspect Volatile_Function,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{166}
+@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{164}
@section Aspect Warnings
@geindex Warnings
-This aspect is equivalent to the two argument form of @ref{121,,pragma Warnings},
+This aspect is equivalent to the two argument form of @ref{11e,,pragma Warnings},
where the first argument is @code{ON} or @code{OFF} and the second argument
is the entity.
@node Implementation Defined Attributes,Standard and Implementation Defined Restrictions,Implementation Defined Aspects,Top
-@anchor{gnat_rm/implementation_defined_attributes doc}@anchor{167}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{168}
+@anchor{gnat_rm/implementation_defined_attributes doc}@anchor{165}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{166}
@chapter Implementation Defined Attributes
@@ -10201,6 +10071,7 @@ consideration, you should minimize the use of these attributes.
* Attribute Has_Access_Values::
* Attribute Has_Discriminants::
* Attribute Img::
+* Attribute Initialized::
* Attribute Integer_Value::
* Attribute Invalid_Value::
* Attribute Iterable::
@@ -10248,7 +10119,7 @@ consideration, you should minimize the use of these attributes.
@end menu
@node Attribute Abort_Signal,Attribute Address_Size,,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-abort-signal}@anchor{169}
+@anchor{gnat_rm/implementation_defined_attributes attribute-abort-signal}@anchor{167}
@section Attribute Abort_Signal
@@ -10262,7 +10133,7 @@ completely outside the normal semantics of Ada, for a user program to
intercept the abort exception).
@node Attribute Address_Size,Attribute Asm_Input,Attribute Abort_Signal,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-address-size}@anchor{16a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-address-size}@anchor{168}
@section Attribute Address_Size
@@ -10278,7 +10149,7 @@ reference to System.Address'Size is nonstatic because Address
is a private type.
@node Attribute Asm_Input,Attribute Asm_Output,Attribute Address_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-asm-input}@anchor{16b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-asm-input}@anchor{169}
@section Attribute Asm_Input
@@ -10292,10 +10163,10 @@ to be a static expression, and is the constraint for the parameter,
value to be used as the input argument. The possible values for the
constant are the same as those used in the RTL, and are dependent on
the configuration file used to built the GCC back end.
-@ref{16c,,Machine Code Insertions}
+@ref{16a,,Machine Code Insertions}
@node Attribute Asm_Output,Attribute Atomic_Always_Lock_Free,Attribute Asm_Input,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-asm-output}@anchor{16d}
+@anchor{gnat_rm/implementation_defined_attributes attribute-asm-output}@anchor{16b}
@section Attribute Asm_Output
@@ -10311,10 +10182,10 @@ result. The possible values for constraint are the same as those used in
the RTL, and are dependent on the configuration file used to build the
GCC back end. If there are no output operands, then this argument may
either be omitted, or explicitly given as @code{No_Output_Operands}.
-@ref{16c,,Machine Code Insertions}
+@ref{16a,,Machine Code Insertions}
@node Attribute Atomic_Always_Lock_Free,Attribute Bit,Attribute Asm_Output,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-atomic-always-lock-free}@anchor{16e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-atomic-always-lock-free}@anchor{16c}
@section Attribute Atomic_Always_Lock_Free
@@ -10326,7 +10197,7 @@ and False otherwise. The result indicate whether atomic operations are
supported by the target for the given type.
@node Attribute Bit,Attribute Bit_Position,Attribute Atomic_Always_Lock_Free,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{16f}
+@anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{16d}
@section Attribute Bit
@@ -10335,8 +10206,8 @@ supported by the target for the given type.
@code{obj'Bit}, where @code{obj} is any object, yields the bit
offset within the storage unit (byte) that contains the first bit of
storage allocated for the object. The value of this attribute is of the
-type @emph{universal_integer}, and is always a non-negative number not
-exceeding the value of @code{System.Storage_Unit}.
+type @emph{universal_integer} and is always a nonnegative number smaller
+than @code{System.Storage_Unit}.
For an object that is a variable or a constant allocated in a register,
the value is zero. (The use of this attribute does not force the
@@ -10357,7 +10228,7 @@ This attribute is designed to be compatible with the DEC Ada 83 definition
and implementation of the @code{Bit} attribute.
@node Attribute Bit_Position,Attribute Code_Address,Attribute Bit,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-bit-position}@anchor{170}
+@anchor{gnat_rm/implementation_defined_attributes attribute-bit-position}@anchor{16e}
@section Attribute Bit_Position
@@ -10372,7 +10243,7 @@ type @emph{universal_integer}. The value depends only on the field
the containing record @code{R}.
@node Attribute Code_Address,Attribute Compiler_Version,Attribute Bit_Position,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-code-address}@anchor{171}
+@anchor{gnat_rm/implementation_defined_attributes attribute-code-address}@anchor{16f}
@section Attribute Code_Address
@@ -10415,7 +10286,7 @@ the same value as is returned by the corresponding @code{'Address}
attribute.
@node Attribute Compiler_Version,Attribute Constrained,Attribute Code_Address,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-compiler-version}@anchor{172}
+@anchor{gnat_rm/implementation_defined_attributes attribute-compiler-version}@anchor{170}
@section Attribute Compiler_Version
@@ -10426,7 +10297,7 @@ prefix) yields a static string identifying the version of the compiler
being used to compile the unit containing the attribute reference.
@node Attribute Constrained,Attribute Default_Bit_Order,Attribute Compiler_Version,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-constrained}@anchor{173}
+@anchor{gnat_rm/implementation_defined_attributes attribute-constrained}@anchor{171}
@section Attribute Constrained
@@ -10441,7 +10312,7 @@ record type without discriminants is always @code{True}. This usage is
compatible with older Ada compilers, including notably DEC Ada.
@node Attribute Default_Bit_Order,Attribute Default_Scalar_Storage_Order,Attribute Constrained,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-default-bit-order}@anchor{174}
+@anchor{gnat_rm/implementation_defined_attributes attribute-default-bit-order}@anchor{172}
@section Attribute Default_Bit_Order
@@ -10458,7 +10329,7 @@ as a @code{Pos} value (0 for @code{High_Order_First}, 1 for
@code{Default_Bit_Order} in package @code{System}.
@node Attribute Default_Scalar_Storage_Order,Attribute Deref,Attribute Default_Bit_Order,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-default-scalar-storage-order}@anchor{175}
+@anchor{gnat_rm/implementation_defined_attributes attribute-default-scalar-storage-order}@anchor{173}
@section Attribute Default_Scalar_Storage_Order
@@ -10475,7 +10346,7 @@ equal to @code{Default_Bit_Order} if unspecified) as a
@code{System.Bit_Order} value. This is a static attribute.
@node Attribute Deref,Attribute Descriptor_Size,Attribute Default_Scalar_Storage_Order,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-deref}@anchor{176}
+@anchor{gnat_rm/implementation_defined_attributes attribute-deref}@anchor{174}
@section Attribute Deref
@@ -10488,7 +10359,7 @@ a named access-to-@cite{typ} type, except that it yields a variable, so it can b
used on the left side of an assignment.
@node Attribute Descriptor_Size,Attribute Elaborated,Attribute Deref,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-descriptor-size}@anchor{177}
+@anchor{gnat_rm/implementation_defined_attributes attribute-descriptor-size}@anchor{175}
@section Attribute Descriptor_Size
@@ -10505,17 +10376,19 @@ array descriptor contains bounds information and is located immediately before
the first element of the array.
@example
-type Unconstr_Array is array (Positive range <>) of Boolean;
+type Unconstr_Array is array (Short_Short_Integer range <>) of Positive;
Put_Line ("Descriptor size = " & Unconstr_Array'Descriptor_Size'Img);
@end example
-The attribute takes into account any additional padding due to type alignment.
-In the example above, the descriptor contains two values of type
-@code{Positive} representing the low and high bound. Since @code{Positive} has
-a size of 31 bits and an alignment of 4, the descriptor size is @code{2 * Positive'Size + 2} or 64 bits.
+The attribute takes into account any padding due to the alignment of the
+component type. In the example above, the descriptor contains two values
+of type @code{Short_Short_Integer} representing the low and high bound. But,
+since @code{Positive} has an alignment of 4, the size of the descriptor is
+@code{2 * Short_Short_Integer'Size} rounded up to the next multiple of 32,
+which yields a size of 32 bits, i.e. including 16 bits of padding.
@node Attribute Elaborated,Attribute Elab_Body,Attribute Descriptor_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-elaborated}@anchor{178}
+@anchor{gnat_rm/implementation_defined_attributes attribute-elaborated}@anchor{176}
@section Attribute Elaborated
@@ -10530,7 +10403,7 @@ units has been completed. An exception is for units which need no
elaboration, the value is always False for such units.
@node Attribute Elab_Body,Attribute Elab_Spec,Attribute Elaborated,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-elab-body}@anchor{179}
+@anchor{gnat_rm/implementation_defined_attributes attribute-elab-body}@anchor{177}
@section Attribute Elab_Body
@@ -10546,7 +10419,7 @@ e.g., if it is necessary to do selective re-elaboration to fix some
error.
@node Attribute Elab_Spec,Attribute Elab_Subp_Body,Attribute Elab_Body,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-elab-spec}@anchor{17a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-elab-spec}@anchor{178}
@section Attribute Elab_Spec
@@ -10562,7 +10435,7 @@ Ada code, e.g., if it is necessary to do selective re-elaboration to fix
some error.
@node Attribute Elab_Subp_Body,Attribute Emax,Attribute Elab_Spec,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-elab-subp-body}@anchor{17b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-elab-subp-body}@anchor{179}
@section Attribute Elab_Subp_Body
@@ -10576,7 +10449,7 @@ elaboration procedure by the binder in CodePeer mode only and is unrecognized
otherwise.
@node Attribute Emax,Attribute Enabled,Attribute Elab_Subp_Body,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-emax}@anchor{17c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-emax}@anchor{17a}
@section Attribute Emax
@@ -10589,7 +10462,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Enabled,Attribute Enum_Rep,Attribute Emax,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-enabled}@anchor{17d}
+@anchor{gnat_rm/implementation_defined_attributes attribute-enabled}@anchor{17b}
@section Attribute Enabled
@@ -10613,7 +10486,7 @@ a @code{pragma Suppress} or @code{pragma Unsuppress} before instantiating
the package or subprogram, controlling whether the check will be present.
@node Attribute Enum_Rep,Attribute Enum_Val,Attribute Enabled,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-enum-rep}@anchor{17e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-enum-rep}@anchor{17c}
@section Attribute Enum_Rep
@@ -10621,6 +10494,9 @@ the package or subprogram, controlling whether the check will be present.
@geindex Enum_Rep
+Note that this attribute is now standard in Ada 202x and is available
+as an implementation defined attribute for earlier Ada versions.
+
For every enumeration subtype @code{S}, @code{S'Enum_Rep} denotes a
function with the following spec:
@@ -10637,7 +10513,7 @@ enumeration literal or object.
The function returns the representation value for the given enumeration
value. This will be equal to value of the @code{Pos} attribute in the
absence of an enumeration representation clause. This is a static
-attribute (i.e.,:the result is static if the argument is static).
+attribute (i.e., the result is static if the argument is static).
@code{S'Enum_Rep} can also be used with integer types and objects,
in which case it simply returns the integer value. The reason for this
@@ -10650,7 +10526,7 @@ integer calculation is done at run time, then the call to @code{Enum_Rep}
may raise @code{Constraint_Error}.
@node Attribute Enum_Val,Attribute Epsilon,Attribute Enum_Rep,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-enum-val}@anchor{17f}
+@anchor{gnat_rm/implementation_defined_attributes attribute-enum-val}@anchor{17d}
@section Attribute Enum_Val
@@ -10658,6 +10534,9 @@ may raise @code{Constraint_Error}.
@geindex Enum_Val
+Note that this attribute is now standard in Ada 202x and is available
+as an implementation defined attribute for earlier Ada versions.
+
For every enumeration subtype @code{S}, @code{S'Enum_Val} denotes a
function with the following spec:
@@ -10673,7 +10552,7 @@ absence of an enumeration representation clause. This is a static
attribute (i.e., the result is static if the argument is static).
@node Attribute Epsilon,Attribute Fast_Math,Attribute Enum_Val,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-epsilon}@anchor{180}
+@anchor{gnat_rm/implementation_defined_attributes attribute-epsilon}@anchor{17e}
@section Attribute Epsilon
@@ -10686,7 +10565,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Fast_Math,Attribute Finalization_Size,Attribute Epsilon,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-fast-math}@anchor{181}
+@anchor{gnat_rm/implementation_defined_attributes attribute-fast-math}@anchor{17f}
@section Attribute Fast_Math
@@ -10697,7 +10576,7 @@ prefix) yields a static Boolean value that is True if pragma
@code{Fast_Math} is active, and False otherwise.
@node Attribute Finalization_Size,Attribute Fixed_Value,Attribute Fast_Math,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-finalization-size}@anchor{182}
+@anchor{gnat_rm/implementation_defined_attributes attribute-finalization-size}@anchor{180}
@section Attribute Finalization_Size
@@ -10715,7 +10594,7 @@ class-wide type whose tag denotes a type with no controlled parts.
Note that only heap-allocated objects contain finalization data.
@node Attribute Fixed_Value,Attribute From_Any,Attribute Finalization_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-fixed-value}@anchor{183}
+@anchor{gnat_rm/implementation_defined_attributes attribute-fixed-value}@anchor{181}
@section Attribute Fixed_Value
@@ -10742,7 +10621,7 @@ This attribute is primarily intended for use in implementation of the
input-output functions for fixed-point values.
@node Attribute From_Any,Attribute Has_Access_Values,Attribute Fixed_Value,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-from-any}@anchor{184}
+@anchor{gnat_rm/implementation_defined_attributes attribute-from-any}@anchor{182}
@section Attribute From_Any
@@ -10752,7 +10631,7 @@ This internal attribute is used for the generation of remote subprogram
stubs in the context of the Distributed Systems Annex.
@node Attribute Has_Access_Values,Attribute Has_Discriminants,Attribute From_Any,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-has-access-values}@anchor{185}
+@anchor{gnat_rm/implementation_defined_attributes attribute-has-access-values}@anchor{183}
@section Attribute Has_Access_Values
@@ -10770,7 +10649,7 @@ definitions. If the attribute is applied to a generic private type, it
indicates whether or not the corresponding actual type has access values.
@node Attribute Has_Discriminants,Attribute Img,Attribute Has_Access_Values,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{186}
+@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{184}
@section Attribute Has_Discriminants
@@ -10785,8 +10664,8 @@ otherwise. The intended use of this attribute is in conjunction with generic
definitions. If the attribute is applied to a generic private type, it
indicates whether or not the corresponding actual type has discriminants.
-@node Attribute Img,Attribute Integer_Value,Attribute Has_Discriminants,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{187}
+@node Attribute Img,Attribute Initialized,Attribute Has_Discriminants,Implementation Defined Attributes
+@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{185}
@section Attribute Img
@@ -10815,8 +10694,18 @@ that returns the appropriate string when called. This means that
@code{X'Img} can be renamed as a function-returning-string, or used
in an instantiation as a function parameter.
-@node Attribute Integer_Value,Attribute Invalid_Value,Attribute Img,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-integer-value}@anchor{188}
+@node Attribute Initialized,Attribute Integer_Value,Attribute Img,Implementation Defined Attributes
+@anchor{gnat_rm/implementation_defined_attributes attribute-initialized}@anchor{186}
+@section Attribute Initialized
+
+
+@geindex Initialized
+
+For the syntax and semantics of this attribute, see the SPARK 2014 Reference
+Manual, section 6.10.
+
+@node Attribute Integer_Value,Attribute Invalid_Value,Attribute Initialized,Implementation Defined Attributes
+@anchor{gnat_rm/implementation_defined_attributes attribute-integer-value}@anchor{187}
@section Attribute Integer_Value
@@ -10844,7 +10733,7 @@ This attribute is primarily intended for use in implementation of the
standard input-output functions for fixed-point values.
@node Attribute Invalid_Value,Attribute Iterable,Attribute Integer_Value,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{189}
+@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{188}
@section Attribute Invalid_Value
@@ -10858,7 +10747,7 @@ including the ability to modify the value with the binder -Sxx flag and
relevant environment variables at run time.
@node Attribute Iterable,Attribute Large,Attribute Invalid_Value,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-iterable}@anchor{18a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-iterable}@anchor{189}
@section Attribute Iterable
@@ -10867,7 +10756,7 @@ relevant environment variables at run time.
Equivalent to Aspect Iterable.
@node Attribute Large,Attribute Library_Level,Attribute Iterable,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{18b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{18a}
@section Attribute Large
@@ -10880,7 +10769,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Library_Level,Attribute Lock_Free,Attribute Large,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{18c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{18b}
@section Attribute Library_Level
@@ -10906,7 +10795,7 @@ end Gen;
@end example
@node Attribute Lock_Free,Attribute Loop_Entry,Attribute Library_Level,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-lock-free}@anchor{18d}
+@anchor{gnat_rm/implementation_defined_attributes attribute-lock-free}@anchor{18c}
@section Attribute Lock_Free
@@ -10916,7 +10805,7 @@ end Gen;
pragma @code{Lock_Free} applies to P.
@node Attribute Loop_Entry,Attribute Machine_Size,Attribute Lock_Free,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{18e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{18d}
@section Attribute Loop_Entry
@@ -10946,7 +10835,7 @@ entry. This copy is not performed if the loop is not entered, or if the
corresponding pragmas are ignored or disabled.
@node Attribute Machine_Size,Attribute Mantissa,Attribute Loop_Entry,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{18f}
+@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{18e}
@section Attribute Machine_Size
@@ -10956,7 +10845,7 @@ This attribute is identical to the @code{Object_Size} attribute. It is
provided for compatibility with the DEC Ada 83 attribute of this name.
@node Attribute Mantissa,Attribute Maximum_Alignment,Attribute Machine_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{190}
+@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{18f}
@section Attribute Mantissa
@@ -10969,7 +10858,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Maximum_Alignment,Attribute Mechanism_Code,Attribute Mantissa,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{191}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{192}
+@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{190}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{191}
@section Attribute Maximum_Alignment
@@ -10985,7 +10874,7 @@ for an object, guaranteeing that it is properly aligned in all
cases.
@node Attribute Mechanism_Code,Attribute Null_Parameter,Attribute Maximum_Alignment,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{193}
+@anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{192}
@section Attribute Mechanism_Code
@@ -11016,7 +10905,7 @@ by reference
@end table
@node Attribute Null_Parameter,Attribute Object_Size,Attribute Mechanism_Code,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-null-parameter}@anchor{194}
+@anchor{gnat_rm/implementation_defined_attributes attribute-null-parameter}@anchor{193}
@section Attribute Null_Parameter
@@ -11041,7 +10930,7 @@ There is no way of indicating this without the @code{Null_Parameter}
attribute.
@node Attribute Object_Size,Attribute Old,Attribute Null_Parameter,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{147}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{195}
+@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{144}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{194}
@section Attribute Object_Size
@@ -11111,7 +11000,7 @@ Similar additional checks are performed in other contexts requiring
statically matching subtypes.
@node Attribute Old,Attribute Passed_By_Reference,Attribute Object_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-old}@anchor{196}
+@anchor{gnat_rm/implementation_defined_attributes attribute-old}@anchor{195}
@section Attribute Old
@@ -11126,7 +11015,7 @@ definition are allowed under control of
implementation defined pragma @code{Unevaluated_Use_Of_Old}.
@node Attribute Passed_By_Reference,Attribute Pool_Address,Attribute Old,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-passed-by-reference}@anchor{197}
+@anchor{gnat_rm/implementation_defined_attributes attribute-passed-by-reference}@anchor{196}
@section Attribute Passed_By_Reference
@@ -11142,7 +11031,7 @@ passed by copy in calls. For scalar types, the result is always @code{False}
and is static. For non-scalar types, the result is nonstatic.
@node Attribute Pool_Address,Attribute Range_Length,Attribute Passed_By_Reference,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-pool-address}@anchor{198}
+@anchor{gnat_rm/implementation_defined_attributes attribute-pool-address}@anchor{197}
@section Attribute Pool_Address
@@ -11167,7 +11056,7 @@ For an object created by @code{new}, @code{Ptr.all'Pool_Address} is
what is passed to @code{Allocate} and returned from @code{Deallocate}.
@node Attribute Range_Length,Attribute Restriction_Set,Attribute Pool_Address,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-range-length}@anchor{199}
+@anchor{gnat_rm/implementation_defined_attributes attribute-range-length}@anchor{198}
@section Attribute Range_Length
@@ -11180,7 +11069,7 @@ applied to the index subtype of a one dimensional array always gives the
same result as @code{Length} applied to the array itself.
@node Attribute Restriction_Set,Attribute Result,Attribute Range_Length,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-restriction-set}@anchor{19a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-restriction-set}@anchor{199}
@section Attribute Restriction_Set
@@ -11250,7 +11139,7 @@ Restrictions pragma, they are not analyzed semantically,
so they do not have a type.
@node Attribute Result,Attribute Safe_Emax,Attribute Restriction_Set,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{19b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{19a}
@section Attribute Result
@@ -11263,7 +11152,7 @@ For a further discussion of the use of this attribute and examples of its use,
see the description of pragma Postcondition.
@node Attribute Safe_Emax,Attribute Safe_Large,Attribute Result,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{19c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{19b}
@section Attribute Safe_Emax
@@ -11276,7 +11165,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Safe_Large,Attribute Safe_Small,Attribute Safe_Emax,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-safe-large}@anchor{19d}
+@anchor{gnat_rm/implementation_defined_attributes attribute-safe-large}@anchor{19c}
@section Attribute Safe_Large
@@ -11289,7 +11178,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Safe_Small,Attribute Scalar_Storage_Order,Attribute Safe_Large,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-safe-small}@anchor{19e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-safe-small}@anchor{19d}
@section Attribute Safe_Small
@@ -11302,7 +11191,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Scalar_Storage_Order,Attribute Simple_Storage_Pool,Attribute Safe_Small,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{19f}@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{154}
+@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{19e}@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{152}
@section Attribute Scalar_Storage_Order
@@ -11425,7 +11314,7 @@ Note that debuggers may be unable to display the correct value of scalar
components of a type for which the opposite storage order is specified.
@node Attribute Simple_Storage_Pool,Attribute Small,Attribute Scalar_Storage_Order,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{e9}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{1a0}
+@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{e6}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{19f}
@section Attribute Simple_Storage_Pool
@@ -11488,7 +11377,7 @@ as defined in section 13.11.2 of the Ada Reference Manual, except that the
term @emph{simple storage pool} is substituted for @emph{storage pool}.
@node Attribute Small,Attribute Storage_Unit,Attribute Simple_Storage_Pool,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{1a1}
+@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{1a0}
@section Attribute Small
@@ -11504,7 +11393,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute when applied to floating-point types.
@node Attribute Storage_Unit,Attribute Stub_Type,Attribute Small,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{1a2}
+@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{1a1}
@section Attribute Storage_Unit
@@ -11514,7 +11403,7 @@ this attribute when applied to floating-point types.
prefix) provides the same value as @code{System.Storage_Unit}.
@node Attribute Stub_Type,Attribute System_Allocator_Alignment,Attribute Storage_Unit,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{1a3}
+@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{1a2}
@section Attribute Stub_Type
@@ -11538,7 +11427,7 @@ unit @code{System.Partition_Interface}. Use of this attribute will create
an implicit dependency on this unit.
@node Attribute System_Allocator_Alignment,Attribute Target_Name,Attribute Stub_Type,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{1a4}
+@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{1a3}
@section Attribute System_Allocator_Alignment
@@ -11555,7 +11444,7 @@ with alignment too large or to enable a realignment circuitry if the
alignment request is larger than this value.
@node Attribute Target_Name,Attribute To_Address,Attribute System_Allocator_Alignment,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{1a5}
+@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{1a4}
@section Attribute Target_Name
@@ -11568,7 +11457,7 @@ standard gcc target name without the terminating slash (for
example, GNAT 5.0 on windows yields "i586-pc-mingw32msv").
@node Attribute To_Address,Attribute To_Any,Attribute Target_Name,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{1a6}
+@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{1a5}
@section Attribute To_Address
@@ -11591,7 +11480,7 @@ modular manner (e.g., -1 means the same as 16#FFFF_FFFF# on
a 32 bits machine).
@node Attribute To_Any,Attribute Type_Class,Attribute To_Address,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{1a7}
+@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{1a6}
@section Attribute To_Any
@@ -11601,7 +11490,7 @@ This internal attribute is used for the generation of remote subprogram
stubs in the context of the Distributed Systems Annex.
@node Attribute Type_Class,Attribute Type_Key,Attribute To_Any,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{1a8}
+@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{1a7}
@section Attribute Type_Class
@@ -11631,7 +11520,7 @@ applies to all concurrent types. This attribute is designed to
be compatible with the DEC Ada 83 attribute of the same name.
@node Attribute Type_Key,Attribute TypeCode,Attribute Type_Class,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{1a9}
+@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{1a8}
@section Attribute Type_Key
@@ -11643,7 +11532,7 @@ about the type or subtype. This provides improved compatibility with
other implementations that support this attribute.
@node Attribute TypeCode,Attribute Unconstrained_Array,Attribute Type_Key,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{1aa}
+@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{1a9}
@section Attribute TypeCode
@@ -11653,7 +11542,7 @@ This internal attribute is used for the generation of remote subprogram
stubs in the context of the Distributed Systems Annex.
@node Attribute Unconstrained_Array,Attribute Universal_Literal_String,Attribute TypeCode,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{1ab}
+@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{1aa}
@section Attribute Unconstrained_Array
@@ -11667,7 +11556,7 @@ still static, and yields the result of applying this test to the
generic actual.
@node Attribute Universal_Literal_String,Attribute Unrestricted_Access,Attribute Unconstrained_Array,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{1ac}
+@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{1ab}
@section Attribute Universal_Literal_String
@@ -11695,7 +11584,7 @@ end;
@end example
@node Attribute Unrestricted_Access,Attribute Update,Attribute Universal_Literal_String,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{1ad}
+@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{1ac}
@section Attribute Unrestricted_Access
@@ -11882,7 +11771,7 @@ In general this is a risky approach. It may appear to "work" but such uses of
of GNAT to another, so are best avoided if possible.
@node Attribute Update,Attribute Valid_Scalars,Attribute Unrestricted_Access,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1ae}
+@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1ad}
@section Attribute Update
@@ -11963,7 +11852,7 @@ A := A'Update ((1, 2) => 20, (3, 4) => 30);
which changes element (1,2) to 20 and (3,4) to 30.
@node Attribute Valid_Scalars,Attribute VADS_Size,Attribute Update,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1af}
+@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1ae}
@section Attribute Valid_Scalars
@@ -11997,7 +11886,7 @@ write a function with a single use of the attribute, and then call that
function from multiple places.
@node Attribute VADS_Size,Attribute Value_Size,Attribute Valid_Scalars,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{1b0}
+@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{1af}
@section Attribute VADS_Size
@@ -12017,7 +11906,7 @@ gives the result that would be obtained by applying the attribute to
the corresponding type.
@node Attribute Value_Size,Attribute Wchar_T_Size,Attribute VADS_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1b1}@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{163}
+@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1b0}@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{161}
@section Attribute Value_Size
@@ -12031,7 +11920,7 @@ a value of the given subtype. It is the same as @code{type'Size},
but, unlike @code{Size}, may be set for non-first subtypes.
@node Attribute Wchar_T_Size,Attribute Word_Size,Attribute Value_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{1b2}
+@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{1b1}
@section Attribute Wchar_T_Size
@@ -12043,7 +11932,7 @@ primarily for constructing the definition of this type in
package @code{Interfaces.C}. The result is a static constant.
@node Attribute Word_Size,,Attribute Wchar_T_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{1b3}
+@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{1b2}
@section Attribute Word_Size
@@ -12054,7 +11943,7 @@ prefix) provides the value @code{System.Word_Size}. The result is
a static constant.
@node Standard and Implementation Defined Restrictions,Implementation Advice,Implementation Defined Attributes,Top
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9}@anchor{gnat_rm/standard_and_implementation_defined_restrictions doc}@anchor{1b4}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1b5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9}@anchor{gnat_rm/standard_and_implementation_defined_restrictions doc}@anchor{1b3}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1b4}
@chapter Standard and Implementation Defined Restrictions
@@ -12083,7 +11972,7 @@ language defined or GNAT-specific, are listed in the following.
@end menu
@node Partition-Wide Restrictions,Program Unit Level Restrictions,,Standard and Implementation Defined Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1b6}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{1b7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1b5}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{1b6}
@section Partition-Wide Restrictions
@@ -12172,7 +12061,7 @@ then all compilation units in the partition must obey the restriction).
@end menu
@node Immediate_Reclamation,Max_Asynchronous_Select_Nesting,,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{1b8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{1b7}
@subsection Immediate_Reclamation
@@ -12184,7 +12073,7 @@ deallocation, any storage reserved at run time for an object is
immediately reclaimed when the object no longer exists.
@node Max_Asynchronous_Select_Nesting,Max_Entry_Queue_Length,Immediate_Reclamation,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{1b9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{1b8}
@subsection Max_Asynchronous_Select_Nesting
@@ -12196,7 +12085,7 @@ detected at compile time. Violations of this restriction with values
other than zero cause Storage_Error to be raised.
@node Max_Entry_Queue_Length,Max_Protected_Entries,Max_Asynchronous_Select_Nesting,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{1ba}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{1b9}
@subsection Max_Entry_Queue_Length
@@ -12217,7 +12106,7 @@ compatibility purposes (and a warning will be generated for its use if
warnings on obsolescent features are activated).
@node Max_Protected_Entries,Max_Select_Alternatives,Max_Entry_Queue_Length,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{1bb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{1ba}
@subsection Max_Protected_Entries
@@ -12228,7 +12117,7 @@ bounds of every entry family of a protected unit shall be static, or shall be
defined by a discriminant of a subtype whose corresponding bound is static.
@node Max_Select_Alternatives,Max_Storage_At_Blocking,Max_Protected_Entries,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{1bc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{1bb}
@subsection Max_Select_Alternatives
@@ -12237,7 +12126,7 @@ defined by a discriminant of a subtype whose corresponding bound is static.
[RM D.7] Specifies the maximum number of alternatives in a selective accept.
@node Max_Storage_At_Blocking,Max_Task_Entries,Max_Select_Alternatives,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{1bd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{1bc}
@subsection Max_Storage_At_Blocking
@@ -12248,7 +12137,7 @@ Storage_Size that can be retained by a blocked task. A violation of this
restriction causes Storage_Error to be raised.
@node Max_Task_Entries,Max_Tasks,Max_Storage_At_Blocking,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{1be}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{1bd}
@subsection Max_Task_Entries
@@ -12261,7 +12150,7 @@ defined by a discriminant of a subtype whose
corresponding bound is static.
@node Max_Tasks,No_Abort_Statements,Max_Task_Entries,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{1bf}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{1be}
@subsection Max_Tasks
@@ -12274,7 +12163,7 @@ time. Violations of this restriction with values other than zero cause
Storage_Error to be raised.
@node No_Abort_Statements,No_Access_Parameter_Allocators,Max_Tasks,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{1c0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{1bf}
@subsection No_Abort_Statements
@@ -12284,7 +12173,7 @@ Storage_Error to be raised.
no calls to Task_Identification.Abort_Task.
@node No_Access_Parameter_Allocators,No_Access_Subprograms,No_Abort_Statements,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{1c1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{1c0}
@subsection No_Access_Parameter_Allocators
@@ -12295,7 +12184,7 @@ occurrences of an allocator as the actual parameter to an access
parameter.
@node No_Access_Subprograms,No_Allocators,No_Access_Parameter_Allocators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{1c2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{1c1}
@subsection No_Access_Subprograms
@@ -12305,7 +12194,7 @@ parameter.
declarations of access-to-subprogram types.
@node No_Allocators,No_Anonymous_Allocators,No_Access_Subprograms,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{1c3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{1c2}
@subsection No_Allocators
@@ -12315,7 +12204,7 @@ declarations of access-to-subprogram types.
occurrences of an allocator.
@node No_Anonymous_Allocators,No_Asynchronous_Control,No_Allocators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{1c4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{1c3}
@subsection No_Anonymous_Allocators
@@ -12325,7 +12214,7 @@ occurrences of an allocator.
occurrences of an allocator of anonymous access type.
@node No_Asynchronous_Control,No_Calendar,No_Anonymous_Allocators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{1c5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{1c4}
@subsection No_Asynchronous_Control
@@ -12335,7 +12224,7 @@ occurrences of an allocator of anonymous access type.
dependences on the predefined package Asynchronous_Task_Control.
@node No_Calendar,No_Coextensions,No_Asynchronous_Control,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{1c6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{1c5}
@subsection No_Calendar
@@ -12345,7 +12234,7 @@ dependences on the predefined package Asynchronous_Task_Control.
dependences on package Calendar.
@node No_Coextensions,No_Default_Initialization,No_Calendar,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{1c7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{1c6}
@subsection No_Coextensions
@@ -12355,7 +12244,7 @@ dependences on package Calendar.
coextensions. See 3.10.2.
@node No_Default_Initialization,No_Delay,No_Coextensions,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{1c8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{1c7}
@subsection No_Default_Initialization
@@ -12372,7 +12261,7 @@ is to prohibit all cases of variables declared without a specific
initializer (including the case of OUT scalar parameters).
@node No_Delay,No_Dependence,No_Default_Initialization,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{1c9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{1c8}
@subsection No_Delay
@@ -12382,7 +12271,7 @@ initializer (including the case of OUT scalar parameters).
delay statements and no semantic dependences on package Calendar.
@node No_Dependence,No_Direct_Boolean_Operators,No_Delay,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{1ca}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{1c9}
@subsection No_Dependence
@@ -12392,7 +12281,7 @@ delay statements and no semantic dependences on package Calendar.
dependences on a library unit.
@node No_Direct_Boolean_Operators,No_Dispatch,No_Dependence,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{1cb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{1ca}
@subsection No_Direct_Boolean_Operators
@@ -12405,7 +12294,7 @@ protocol requires the use of short-circuit (and then, or else) forms for all
composite boolean operations.
@node No_Dispatch,No_Dispatching_Calls,No_Direct_Boolean_Operators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{1cc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{1cb}
@subsection No_Dispatch
@@ -12415,7 +12304,7 @@ composite boolean operations.
occurrences of @code{T'Class}, for any (tagged) subtype @code{T}.
@node No_Dispatching_Calls,No_Dynamic_Attachment,No_Dispatch,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{1cd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{1cc}
@subsection No_Dispatching_Calls
@@ -12476,7 +12365,7 @@ end Example;
@end example
@node No_Dynamic_Attachment,No_Dynamic_Priorities,No_Dispatching_Calls,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{1ce}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{1cd}
@subsection No_Dynamic_Attachment
@@ -12495,7 +12384,7 @@ compatibility purposes (and a warning will be generated for its use if
warnings on obsolescent features are activated).
@node No_Dynamic_Priorities,No_Entry_Calls_In_Elaboration_Code,No_Dynamic_Attachment,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{1cf}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{1ce}
@subsection No_Dynamic_Priorities
@@ -12504,7 +12393,7 @@ warnings on obsolescent features are activated).
[RM D.7] There are no semantic dependencies on the package Dynamic_Priorities.
@node No_Entry_Calls_In_Elaboration_Code,No_Enumeration_Maps,No_Dynamic_Priorities,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{1d0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{1cf}
@subsection No_Entry_Calls_In_Elaboration_Code
@@ -12516,7 +12405,7 @@ restriction, the compiler can assume that no code past an accept statement
in a task can be executed at elaboration time.
@node No_Enumeration_Maps,No_Exception_Handlers,No_Entry_Calls_In_Elaboration_Code,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{1d1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{1d0}
@subsection No_Enumeration_Maps
@@ -12527,7 +12416,7 @@ enumeration maps are used (that is Image and Value attributes applied
to enumeration types).
@node No_Exception_Handlers,No_Exception_Propagation,No_Enumeration_Maps,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{1d2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{1d1}
@subsection No_Exception_Handlers
@@ -12552,7 +12441,7 @@ statement generated by the compiler). The Line parameter when nonzero
represents the line number in the source program where the raise occurs.
@node No_Exception_Propagation,No_Exception_Registration,No_Exception_Handlers,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{1d3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{1d2}
@subsection No_Exception_Propagation
@@ -12569,7 +12458,7 @@ the package GNAT.Current_Exception is not permitted, and reraise
statements (raise with no operand) are not permitted.
@node No_Exception_Registration,No_Exceptions,No_Exception_Propagation,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{1d4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{1d3}
@subsection No_Exception_Registration
@@ -12583,7 +12472,7 @@ code is simplified by omitting the otherwise-required global registration
of exceptions when they are declared.
@node No_Exceptions,No_Finalization,No_Exception_Registration,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{1d5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{1d4}
@subsection No_Exceptions
@@ -12594,7 +12483,7 @@ raise statements and no exception handlers and also suppresses the
generation of language-defined run-time checks.
@node No_Finalization,No_Fixed_Point,No_Exceptions,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{1d6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{1d5}
@subsection No_Finalization
@@ -12635,7 +12524,7 @@ object or a nested component, either declared on the stack or on the heap. The
deallocation of a controlled object no longer finalizes its contents.
@node No_Fixed_Point,No_Floating_Point,No_Finalization,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{1d7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{1d6}
@subsection No_Fixed_Point
@@ -12645,7 +12534,7 @@ deallocation of a controlled object no longer finalizes its contents.
occurrences of fixed point types and operations.
@node No_Floating_Point,No_Implicit_Conditionals,No_Fixed_Point,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{1d8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{1d7}
@subsection No_Floating_Point
@@ -12655,7 +12544,7 @@ occurrences of fixed point types and operations.
occurrences of floating point types and operations.
@node No_Implicit_Conditionals,No_Implicit_Dynamic_Code,No_Floating_Point,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{1d9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{1d8}
@subsection No_Implicit_Conditionals
@@ -12671,7 +12560,7 @@ normal manner. Constructs generating implicit conditionals include comparisons
of composite objects and the Max/Min attributes.
@node No_Implicit_Dynamic_Code,No_Implicit_Heap_Allocations,No_Implicit_Conditionals,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{1da}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{1d9}
@subsection No_Implicit_Dynamic_Code
@@ -12701,7 +12590,7 @@ foreign-language convention; primitive operations of nested tagged
types.
@node No_Implicit_Heap_Allocations,No_Implicit_Protected_Object_Allocations,No_Implicit_Dynamic_Code,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{1db}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{1da}
@subsection No_Implicit_Heap_Allocations
@@ -12710,7 +12599,7 @@ types.
[RM D.7] No constructs are allowed to cause implicit heap allocation.
@node No_Implicit_Protected_Object_Allocations,No_Implicit_Task_Allocations,No_Implicit_Heap_Allocations,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{1dc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{1db}
@subsection No_Implicit_Protected_Object_Allocations
@@ -12720,7 +12609,7 @@ types.
protected object.
@node No_Implicit_Task_Allocations,No_Initialize_Scalars,No_Implicit_Protected_Object_Allocations,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{1dd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{1dc}
@subsection No_Implicit_Task_Allocations
@@ -12729,7 +12618,7 @@ protected object.
[GNAT] No constructs are allowed to cause implicit heap allocation of a task.
@node No_Initialize_Scalars,No_IO,No_Implicit_Task_Allocations,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{1de}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{1dd}
@subsection No_Initialize_Scalars
@@ -12741,7 +12630,7 @@ code, and in particular eliminates dummy null initialization routines that
are otherwise generated for some record and array types.
@node No_IO,No_Local_Allocators,No_Initialize_Scalars,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{1df}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{1de}
@subsection No_IO
@@ -12752,7 +12641,7 @@ dependences on any of the library units Sequential_IO, Direct_IO,
Text_IO, Wide_Text_IO, Wide_Wide_Text_IO, or Stream_IO.
@node No_Local_Allocators,No_Local_Protected_Objects,No_IO,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{1e0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{1df}
@subsection No_Local_Allocators
@@ -12763,7 +12652,7 @@ occurrences of an allocator in subprograms, generic subprograms, tasks,
and entry bodies.
@node No_Local_Protected_Objects,No_Local_Timing_Events,No_Local_Allocators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{1e1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{1e0}
@subsection No_Local_Protected_Objects
@@ -12773,7 +12662,7 @@ and entry bodies.
only declared at the library level.
@node No_Local_Timing_Events,No_Long_Long_Integers,No_Local_Protected_Objects,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{1e2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{1e1}
@subsection No_Local_Timing_Events
@@ -12783,7 +12672,7 @@ only declared at the library level.
declared at the library level.
@node No_Long_Long_Integers,No_Multiple_Elaboration,No_Local_Timing_Events,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-long-long-integers}@anchor{1e3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-long-long-integers}@anchor{1e2}
@subsection No_Long_Long_Integers
@@ -12795,7 +12684,7 @@ implicit base type is Long_Long_Integer, and modular types whose size exceeds
Long_Integer'Size.
@node No_Multiple_Elaboration,No_Nested_Finalization,No_Long_Long_Integers,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{1e4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{1e3}
@subsection No_Multiple_Elaboration
@@ -12811,7 +12700,7 @@ possible, including non-Ada main programs and Stand Alone libraries, are not
permitted and will be diagnosed by the binder.
@node No_Nested_Finalization,No_Protected_Type_Allocators,No_Multiple_Elaboration,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{1e5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{1e4}
@subsection No_Nested_Finalization
@@ -12820,7 +12709,7 @@ permitted and will be diagnosed by the binder.
[RM D.7] All objects requiring finalization are declared at the library level.
@node No_Protected_Type_Allocators,No_Protected_Types,No_Nested_Finalization,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-type-allocators}@anchor{1e6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-type-allocators}@anchor{1e5}
@subsection No_Protected_Type_Allocators
@@ -12830,7 +12719,7 @@ permitted and will be diagnosed by the binder.
expressions that attempt to allocate protected objects.
@node No_Protected_Types,No_Recursion,No_Protected_Type_Allocators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-types}@anchor{1e7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-types}@anchor{1e6}
@subsection No_Protected_Types
@@ -12840,7 +12729,7 @@ expressions that attempt to allocate protected objects.
declarations of protected types or protected objects.
@node No_Recursion,No_Reentrancy,No_Protected_Types,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-recursion}@anchor{1e8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-recursion}@anchor{1e7}
@subsection No_Recursion
@@ -12850,7 +12739,7 @@ declarations of protected types or protected objects.
part of its execution.
@node No_Reentrancy,No_Relative_Delay,No_Recursion,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-reentrancy}@anchor{1e9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-reentrancy}@anchor{1e8}
@subsection No_Reentrancy
@@ -12860,7 +12749,7 @@ part of its execution.
two tasks at the same time.
@node No_Relative_Delay,No_Requeue_Statements,No_Reentrancy,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-relative-delay}@anchor{1ea}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-relative-delay}@anchor{1e9}
@subsection No_Relative_Delay
@@ -12871,7 +12760,7 @@ relative statements and prevents expressions such as @code{delay 1.23;} from
appearing in source code.
@node No_Requeue_Statements,No_Secondary_Stack,No_Relative_Delay,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-requeue-statements}@anchor{1eb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-requeue-statements}@anchor{1ea}
@subsection No_Requeue_Statements
@@ -12889,7 +12778,7 @@ compatibility purposes (and a warning will be generated for its use if
warnings on oNobsolescent features are activated).
@node No_Secondary_Stack,No_Select_Statements,No_Requeue_Statements,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-secondary-stack}@anchor{1ec}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-secondary-stack}@anchor{1eb}
@subsection No_Secondary_Stack
@@ -12902,7 +12791,7 @@ stack is used to implement functions returning unconstrained objects
secondary stacks for tasks (excluding the environment task) at run time.
@node No_Select_Statements,No_Specific_Termination_Handlers,No_Secondary_Stack,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-select-statements}@anchor{1ed}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-select-statements}@anchor{1ec}
@subsection No_Select_Statements
@@ -12912,7 +12801,7 @@ secondary stacks for tasks (excluding the environment task) at run time.
kind are permitted, that is the keyword @code{select} may not appear.
@node No_Specific_Termination_Handlers,No_Specification_of_Aspect,No_Select_Statements,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specific-termination-handlers}@anchor{1ee}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specific-termination-handlers}@anchor{1ed}
@subsection No_Specific_Termination_Handlers
@@ -12922,7 +12811,7 @@ kind are permitted, that is the keyword @code{select} may not appear.
or to Ada.Task_Termination.Specific_Handler.
@node No_Specification_of_Aspect,No_Standard_Allocators_After_Elaboration,No_Specific_Termination_Handlers,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specification-of-aspect}@anchor{1ef}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specification-of-aspect}@anchor{1ee}
@subsection No_Specification_of_Aspect
@@ -12933,7 +12822,7 @@ specification, attribute definition clause, or pragma is given for a
given aspect.
@node No_Standard_Allocators_After_Elaboration,No_Standard_Storage_Pools,No_Specification_of_Aspect,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-allocators-after-elaboration}@anchor{1f0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-allocators-after-elaboration}@anchor{1ef}
@subsection No_Standard_Allocators_After_Elaboration
@@ -12945,7 +12834,7 @@ library items of the partition has completed. Otherwise, Storage_Error
is raised.
@node No_Standard_Storage_Pools,No_Stream_Optimizations,No_Standard_Allocators_After_Elaboration,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-storage-pools}@anchor{1f1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-storage-pools}@anchor{1f0}
@subsection No_Standard_Storage_Pools
@@ -12957,7 +12846,7 @@ have an explicit Storage_Pool attribute defined specifying a
user-defined storage pool.
@node No_Stream_Optimizations,No_Streams,No_Standard_Storage_Pools,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-stream-optimizations}@anchor{1f2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-stream-optimizations}@anchor{1f1}
@subsection No_Stream_Optimizations
@@ -12970,7 +12859,7 @@ due to their superior performance. When this restriction is in effect, the
compiler performs all IO operations on a per-character basis.
@node No_Streams,No_Task_Allocators,No_Stream_Optimizations,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{1f3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{1f2}
@subsection No_Streams
@@ -12991,7 +12880,7 @@ unit declaring a tagged type should be compiled with the restriction,
though this is not required.
@node No_Task_Allocators,No_Task_At_Interrupt_Priority,No_Streams,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{1f4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{1f3}
@subsection No_Task_Allocators
@@ -13001,7 +12890,7 @@ though this is not required.
or types containing task subcomponents.
@node No_Task_At_Interrupt_Priority,No_Task_Attributes_Package,No_Task_Allocators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-at-interrupt-priority}@anchor{1f5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-at-interrupt-priority}@anchor{1f4}
@subsection No_Task_At_Interrupt_Priority
@@ -13013,7 +12902,7 @@ a consequence, the tasks are always created with a priority below
that an interrupt priority.
@node No_Task_Attributes_Package,No_Task_Hierarchy,No_Task_At_Interrupt_Priority,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{1f6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{1f5}
@subsection No_Task_Attributes_Package
@@ -13030,7 +12919,7 @@ compatibility purposes (and a warning will be generated for its use if
warnings on obsolescent features are activated).
@node No_Task_Hierarchy,No_Task_Termination,No_Task_Attributes_Package,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{1f7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{1f6}
@subsection No_Task_Hierarchy
@@ -13040,7 +12929,7 @@ warnings on obsolescent features are activated).
directly on the environment task of the partition.
@node No_Task_Termination,No_Tasking,No_Task_Hierarchy,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{1f8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{1f7}
@subsection No_Task_Termination
@@ -13049,7 +12938,7 @@ directly on the environment task of the partition.
[RM D.7] Tasks that terminate are erroneous.
@node No_Tasking,No_Terminate_Alternatives,No_Task_Termination,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{1f9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{1f8}
@subsection No_Tasking
@@ -13062,7 +12951,7 @@ and cause an error message to be output either by the compiler or
binder.
@node No_Terminate_Alternatives,No_Unchecked_Access,No_Tasking,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{1fa}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{1f9}
@subsection No_Terminate_Alternatives
@@ -13071,7 +12960,7 @@ binder.
[RM D.7] There are no selective accepts with terminate alternatives.
@node No_Unchecked_Access,No_Unchecked_Conversion,No_Terminate_Alternatives,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{1fb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{1fa}
@subsection No_Unchecked_Access
@@ -13081,7 +12970,7 @@ binder.
occurrences of the Unchecked_Access attribute.
@node No_Unchecked_Conversion,No_Unchecked_Deallocation,No_Unchecked_Access,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-conversion}@anchor{1fc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-conversion}@anchor{1fb}
@subsection No_Unchecked_Conversion
@@ -13091,7 +12980,7 @@ occurrences of the Unchecked_Access attribute.
dependences on the predefined generic function Unchecked_Conversion.
@node No_Unchecked_Deallocation,No_Use_Of_Entity,No_Unchecked_Conversion,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{1fd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{1fc}
@subsection No_Unchecked_Deallocation
@@ -13101,7 +12990,7 @@ dependences on the predefined generic function Unchecked_Conversion.
dependences on the predefined generic procedure Unchecked_Deallocation.
@node No_Use_Of_Entity,Pure_Barriers,No_Unchecked_Deallocation,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{1fe}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{1fd}
@subsection No_Use_Of_Entity
@@ -13121,7 +13010,7 @@ No_Use_Of_Entity => Ada.Text_IO.Put_Line
@end example
@node Pure_Barriers,Simple_Barriers,No_Use_Of_Entity,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{1ff}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{1fe}
@subsection Pure_Barriers
@@ -13172,7 +13061,7 @@ but still ensures absence of side effects, exceptions, and recursion
during the evaluation of the barriers.
@node Simple_Barriers,Static_Priorities,Pure_Barriers,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{200}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{1ff}
@subsection Simple_Barriers
@@ -13191,7 +13080,7 @@ compatibility purposes (and a warning will be generated for its use if
warnings on obsolescent features are activated).
@node Static_Priorities,Static_Storage_Size,Simple_Barriers,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{201}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{200}
@subsection Static_Priorities
@@ -13202,7 +13091,7 @@ are static, and that there are no dependences on the package
@code{Ada.Dynamic_Priorities}.
@node Static_Storage_Size,,Static_Priorities,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{202}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{201}
@subsection Static_Storage_Size
@@ -13212,7 +13101,7 @@ are static, and that there are no dependences on the package
in a Storage_Size pragma or attribute definition clause is static.
@node Program Unit Level Restrictions,,Partition-Wide Restrictions,Standard and Implementation Defined Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{203}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{204}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{202}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{203}
@section Program Unit Level Restrictions
@@ -13242,7 +13131,7 @@ other compilation units in the partition.
@end menu
@node No_Elaboration_Code,No_Dynamic_Sized_Objects,,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{205}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{204}
@subsection No_Elaboration_Code
@@ -13298,7 +13187,7 @@ associated with the unit. This counter is typically used to check for access
before elaboration and to control multiple elaboration attempts.
@node No_Dynamic_Sized_Objects,No_Entry_Queue,No_Elaboration_Code,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-sized-objects}@anchor{206}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-sized-objects}@anchor{205}
@subsection No_Dynamic_Sized_Objects
@@ -13316,7 +13205,7 @@ access discriminants. It is often a good idea to combine this restriction
with No_Secondary_Stack.
@node No_Entry_Queue,No_Implementation_Aspect_Specifications,No_Dynamic_Sized_Objects,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{207}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{206}
@subsection No_Entry_Queue
@@ -13329,7 +13218,7 @@ checked at compile time. A program execution is erroneous if an attempt
is made to queue a second task on such an entry.
@node No_Implementation_Aspect_Specifications,No_Implementation_Attributes,No_Entry_Queue,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{208}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{207}
@subsection No_Implementation_Aspect_Specifications
@@ -13340,7 +13229,7 @@ GNAT-defined aspects are present. With this restriction, the only
aspects that can be used are those defined in the Ada Reference Manual.
@node No_Implementation_Attributes,No_Implementation_Identifiers,No_Implementation_Aspect_Specifications,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{209}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{208}
@subsection No_Implementation_Attributes
@@ -13352,7 +13241,7 @@ attributes that can be used are those defined in the Ada Reference
Manual.
@node No_Implementation_Identifiers,No_Implementation_Pragmas,No_Implementation_Attributes,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{20a}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{209}
@subsection No_Implementation_Identifiers
@@ -13363,7 +13252,7 @@ implementation-defined identifiers (marked with pragma Implementation_Defined)
occur within language-defined packages.
@node No_Implementation_Pragmas,No_Implementation_Restrictions,No_Implementation_Identifiers,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{20b}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{20a}
@subsection No_Implementation_Pragmas
@@ -13374,7 +13263,7 @@ GNAT-defined pragmas are present. With this restriction, the only
pragmas that can be used are those defined in the Ada Reference Manual.
@node No_Implementation_Restrictions,No_Implementation_Units,No_Implementation_Pragmas,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{20c}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{20b}
@subsection No_Implementation_Restrictions
@@ -13386,7 +13275,7 @@ are present. With this restriction, the only other restriction identifiers
that can be used are those defined in the Ada Reference Manual.
@node No_Implementation_Units,No_Implicit_Aliasing,No_Implementation_Restrictions,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{20d}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{20c}
@subsection No_Implementation_Units
@@ -13397,7 +13286,7 @@ mention in the context clause of any implementation-defined descendants
of packages Ada, Interfaces, or System.
@node No_Implicit_Aliasing,No_Implicit_Loops,No_Implementation_Units,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{20e}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{20d}
@subsection No_Implicit_Aliasing
@@ -13412,7 +13301,7 @@ to be aliased, and in such cases, it can always be replaced by
the standard attribute Unchecked_Access which is preferable.
@node No_Implicit_Loops,No_Obsolescent_Features,No_Implicit_Aliasing,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{20f}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{20e}
@subsection No_Implicit_Loops
@@ -13429,7 +13318,7 @@ arrays larger than about 5000 scalar components. Note that if this restriction
is set in the spec of a package, it will not apply to its body.
@node No_Obsolescent_Features,No_Wide_Characters,No_Implicit_Loops,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{210}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{20f}
@subsection No_Obsolescent_Features
@@ -13439,7 +13328,7 @@ is set in the spec of a package, it will not apply to its body.
features are used, as defined in Annex J of the Ada Reference Manual.
@node No_Wide_Characters,Static_Dispatch_Tables,No_Obsolescent_Features,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{211}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{210}
@subsection No_Wide_Characters
@@ -13453,7 +13342,7 @@ appear in the program (that is literals representing characters not in
type @code{Character}).
@node Static_Dispatch_Tables,SPARK_05,No_Wide_Characters,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-dispatch-tables}@anchor{212}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-dispatch-tables}@anchor{211}
@subsection Static_Dispatch_Tables
@@ -13463,14 +13352,13 @@ type @code{Character}).
associated with dispatch tables can be placed in read-only memory.
@node SPARK_05,,Static_Dispatch_Tables,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{213}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{212}
@subsection SPARK_05
@geindex SPARK_05
-[GNAT] This restriction checks at compile time that some constructs forbidden
-in SPARK 2005 are not present. Note that SPARK 2005 has been superseded by
+[GNAT] This restriction no longer has any effect and is superseded by
SPARK 2014, whose restrictions are checked by the tool GNATprove. To check that
a codebase respects SPARK 2014 restrictions, mark the code with pragma or
aspect @code{SPARK_Mode}, and run the tool GNATprove at Stone assurance level, as
@@ -13486,358 +13374,8 @@ or equivalently:
gnatprove -P project.gpr --mode=check_all
@end example
-With restriction @code{SPARK_05}, error messages related to SPARK 2005 restriction
-have the form:
-
-@example
-violation of restriction "SPARK_05" at <source-location>
- <error message>
-@end example
-
-@geindex SPARK
-
-The restriction @code{SPARK} is recognized as a synonym for @code{SPARK_05}. This is
-retained for historical compatibility purposes (and an unconditional warning
-will be generated for its use, advising replacement by @code{SPARK_05}).
-
-This is not a replacement for the semantic checks performed by the
-SPARK Examiner tool, as the compiler currently only deals with code,
-not SPARK 2005 annotations, and does not guarantee catching all
-cases of constructs forbidden by SPARK 2005.
-
-Thus it may well be the case that code which passes the compiler with
-the SPARK 2005 restriction is rejected by the SPARK Examiner, e.g. due to
-the different visibility rules of the Examiner based on SPARK 2005
-@code{inherit} annotations.
-
-This restriction can be useful in providing an initial filter for code
-developed using SPARK 2005, or in examining legacy code to see how far
-it is from meeting SPARK 2005 restrictions.
-
-The list below summarizes the checks that are performed when this
-restriction is in force:
-
-
-@itemize *
-
-@item
-No block statements
-
-@item
-No case statements with only an others clause
-
-@item
-Exit statements in loops must respect the SPARK 2005 language restrictions
-
-@item
-No goto statements
-
-@item
-Return can only appear as last statement in function
-
-@item
-Function must have return statement
-
-@item
-Loop parameter specification must include subtype mark
-
-@item
-Prefix of expanded name cannot be a loop statement
-
-@item
-Abstract subprogram not allowed
-
-@item
-User-defined operators not allowed
-
-@item
-Access type parameters not allowed
-
-@item
-Default expressions for parameters not allowed
-
-@item
-Default expressions for record fields not allowed
-
-@item
-No tasking constructs allowed
-
-@item
-Label needed at end of subprograms and packages
-
-@item
-No mixing of positional and named parameter association
-
-@item
-No access types as result type
-
-@item
-No unconstrained arrays as result types
-
-@item
-No null procedures
-
-@item
-Initial and later declarations must be in correct order (declaration can't come after body)
-
-@item
-No attributes on private types if full declaration not visible
-
-@item
-No package declaration within package specification
-
-@item
-No controlled types
-
-@item
-No discriminant types
-
-@item
-No overloading
-
-@item
-Selector name cannot be operator symbol (i.e. operator symbol cannot be prefixed)
-
-@item
-Access attribute not allowed
-
-@item
-Allocator not allowed
-
-@item
-Result of catenation must be String
-
-@item
-Operands of catenation must be string literal, static char or another catenation
-
-@item
-No conditional expressions
-
-@item
-No explicit dereference
-
-@item
-Quantified expression not allowed
-
-@item
-Slicing not allowed
-
-@item
-No exception renaming
-
-@item
-No generic renaming
-
-@item
-No object renaming
-
-@item
-No use clause
-
-@item
-Aggregates must be qualified
-
-@item
-Nonstatic choice in array aggregates not allowed
-
-@item
-The only view conversions which are allowed as in-out parameters are conversions of a tagged type to an ancestor type
-
-@item
-No mixing of positional and named association in aggregate, no multi choice
-
-@item
-AND, OR and XOR for arrays only allowed when operands have same static bounds
-
-@item
-Fixed point operands to * or / must be qualified or converted
-
-@item
-Comparison operators not allowed for Booleans or arrays (except strings)
-
-@item
-Equality not allowed for arrays with non-matching static bounds (except strings)
-
-@item
-Conversion / qualification not allowed for arrays with non-matching static bounds
-
-@item
-Subprogram declaration only allowed in package spec (unless followed by import)
-
-@item
-Access types not allowed
-
-@item
-Incomplete type declaration not allowed
-
-@item
-Object and subtype declarations must respect SPARK 2005 restrictions
-
-@item
-Digits or delta constraint not allowed
-
-@item
-Decimal fixed point type not allowed
-
-@item
-Aliasing of objects not allowed
-
-@item
-Modular type modulus must be power of 2
-
-@item
-Base not allowed on subtype mark
-
-@item
-Unary operators not allowed on modular types (except not)
-
-@item
-Untagged record cannot be null
-
-@item
-No class-wide operations
-
-@item
-Initialization expressions must respect SPARK 2005 restrictions
-
-@item
-Nonstatic ranges not allowed except in iteration schemes
-
-@item
-String subtypes must have lower bound of 1
-
-@item
-Subtype of Boolean cannot have constraint
-
-@item
-At most one tagged type or extension per package
-
-@item
-Interface is not allowed
-
-@item
-Character literal cannot be prefixed (selector name cannot be character literal)
-
-@item
-Record aggregate cannot contain 'others'
-
-@item
-Component association in record aggregate must contain a single choice
-
-@item
-Ancestor part cannot be a type mark
-
-@item
-Attributes 'Image, 'Width and 'Value not allowed
-
-@item
-Functions may not update globals
-
-@item
-Subprograms may not contain direct calls to themselves (prevents recursion within unit)
-
-@item
-Call to subprogram not allowed in same unit before body has been seen (prevents recursion within unit)
-@end itemize
-
-The following restrictions are enforced, but note that they are actually more
-strict that the latest SPARK 2005 language definition:
-
-
-@itemize *
-
-@item
-No derived types other than tagged type extensions
-
-@item
-Subtype of unconstrained array must have constraint
-@end itemize
-
-This list summarises the main SPARK 2005 language rules that are not
-currently checked by the SPARK_05 restriction:
-
-
-@itemize *
-
-@item
-SPARK 2005 annotations are treated as comments so are not checked at all
-
-@item
-Based real literals not allowed
-
-@item
-Objects cannot be initialized at declaration by calls to user-defined functions
-
-@item
-Objects cannot be initialized at declaration by assignments from variables
-
-@item
-Objects cannot be initialized at declaration by assignments from indexed/selected components
-
-@item
-Ranges shall not be null
-
-@item
-A fixed point delta expression must be a simple expression
-
-@item
-Restrictions on where renaming declarations may be placed
-
-@item
-Externals of mode 'out' cannot be referenced
-
-@item
-Externals of mode 'in' cannot be updated
-
-@item
-Loop with no iteration scheme or exits only allowed as last statement in main program or task
-
-@item
-Subprogram cannot have parent unit name
-
-@item
-SPARK 2005 inherited subprogram must be prefixed with overriding
-
-@item
-External variables (or functions that reference them) may not be passed as actual parameters
-
-@item
-Globals must be explicitly mentioned in contract
-
-@item
-Deferred constants cannot be completed by pragma Import
-
-@item
-Package initialization cannot read/write variables from other packages
-
-@item
-Prefix not allowed for entities that are directly visible
-
-@item
-Identifier declaration can't override inherited package name
-
-@item
-Cannot use Standard or other predefined packages as identifiers
-
-@item
-After renaming, cannot use the original name
-
-@item
-Subprograms can only be renamed to remove package prefix
-
-@item
-Pragma import must be immediately after entity it names
-
-@item
-No mutual recursion between multiple units (this can be checked with gnatcheck)
-@end itemize
-
-Note that if a unit is compiled in Ada 95 mode with the SPARK 2005 restriction,
-violations will be reported for constructs forbidden in SPARK 95,
-instead of SPARK 2005.
-
@node Implementation Advice,Implementation Defined Characteristics,Standard and Implementation Defined Restrictions,Top
-@anchor{gnat_rm/implementation_advice doc}@anchor{214}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a}@anchor{gnat_rm/implementation_advice id1}@anchor{215}
+@anchor{gnat_rm/implementation_advice doc}@anchor{213}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a}@anchor{gnat_rm/implementation_advice id1}@anchor{214}
@chapter Implementation Advice
@@ -13934,7 +13472,7 @@ case the text describes what GNAT does and why.
@end menu
@node RM 1 1 3 20 Error Detection,RM 1 1 3 31 Child Units,,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{216}
+@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{215}
@section RM 1.1.3(20): Error Detection
@@ -13951,7 +13489,7 @@ or diagnosed at compile time.
@geindex Child Units
@node RM 1 1 3 31 Child Units,RM 1 1 5 12 Bounded Errors,RM 1 1 3 20 Error Detection,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{217}
+@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{216}
@section RM 1.1.3(31): Child Units
@@ -13967,7 +13505,7 @@ Followed.
@geindex Bounded errors
@node RM 1 1 5 12 Bounded Errors,RM 2 8 16 Pragmas,RM 1 1 3 31 Child Units,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{218}
+@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{217}
@section RM 1.1.5(12): Bounded Errors
@@ -13984,7 +13522,7 @@ runtime.
@geindex Pragmas
@node RM 2 8 16 Pragmas,RM 2 8 17-19 Pragmas,RM 1 1 5 12 Bounded Errors,Implementation Advice
-@anchor{gnat_rm/implementation_advice id2}@anchor{219}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{21a}
+@anchor{gnat_rm/implementation_advice id2}@anchor{218}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{219}
@section RM 2.8(16): Pragmas
@@ -14097,7 +13635,7 @@ that this advice not be followed. For details see
@ref{7,,Implementation Defined Pragmas}.
@node RM 2 8 17-19 Pragmas,RM 3 5 2 5 Alternative Character Sets,RM 2 8 16 Pragmas,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{21b}
+@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{21a}
@section RM 2.8(17-19): Pragmas
@@ -14118,14 +13656,14 @@ replacing @code{library_items}."
@end itemize
@end quotation
-See @ref{21a,,RM 2.8(16); Pragmas}.
+See @ref{219,,RM 2.8(16); Pragmas}.
@geindex Character Sets
@geindex Alternative Character Sets
@node RM 3 5 2 5 Alternative Character Sets,RM 3 5 4 28 Integer Types,RM 2 8 17-19 Pragmas,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{21c}
+@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{21b}
@section RM 3.5.2(5): Alternative Character Sets
@@ -14153,7 +13691,7 @@ there is no such restriction.
@geindex Integer types
@node RM 3 5 4 28 Integer Types,RM 3 5 4 29 Integer Types,RM 3 5 2 5 Alternative Character Sets,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{21d}
+@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{21c}
@section RM 3.5.4(28): Integer Types
@@ -14172,7 +13710,7 @@ are supported for convenient interface to C, and so that all hardware
types of the machine are easily available.
@node RM 3 5 4 29 Integer Types,RM 3 5 5 8 Enumeration Values,RM 3 5 4 28 Integer Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{21e}
+@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{21d}
@section RM 3.5.4(29): Integer Types
@@ -14188,7 +13726,7 @@ Followed.
@geindex Enumeration values
@node RM 3 5 5 8 Enumeration Values,RM 3 5 7 17 Float Types,RM 3 5 4 29 Integer Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{21f}
+@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{21e}
@section RM 3.5.5(8): Enumeration Values
@@ -14208,7 +13746,7 @@ Followed.
@geindex Float types
@node RM 3 5 7 17 Float Types,RM 3 6 2 11 Multidimensional Arrays,RM 3 5 5 8 Enumeration Values,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{220}
+@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{21f}
@section RM 3.5.7(17): Float Types
@@ -14238,7 +13776,7 @@ since this is a software rather than a hardware format.
@geindex multidimensional
@node RM 3 6 2 11 Multidimensional Arrays,RM 9 6 30-31 Duration'Small,RM 3 5 7 17 Float Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-6-2-11-multidimensional-arrays}@anchor{221}
+@anchor{gnat_rm/implementation_advice rm-3-6-2-11-multidimensional-arrays}@anchor{220}
@section RM 3.6.2(11): Multidimensional Arrays
@@ -14256,7 +13794,7 @@ Followed.
@geindex Duration'Small
@node RM 9 6 30-31 Duration'Small,RM 10 2 1 12 Consistent Representation,RM 3 6 2 11 Multidimensional Arrays,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-9-6-30-31-duration-small}@anchor{222}
+@anchor{gnat_rm/implementation_advice rm-9-6-30-31-duration-small}@anchor{221}
@section RM 9.6(30-31): Duration'Small
@@ -14277,7 +13815,7 @@ it need not be the same time base as used for @code{Calendar.Clock}."
Followed.
@node RM 10 2 1 12 Consistent Representation,RM 11 4 1 19 Exception Information,RM 9 6 30-31 Duration'Small,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-10-2-1-12-consistent-representation}@anchor{223}
+@anchor{gnat_rm/implementation_advice rm-10-2-1-12-consistent-representation}@anchor{222}
@section RM 10.2.1(12): Consistent Representation
@@ -14299,7 +13837,7 @@ advice without severely impacting efficiency of execution.
@geindex Exception information
@node RM 11 4 1 19 Exception Information,RM 11 5 28 Suppression of Checks,RM 10 2 1 12 Consistent Representation,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{224}
+@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{223}
@section RM 11.4.1(19): Exception Information
@@ -14330,7 +13868,7 @@ Pragma @code{Discard_Names}.
@geindex suppression of
@node RM 11 5 28 Suppression of Checks,RM 13 1 21-24 Representation Clauses,RM 11 4 1 19 Exception Information,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{225}
+@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{224}
@section RM 11.5(28): Suppression of Checks
@@ -14345,7 +13883,7 @@ Followed.
@geindex Representation clauses
@node RM 13 1 21-24 Representation Clauses,RM 13 2 6-8 Packed Types,RM 11 5 28 Suppression of Checks,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{226}
+@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{225}
@section RM 13.1 (21-24): Representation Clauses
@@ -14394,7 +13932,7 @@ Followed.
@geindex Packed types
@node RM 13 2 6-8 Packed Types,RM 13 3 14-19 Address Clauses,RM 13 1 21-24 Representation Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{227}
+@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{226}
@section RM 13.2(6-8): Packed Types
@@ -14433,7 +13971,7 @@ Followed.
@geindex Address clauses
@node RM 13 3 14-19 Address Clauses,RM 13 3 29-35 Alignment Clauses,RM 13 2 6-8 Packed Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{228}
+@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{227}
@section RM 13.3(14-19): Address Clauses
@@ -14486,7 +14024,7 @@ Followed.
@geindex Alignment clauses
@node RM 13 3 29-35 Alignment Clauses,RM 13 3 42-43 Size Clauses,RM 13 3 14-19 Address Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{229}
+@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{228}
@section RM 13.3(29-35): Alignment Clauses
@@ -14543,7 +14081,7 @@ Followed.
@geindex Size clauses
@node RM 13 3 42-43 Size Clauses,RM 13 3 50-56 Size Clauses,RM 13 3 29-35 Alignment Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{22a}
+@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{229}
@section RM 13.3(42-43): Size Clauses
@@ -14561,7 +14099,7 @@ object's @code{Alignment} (if the @code{Alignment} is nonzero)."
Followed.
@node RM 13 3 50-56 Size Clauses,RM 13 3 71-73 Component Size Clauses,RM 13 3 42-43 Size Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{22b}
+@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{22a}
@section RM 13.3(50-56): Size Clauses
@@ -14612,7 +14150,7 @@ Followed.
@geindex Component_Size clauses
@node RM 13 3 71-73 Component Size Clauses,RM 13 4 9-10 Enumeration Representation Clauses,RM 13 3 50-56 Size Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{22c}
+@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{22b}
@section RM 13.3(71-73): Component Size Clauses
@@ -14646,7 +14184,7 @@ Followed.
@geindex enumeration
@node RM 13 4 9-10 Enumeration Representation Clauses,RM 13 5 1 17-22 Record Representation Clauses,RM 13 3 71-73 Component Size Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{22d}
+@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{22c}
@section RM 13.4(9-10): Enumeration Representation Clauses
@@ -14668,7 +14206,7 @@ Followed.
@geindex records
@node RM 13 5 1 17-22 Record Representation Clauses,RM 13 5 2 5 Storage Place Attributes,RM 13 4 9-10 Enumeration Representation Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{22e}
+@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{22d}
@section RM 13.5.1(17-22): Record Representation Clauses
@@ -14728,7 +14266,7 @@ and all mentioned features are implemented.
@geindex Storage place attributes
@node RM 13 5 2 5 Storage Place Attributes,RM 13 5 3 7-8 Bit Ordering,RM 13 5 1 17-22 Record Representation Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{22f}
+@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{22e}
@section RM 13.5.2(5): Storage Place Attributes
@@ -14748,7 +14286,7 @@ Followed. There are no such components in GNAT.
@geindex Bit ordering
@node RM 13 5 3 7-8 Bit Ordering,RM 13 7 37 Address as Private,RM 13 5 2 5 Storage Place Attributes,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{230}
+@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{22f}
@section RM 13.5.3(7-8): Bit Ordering
@@ -14768,7 +14306,7 @@ Thus non-default bit ordering is not supported.
@geindex as private type
@node RM 13 7 37 Address as Private,RM 13 7 1 16 Address Operations,RM 13 5 3 7-8 Bit Ordering,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{231}
+@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{230}
@section RM 13.7(37): Address as Private
@@ -14786,7 +14324,7 @@ Followed.
@geindex operations of
@node RM 13 7 1 16 Address Operations,RM 13 9 14-17 Unchecked Conversion,RM 13 7 37 Address as Private,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{232}
+@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{231}
@section RM 13.7.1(16): Address Operations
@@ -14804,7 +14342,7 @@ operation raises @code{Program_Error}, since all operations make sense.
@geindex Unchecked conversion
@node RM 13 9 14-17 Unchecked Conversion,RM 13 11 23-25 Implicit Heap Usage,RM 13 7 1 16 Address Operations,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{233}
+@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{232}
@section RM 13.9(14-17): Unchecked Conversion
@@ -14848,7 +14386,7 @@ Followed.
@geindex implicit
@node RM 13 11 23-25 Implicit Heap Usage,RM 13 11 2 17 Unchecked Deallocation,RM 13 9 14-17 Unchecked Conversion,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{234}
+@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{233}
@section RM 13.11(23-25): Implicit Heap Usage
@@ -14899,7 +14437,7 @@ Followed.
@geindex Unchecked deallocation
@node RM 13 11 2 17 Unchecked Deallocation,RM 13 13 2 1 6 Stream Oriented Attributes,RM 13 11 23-25 Implicit Heap Usage,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{235}
+@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{234}
@section RM 13.11.2(17): Unchecked Deallocation
@@ -14914,7 +14452,7 @@ Followed.
@geindex Stream oriented attributes
@node RM 13 13 2 1 6 Stream Oriented Attributes,RM A 1 52 Names of Predefined Numeric Types,RM 13 11 2 17 Unchecked Deallocation,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-13-2-1-6-stream-oriented-attributes}@anchor{236}
+@anchor{gnat_rm/implementation_advice rm-13-13-2-1-6-stream-oriented-attributes}@anchor{235}
@section RM 13.13.2(1.6): Stream Oriented Attributes
@@ -14927,14 +14465,14 @@ to the nearest factor or multiple of the word size that is also a
multiple of the stream element size."
@end quotation
-Followed, except that the number of stream elements is a power of 2.
+Followed, except that the number of stream elements is 1, 2, 3, 4 or 8.
The Stream_Size may be used to override the default choice.
-However, such an implementation is based on direct binary
-representations and is therefore target- and endianness-dependent. To
-address this issue, GNAT also supplies an alternate implementation of
-the stream attributes @code{Read} and @code{Write}, which uses the
-target-independent XDR standard representation for scalar types.
+The default implementation is based on direct binary representations and is
+therefore target- and endianness-dependent. To address this issue, GNAT also
+supplies an alternate implementation of the stream attributes @code{Read} and
+@code{Write}, which uses the target-independent XDR standard representation for
+scalar types. This XDR alternative can be enabled via the binder switch -xdr.
@geindex XDR representation
@@ -14944,32 +14482,8 @@ target-independent XDR standard representation for scalar types.
@geindex Stream oriented attributes
-The XDR implementation is provided as an alternative body of the
-@code{System.Stream_Attributes} package, in the file
-@code{s-stratt-xdr.adb} in the GNAT library.
-There is no @code{s-stratt-xdr.ads} file.
-In order to install the XDR implementation, do the following:
-
-
-@itemize *
-
-@item
-Replace the default implementation of the
-@code{System.Stream_Attributes} package with the XDR implementation.
-For example on a Unix platform issue the commands:
-
-@example
-$ mv s-stratt.adb s-stratt-default.adb
-$ mv s-stratt-xdr.adb s-stratt.adb
-@end example
-
-@item
-Rebuild the GNAT run-time library as documented in
-the @emph{GNAT and Libraries} section of the @cite{GNAT User's Guide}.
-@end itemize
-
@node RM A 1 52 Names of Predefined Numeric Types,RM A 3 2 49 Ada Characters Handling,RM 13 13 2 1 6 Stream Oriented Attributes,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{237}
+@anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{236}
@section RM A.1(52): Names of Predefined Numeric Types
@@ -14987,7 +14501,7 @@ Followed.
@geindex Ada.Characters.Handling
@node RM A 3 2 49 Ada Characters Handling,RM A 4 4 106 Bounded-Length String Handling,RM A 1 52 Names of Predefined Numeric Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{238}
+@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{237}
@section RM A.3.2(49): @code{Ada.Characters.Handling}
@@ -15004,7 +14518,7 @@ Followed. GNAT provides no such localized definitions.
@geindex Bounded-length strings
@node RM A 4 4 106 Bounded-Length String Handling,RM A 5 2 46-47 Random Number Generation,RM A 3 2 49 Ada Characters Handling,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{239}
+@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{238}
@section RM A.4.4(106): Bounded-Length String Handling
@@ -15019,7 +14533,7 @@ Followed. No implicit pointers or dynamic allocation are used.
@geindex Random number generation
@node RM A 5 2 46-47 Random Number Generation,RM A 10 7 23 Get_Immediate,RM A 4 4 106 Bounded-Length String Handling,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{23a}
+@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{239}
@section RM A.5.2(46-47): Random Number Generation
@@ -15048,7 +14562,7 @@ condition here to hold true.
@geindex Get_Immediate
@node RM A 10 7 23 Get_Immediate,RM B 1 39-41 Pragma Export,RM A 5 2 46-47 Random Number Generation,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{23b}
+@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{23a}
@section RM A.10.7(23): @code{Get_Immediate}
@@ -15072,7 +14586,7 @@ this functionality.
@geindex Export
@node RM B 1 39-41 Pragma Export,RM B 2 12-13 Package Interfaces,RM A 10 7 23 Get_Immediate,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{23c}
+@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{23b}
@section RM B.1(39-41): Pragma @code{Export}
@@ -15120,7 +14634,7 @@ Followed.
@geindex Interfaces
@node RM B 2 12-13 Package Interfaces,RM B 3 63-71 Interfacing with C,RM B 1 39-41 Pragma Export,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{23d}
+@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{23c}
@section RM B.2(12-13): Package @code{Interfaces}
@@ -15150,7 +14664,7 @@ Followed. GNAT provides all the packages described in this section.
@geindex interfacing with
@node RM B 3 63-71 Interfacing with C,RM B 4 95-98 Interfacing with COBOL,RM B 2 12-13 Package Interfaces,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{23e}
+@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{23d}
@section RM B.3(63-71): Interfacing with C
@@ -15238,7 +14752,7 @@ Followed.
@geindex interfacing with
@node RM B 4 95-98 Interfacing with COBOL,RM B 5 22-26 Interfacing with Fortran,RM B 3 63-71 Interfacing with C,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{23f}
+@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{23e}
@section RM B.4(95-98): Interfacing with COBOL
@@ -15279,7 +14793,7 @@ Followed.
@geindex interfacing with
@node RM B 5 22-26 Interfacing with Fortran,RM C 1 3-5 Access to Machine Operations,RM B 4 95-98 Interfacing with COBOL,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{240}
+@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{23f}
@section RM B.5(22-26): Interfacing with Fortran
@@ -15330,7 +14844,7 @@ Followed.
@geindex Machine operations
@node RM C 1 3-5 Access to Machine Operations,RM C 1 10-16 Access to Machine Operations,RM B 5 22-26 Interfacing with Fortran,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{241}
+@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{240}
@section RM C.1(3-5): Access to Machine Operations
@@ -15365,7 +14879,7 @@ object that is specified as exported."
Followed.
@node RM C 1 10-16 Access to Machine Operations,RM C 3 28 Interrupt Support,RM C 1 3-5 Access to Machine Operations,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{242}
+@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{241}
@section RM C.1(10-16): Access to Machine Operations
@@ -15426,7 +14940,7 @@ Followed on any target supporting such operations.
@geindex Interrupt support
@node RM C 3 28 Interrupt Support,RM C 3 1 20-21 Protected Procedure Handlers,RM C 1 10-16 Access to Machine Operations,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{243}
+@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{242}
@section RM C.3(28): Interrupt Support
@@ -15444,7 +14958,7 @@ of interrupt blocking.
@geindex Protected procedure handlers
@node RM C 3 1 20-21 Protected Procedure Handlers,RM C 3 2 25 Package Interrupts,RM C 3 28 Interrupt Support,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{244}
+@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{243}
@section RM C.3.1(20-21): Protected Procedure Handlers
@@ -15470,7 +14984,7 @@ Followed. Compile time warnings are given when possible.
@geindex Interrupts
@node RM C 3 2 25 Package Interrupts,RM C 4 14 Pre-elaboration Requirements,RM C 3 1 20-21 Protected Procedure Handlers,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{245}
+@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{244}
@section RM C.3.2(25): Package @code{Interrupts}
@@ -15488,7 +15002,7 @@ Followed.
@geindex Pre-elaboration requirements
@node RM C 4 14 Pre-elaboration Requirements,RM C 5 8 Pragma Discard_Names,RM C 3 2 25 Package Interrupts,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{246}
+@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{245}
@section RM C.4(14): Pre-elaboration Requirements
@@ -15504,7 +15018,7 @@ Followed. Executable code is generated in some cases, e.g., loops
to initialize large arrays.
@node RM C 5 8 Pragma Discard_Names,RM C 7 2 30 The Package Task_Attributes,RM C 4 14 Pre-elaboration Requirements,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{247}
+@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{246}
@section RM C.5(8): Pragma @code{Discard_Names}
@@ -15522,7 +15036,7 @@ Followed.
@geindex Task_Attributes
@node RM C 7 2 30 The Package Task_Attributes,RM D 3 17 Locking Policies,RM C 5 8 Pragma Discard_Names,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{248}
+@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{247}
@section RM C.7.2(30): The Package Task_Attributes
@@ -15543,7 +15057,7 @@ Not followed. This implementation is not targeted to such a domain.
@geindex Locking Policies
@node RM D 3 17 Locking Policies,RM D 4 16 Entry Queuing Policies,RM C 7 2 30 The Package Task_Attributes,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{249}
+@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{248}
@section RM D.3(17): Locking Policies
@@ -15560,7 +15074,7 @@ whose names (@code{Inheritance_Locking} and
@geindex Entry queuing policies
@node RM D 4 16 Entry Queuing Policies,RM D 6 9-10 Preemptive Abort,RM D 3 17 Locking Policies,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{24a}
+@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{249}
@section RM D.4(16): Entry Queuing Policies
@@ -15575,7 +15089,7 @@ Followed. No such implementation-defined queuing policies exist.
@geindex Preemptive abort
@node RM D 6 9-10 Preemptive Abort,RM D 7 21 Tasking Restrictions,RM D 4 16 Entry Queuing Policies,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{24b}
+@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{24a}
@section RM D.6(9-10): Preemptive Abort
@@ -15601,7 +15115,7 @@ Followed.
@geindex Tasking restrictions
@node RM D 7 21 Tasking Restrictions,RM D 8 47-49 Monotonic Time,RM D 6 9-10 Preemptive Abort,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{24c}
+@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{24b}
@section RM D.7(21): Tasking Restrictions
@@ -15620,7 +15134,7 @@ pragma @code{Profile (Restricted)} for more details.
@geindex monotonic
@node RM D 8 47-49 Monotonic Time,RM E 5 28-29 Partition Communication Subsystem,RM D 7 21 Tasking Restrictions,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{24d}
+@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{24c}
@section RM D.8(47-49): Monotonic Time
@@ -15655,7 +15169,7 @@ Followed.
@geindex PCS
@node RM E 5 28-29 Partition Communication Subsystem,RM F 7 COBOL Support,RM D 8 47-49 Monotonic Time,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{24e}
+@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{24d}
@section RM E.5(28-29): Partition Communication Subsystem
@@ -15683,7 +15197,7 @@ GNAT.
@geindex COBOL support
@node RM F 7 COBOL Support,RM F 1 2 Decimal Radix Support,RM E 5 28-29 Partition Communication Subsystem,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{24f}
+@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{24e}
@section RM F(7): COBOL Support
@@ -15703,7 +15217,7 @@ Followed.
@geindex Decimal radix support
@node RM F 1 2 Decimal Radix Support,RM G Numerics,RM F 7 COBOL Support,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{250}
+@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{24f}
@section RM F.1(2): Decimal Radix Support
@@ -15719,7 +15233,7 @@ representations.
@geindex Numerics
@node RM G Numerics,RM G 1 1 56-58 Complex Types,RM F 1 2 Decimal Radix Support,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{251}
+@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{250}
@section RM G: Numerics
@@ -15739,7 +15253,7 @@ Followed.
@geindex Complex types
@node RM G 1 1 56-58 Complex Types,RM G 1 2 49 Complex Elementary Functions,RM G Numerics,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{252}
+@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{251}
@section RM G.1.1(56-58): Complex Types
@@ -15801,7 +15315,7 @@ Followed.
@geindex Complex elementary functions
@node RM G 1 2 49 Complex Elementary Functions,RM G 2 4 19 Accuracy Requirements,RM G 1 1 56-58 Complex Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{253}
+@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{252}
@section RM G.1.2(49): Complex Elementary Functions
@@ -15823,7 +15337,7 @@ Followed.
@geindex Accuracy requirements
@node RM G 2 4 19 Accuracy Requirements,RM G 2 6 15 Complex Arithmetic Accuracy,RM G 1 2 49 Complex Elementary Functions,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{254}
+@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{253}
@section RM G.2.4(19): Accuracy Requirements
@@ -15847,7 +15361,7 @@ Followed.
@geindex complex arithmetic
@node RM G 2 6 15 Complex Arithmetic Accuracy,RM H 6 15/2 Pragma Partition_Elaboration_Policy,RM G 2 4 19 Accuracy Requirements,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{255}
+@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{254}
@section RM G.2.6(15): Complex Arithmetic Accuracy
@@ -15865,7 +15379,7 @@ Followed.
@geindex Sequential elaboration policy
@node RM H 6 15/2 Pragma Partition_Elaboration_Policy,,RM G 2 6 15 Complex Arithmetic Accuracy,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{256}
+@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{255}
@section RM H.6(15/2): Pragma Partition_Elaboration_Policy
@@ -15880,7 +15394,7 @@ immediately terminated."
Not followed.
@node Implementation Defined Characteristics,Intrinsic Subprograms,Implementation Advice,Top
-@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b}@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{257}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{258}
+@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b}@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{256}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{257}
@chapter Implementation Defined Characteristics
@@ -17076,7 +16590,7 @@ When the @code{Pattern} parameter is not the null string, it is interpreted
according to the syntax of regular expressions as defined in the
@code{GNAT.Regexp} package.
-See @ref{259,,GNAT.Regexp (g-regexp.ads)}.
+See @ref{258,,GNAT.Regexp (g-regexp.ads)}.
@itemize *
@@ -18124,7 +17638,7 @@ H.4(27)."
There are no restrictions on pragma @code{Restrictions}.
@node Intrinsic Subprograms,Representation Clauses and Pragmas,Implementation Defined Characteristics,Top
-@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{25a}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{25b}
+@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{259}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{25a}
@chapter Intrinsic Subprograms
@@ -18162,7 +17676,7 @@ Ada standard does not require Ada compilers to implement this feature.
@end menu
@node Intrinsic Operators,Compilation_ISO_Date,,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id2}@anchor{25c}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{25d}
+@anchor{gnat_rm/intrinsic_subprograms id2}@anchor{25b}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{25c}
@section Intrinsic Operators
@@ -18193,7 +17707,7 @@ It is also possible to specify such operators for private types, if the
full views are appropriate arithmetic types.
@node Compilation_ISO_Date,Compilation_Date,Intrinsic Operators,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{25e}@anchor{gnat_rm/intrinsic_subprograms compilation-iso-date}@anchor{25f}
+@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{25d}@anchor{gnat_rm/intrinsic_subprograms compilation-iso-date}@anchor{25e}
@section Compilation_ISO_Date
@@ -18207,7 +17721,7 @@ application program should simply call the function
the current compilation (in local time format YYYY-MM-DD).
@node Compilation_Date,Compilation_Time,Compilation_ISO_Date,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms compilation-date}@anchor{260}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{261}
+@anchor{gnat_rm/intrinsic_subprograms compilation-date}@anchor{25f}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{260}
@section Compilation_Date
@@ -18217,7 +17731,7 @@ Same as Compilation_ISO_Date, except the string is in the form
MMM DD YYYY.
@node Compilation_Time,Enclosing_Entity,Compilation_Date,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms compilation-time}@anchor{262}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{263}
+@anchor{gnat_rm/intrinsic_subprograms compilation-time}@anchor{261}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{262}
@section Compilation_Time
@@ -18231,7 +17745,7 @@ application program should simply call the function
the current compilation (in local time format HH:MM:SS).
@node Enclosing_Entity,Exception_Information,Compilation_Time,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{264}@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{265}
+@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{263}@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{264}
@section Enclosing_Entity
@@ -18245,7 +17759,7 @@ application program should simply call the function
the current subprogram, package, task, entry, or protected subprogram.
@node Exception_Information,Exception_Message,Enclosing_Entity,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{266}@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{267}
+@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{265}@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{266}
@section Exception_Information
@@ -18259,7 +17773,7 @@ so an application program should simply call the function
the exception information associated with the current exception.
@node Exception_Message,Exception_Name,Exception_Information,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms exception-message}@anchor{268}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{269}
+@anchor{gnat_rm/intrinsic_subprograms exception-message}@anchor{267}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{268}
@section Exception_Message
@@ -18273,7 +17787,7 @@ so an application program should simply call the function
the message associated with the current exception.
@node Exception_Name,File,Exception_Message,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms exception-name}@anchor{26a}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{26b}
+@anchor{gnat_rm/intrinsic_subprograms exception-name}@anchor{269}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{26a}
@section Exception_Name
@@ -18287,7 +17801,7 @@ so an application program should simply call the function
the name of the current exception.
@node File,Line,Exception_Name,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{26c}@anchor{gnat_rm/intrinsic_subprograms file}@anchor{26d}
+@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{26b}@anchor{gnat_rm/intrinsic_subprograms file}@anchor{26c}
@section File
@@ -18301,7 +17815,7 @@ application program should simply call the function
file.
@node Line,Shifts and Rotates,File,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{26e}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{26f}
+@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{26d}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{26e}
@section Line
@@ -18315,7 +17829,7 @@ application program should simply call the function
source line.
@node Shifts and Rotates,Source_Location,Line,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{270}@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{271}
+@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{26f}@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{270}
@section Shifts and Rotates
@@ -18354,7 +17868,7 @@ the Provide_Shift_Operators pragma, which provides the function declarations
and corresponding pragma Import's for all five shift functions.
@node Source_Location,,Shifts and Rotates,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{272}@anchor{gnat_rm/intrinsic_subprograms id13}@anchor{273}
+@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{271}@anchor{gnat_rm/intrinsic_subprograms id13}@anchor{272}
@section Source_Location
@@ -18368,7 +17882,7 @@ application program should simply call the function
source file location.
@node Representation Clauses and Pragmas,Standard Library Routines,Intrinsic Subprograms,Top
-@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d}@anchor{gnat_rm/representation_clauses_and_pragmas doc}@anchor{274}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{275}
+@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d}@anchor{gnat_rm/representation_clauses_and_pragmas doc}@anchor{273}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{274}
@chapter Representation Clauses and Pragmas
@@ -18414,7 +17928,7 @@ and this section describes the additional capabilities provided.
@end menu
@node Alignment Clauses,Size Clauses,,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{276}@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{277}
+@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{275}@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{276}
@section Alignment Clauses
@@ -18436,7 +17950,7 @@ For elementary types, the alignment is the minimum of the actual size of
objects of the type divided by @code{Storage_Unit},
and the maximum alignment supported by the target.
(This maximum alignment is given by the GNAT-specific attribute
-@code{Standard'Maximum_Alignment}; see @ref{191,,Attribute Maximum_Alignment}.)
+@code{Standard'Maximum_Alignment}; see @ref{190,,Attribute Maximum_Alignment}.)
@geindex Maximum_Alignment attribute
@@ -18545,7 +18059,7 @@ assumption is non-portable, and other compilers may choose different
alignments for the subtype @code{RS}.
@node Size Clauses,Storage_Size Clauses,Alignment Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id3}@anchor{278}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{279}
+@anchor{gnat_rm/representation_clauses_and_pragmas id3}@anchor{277}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{278}
@section Size Clauses
@@ -18622,7 +18136,7 @@ if it is known that a Size value can be accommodated in an object of
type Integer.
@node Storage_Size Clauses,Size of Variant Record Objects,Size Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{27a}@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{27b}
+@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{279}@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{27a}
@section Storage_Size Clauses
@@ -18695,7 +18209,7 @@ Of course in practice, there will not be any explicit allocators in the
case of such an access declaration.
@node Size of Variant Record Objects,Biased Representation,Storage_Size Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id5}@anchor{27c}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{27d}
+@anchor{gnat_rm/representation_clauses_and_pragmas id5}@anchor{27b}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{27c}
@section Size of Variant Record Objects
@@ -18805,7 +18319,7 @@ the maximum size, regardless of the current variant value, the
variant value.
@node Biased Representation,Value_Size and Object_Size Clauses,Size of Variant Record Objects,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{27e}@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{27f}
+@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{27d}@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{27e}
@section Biased Representation
@@ -18843,7 +18357,7 @@ biased representation can be used for all discrete types except for
enumeration types for which a representation clause is given.
@node Value_Size and Object_Size Clauses,Component_Size Clauses,Biased Representation,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id7}@anchor{280}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{281}
+@anchor{gnat_rm/representation_clauses_and_pragmas id7}@anchor{27f}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{280}
@section Value_Size and Object_Size Clauses
@@ -19078,7 +18592,7 @@ Value_Size
Note: the entries marked '*' are not actually specified by the Ada
Reference Manual, which has nothing to say about size in the dynamic
-case. What GNAT does is to allocate sufficient bits to accomodate any
+case. What GNAT does is to allocate sufficient bits to accommodate any
possible dynamic values for the bounds at run-time.
So far, so good, but GNAT has to obey the RM rules, so the question is
@@ -19159,7 +18673,7 @@ definition clause forces biased representation. This
warning can be turned off using @code{-gnatw.B}.
@node Component_Size Clauses,Bit_Order Clauses,Value_Size and Object_Size Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{282}@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{283}
+@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{281}@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{282}
@section Component_Size Clauses
@@ -19206,7 +18720,7 @@ and a pragma Pack for the same array type. if such duplicate
clauses are given, the pragma Pack will be ignored.
@node Bit_Order Clauses,Effect of Bit_Order on Byte Ordering,Component_Size Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas bit-order-clauses}@anchor{284}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{285}
+@anchor{gnat_rm/representation_clauses_and_pragmas bit-order-clauses}@anchor{283}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{284}
@section Bit_Order Clauses
@@ -19312,7 +18826,7 @@ if desired. The following section contains additional
details regarding the issue of byte ordering.
@node Effect of Bit_Order on Byte Ordering,Pragma Pack for Arrays,Bit_Order Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{286}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-bit-order-on-byte-ordering}@anchor{287}
+@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{285}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-bit-order-on-byte-ordering}@anchor{286}
@section Effect of Bit_Order on Byte Ordering
@@ -19569,7 +19083,7 @@ to set the boolean constant @code{Master_Byte_First} in
an appropriate manner.
@node Pragma Pack for Arrays,Pragma Pack for Records,Effect of Bit_Order on Byte Ordering,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{288}@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{289}
+@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{287}@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{288}
@section Pragma Pack for Arrays
@@ -19686,7 +19200,7 @@ Here 31-bit packing is achieved as required, and no warning is generated,
since in this case the programmer intention is clear.
@node Pragma Pack for Records,Record Representation Clauses,Pragma Pack for Arrays,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{28a}@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{28b}
+@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{289}@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{28a}
@section Pragma Pack for Records
@@ -19771,7 +19285,7 @@ the @code{L6} field is aligned to the next byte boundary, and takes an
integral number of bytes, i.e., 72 bits.
@node Record Representation Clauses,Handling of Records with Holes,Pragma Pack for Records,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id13}@anchor{28c}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{28d}
+@anchor{gnat_rm/representation_clauses_and_pragmas id13}@anchor{28b}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{28c}
@section Record Representation Clauses
@@ -19849,7 +19363,7 @@ end record;
@end example
@node Handling of Records with Holes,Enumeration Clauses,Record Representation Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{28e}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{28f}
+@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{28d}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{28e}
@section Handling of Records with Holes
@@ -19926,7 +19440,7 @@ for Hrec'Size use 64;
@end example
@node Enumeration Clauses,Address Clauses,Handling of Records with Holes,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas enumeration-clauses}@anchor{290}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{291}
+@anchor{gnat_rm/representation_clauses_and_pragmas enumeration-clauses}@anchor{28f}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{290}
@section Enumeration Clauses
@@ -19969,7 +19483,7 @@ the overhead of converting representation values to the corresponding
positional values, (i.e., the value delivered by the @code{Pos} attribute).
@node Address Clauses,Use of Address Clauses for Memory-Mapped I/O,Enumeration Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{292}@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{293}
+@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{291}@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{292}
@section Address Clauses
@@ -20298,7 +19812,7 @@ then the program compiles without the warning and when run will generate
the output @code{X was not clobbered}.
@node Use of Address Clauses for Memory-Mapped I/O,Effect of Convention on Representation,Address Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id17}@anchor{294}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{295}
+@anchor{gnat_rm/representation_clauses_and_pragmas id17}@anchor{293}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{294}
@section Use of Address Clauses for Memory-Mapped I/O
@@ -20356,7 +19870,7 @@ provides the pragma @code{Volatile_Full_Access} which can be used in lieu of
pragma @code{Atomic} and will give the additional guarantee.
@node Effect of Convention on Representation,Conventions and Anonymous Access Types,Use of Address Clauses for Memory-Mapped I/O,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{296}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{297}
+@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{295}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{296}
@section Effect of Convention on Representation
@@ -20434,7 +19948,7 @@ when one of these values is read, any nonzero value is treated as True.
@end itemize
@node Conventions and Anonymous Access Types,Determining the Representations chosen by GNAT,Effect of Convention on Representation,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas conventions-and-anonymous-access-types}@anchor{298}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{299}
+@anchor{gnat_rm/representation_clauses_and_pragmas conventions-and-anonymous-access-types}@anchor{297}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{298}
@section Conventions and Anonymous Access Types
@@ -20510,7 +20024,7 @@ package ConvComp is
@end example
@node Determining the Representations chosen by GNAT,,Conventions and Anonymous Access Types,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{29a}@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{29b}
+@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{299}@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{29a}
@section Determining the Representations chosen by GNAT
@@ -20662,7 +20176,7 @@ generated by the compiler into the original source to fix and guarantee
the actual representation to be used.
@node Standard Library Routines,The Implementation of Standard I/O,Representation Clauses and Pragmas,Top
-@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e}@anchor{gnat_rm/standard_library_routines doc}@anchor{29c}@anchor{gnat_rm/standard_library_routines id1}@anchor{29d}
+@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e}@anchor{gnat_rm/standard_library_routines doc}@anchor{29b}@anchor{gnat_rm/standard_library_routines id1}@anchor{29c}
@chapter Standard Library Routines
@@ -21486,7 +21000,7 @@ For packages in Interfaces and System, all the RM defined packages are
available in GNAT, see the Ada 2012 RM for full details.
@node The Implementation of Standard I/O,The GNAT Library,Standard Library Routines,Top
-@anchor{gnat_rm/the_implementation_of_standard_i_o the-implementation-of-standard-i-o}@anchor{f}@anchor{gnat_rm/the_implementation_of_standard_i_o doc}@anchor{29e}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{29f}
+@anchor{gnat_rm/the_implementation_of_standard_i_o the-implementation-of-standard-i-o}@anchor{f}@anchor{gnat_rm/the_implementation_of_standard_i_o doc}@anchor{29d}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{29e}
@chapter The Implementation of Standard I/O
@@ -21538,7 +21052,7 @@ these additional facilities are also described in this chapter.
@end menu
@node Standard I/O Packages,FORM Strings,,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{2a0}@anchor{gnat_rm/the_implementation_of_standard_i_o id2}@anchor{2a1}
+@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{29f}@anchor{gnat_rm/the_implementation_of_standard_i_o id2}@anchor{2a0}
@section Standard I/O Packages
@@ -21609,7 +21123,7 @@ flush the common I/O streams and in particular Standard_Output before
elaborating the Ada code.
@node FORM Strings,Direct_IO,Standard I/O Packages,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o form-strings}@anchor{2a2}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2a3}
+@anchor{gnat_rm/the_implementation_of_standard_i_o form-strings}@anchor{2a1}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2a2}
@section FORM Strings
@@ -21635,7 +21149,7 @@ unrecognized keyword appears in a form string, it is silently ignored
and not considered invalid.
@node Direct_IO,Sequential_IO,FORM Strings,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o direct-io}@anchor{2a4}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2a5}
+@anchor{gnat_rm/the_implementation_of_standard_i_o direct-io}@anchor{2a3}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2a4}
@section Direct_IO
@@ -21655,7 +21169,7 @@ There is no limit on the size of Direct_IO files, they are expanded as
necessary to accommodate whatever records are written to the file.
@node Sequential_IO,Text_IO,Direct_IO,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{2a6}@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{2a7}
+@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{2a5}@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{2a6}
@section Sequential_IO
@@ -21702,7 +21216,7 @@ using Stream_IO, and this is the preferred mechanism. In particular, the
above program fragment rewritten to use Stream_IO will work correctly.
@node Text_IO,Wide_Text_IO,Sequential_IO,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o id6}@anchor{2a8}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2a9}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id6}@anchor{2a7}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2a8}
@section Text_IO
@@ -21785,7 +21299,7 @@ the file.
@end menu
@node Stream Pointer Positioning,Reading and Writing Non-Regular Files,,Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o id7}@anchor{2aa}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2ab}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id7}@anchor{2a9}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2aa}
@subsection Stream Pointer Positioning
@@ -21821,7 +21335,7 @@ between two Ada files, then the difference may be observable in some
situations.
@node Reading and Writing Non-Regular Files,Get_Immediate,Stream Pointer Positioning,Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{2ac}@anchor{gnat_rm/the_implementation_of_standard_i_o id8}@anchor{2ad}
+@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{2ab}@anchor{gnat_rm/the_implementation_of_standard_i_o id8}@anchor{2ac}
@subsection Reading and Writing Non-Regular Files
@@ -21872,7 +21386,7 @@ to read data past that end of
file indication, until another end of file indication is entered.
@node Get_Immediate,Treating Text_IO Files as Streams,Reading and Writing Non-Regular Files,Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o get-immediate}@anchor{2ae}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2af}
+@anchor{gnat_rm/the_implementation_of_standard_i_o get-immediate}@anchor{2ad}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2ae}
@subsection Get_Immediate
@@ -21890,7 +21404,7 @@ possible), it is undefined whether the FF character will be treated as a
page mark.
@node Treating Text_IO Files as Streams,Text_IO Extensions,Get_Immediate,Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o id10}@anchor{2b0}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2b1}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id10}@anchor{2af}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2b0}
@subsection Treating Text_IO Files as Streams
@@ -21906,7 +21420,7 @@ skipped and the effect is similar to that described above for
@code{Get_Immediate}.
@node Text_IO Extensions,Text_IO Facilities for Unbounded Strings,Treating Text_IO Files as Streams,Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o id11}@anchor{2b2}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2b3}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id11}@anchor{2b1}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2b2}
@subsection Text_IO Extensions
@@ -21934,7 +21448,7 @@ the string is to be read.
@end itemize
@node Text_IO Facilities for Unbounded Strings,,Text_IO Extensions,Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{2b4}@anchor{gnat_rm/the_implementation_of_standard_i_o id12}@anchor{2b5}
+@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{2b3}@anchor{gnat_rm/the_implementation_of_standard_i_o id12}@anchor{2b4}
@subsection Text_IO Facilities for Unbounded Strings
@@ -21982,7 +21496,7 @@ files @code{a-szuzti.ads} and @code{a-szuzti.adb} provides similar extended
@code{Wide_Wide_Text_IO} functionality for unbounded wide wide strings.
@node Wide_Text_IO,Wide_Wide_Text_IO,Text_IO,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{2b6}@anchor{gnat_rm/the_implementation_of_standard_i_o id13}@anchor{2b7}
+@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{2b5}@anchor{gnat_rm/the_implementation_of_standard_i_o id13}@anchor{2b6}
@section Wide_Text_IO
@@ -22229,12 +21743,12 @@ input also causes Constraint_Error to be raised.
@end menu
@node Stream Pointer Positioning<2>,Reading and Writing Non-Regular Files<2>,,Wide_Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{2b8}@anchor{gnat_rm/the_implementation_of_standard_i_o id14}@anchor{2b9}
+@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{2b7}@anchor{gnat_rm/the_implementation_of_standard_i_o id14}@anchor{2b8}
@subsection Stream Pointer Positioning
@code{Ada.Wide_Text_IO} is similar to @code{Ada.Text_IO} in its handling
-of stream pointer positioning (@ref{2a9,,Text_IO}). There is one additional
+of stream pointer positioning (@ref{2a8,,Text_IO}). There is one additional
case:
If @code{Ada.Wide_Text_IO.Look_Ahead} reads a character outside the
@@ -22253,7 +21767,7 @@ to a normal program using @code{Wide_Text_IO}. However, this discrepancy
can be observed if the wide text file shares a stream with another file.
@node Reading and Writing Non-Regular Files<2>,,Stream Pointer Positioning<2>,Wide_Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{2ba}@anchor{gnat_rm/the_implementation_of_standard_i_o id15}@anchor{2bb}
+@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{2b9}@anchor{gnat_rm/the_implementation_of_standard_i_o id15}@anchor{2ba}
@subsection Reading and Writing Non-Regular Files
@@ -22264,7 +21778,7 @@ treated as data characters), and @code{End_Of_Page} always returns
it is possible to read beyond an end of file.
@node Wide_Wide_Text_IO,Stream_IO,Wide_Text_IO,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o id16}@anchor{2bc}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2bd}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id16}@anchor{2bb}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2bc}
@section Wide_Wide_Text_IO
@@ -22433,12 +21947,12 @@ input also causes Constraint_Error to be raised.
@end menu
@node Stream Pointer Positioning<3>,Reading and Writing Non-Regular Files<3>,,Wide_Wide_Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{2be}@anchor{gnat_rm/the_implementation_of_standard_i_o id17}@anchor{2bf}
+@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{2bd}@anchor{gnat_rm/the_implementation_of_standard_i_o id17}@anchor{2be}
@subsection Stream Pointer Positioning
@code{Ada.Wide_Wide_Text_IO} is similar to @code{Ada.Text_IO} in its handling
-of stream pointer positioning (@ref{2a9,,Text_IO}). There is one additional
+of stream pointer positioning (@ref{2a8,,Text_IO}). There is one additional
case:
If @code{Ada.Wide_Wide_Text_IO.Look_Ahead} reads a character outside the
@@ -22457,7 +21971,7 @@ to a normal program using @code{Wide_Wide_Text_IO}. However, this discrepancy
can be observed if the wide text file shares a stream with another file.
@node Reading and Writing Non-Regular Files<3>,,Stream Pointer Positioning<3>,Wide_Wide_Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o id18}@anchor{2c0}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2c1}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id18}@anchor{2bf}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2c0}
@subsection Reading and Writing Non-Regular Files
@@ -22468,7 +21982,7 @@ treated as data characters), and @code{End_Of_Page} always returns
it is possible to read beyond an end of file.
@node Stream_IO,Text Translation,Wide_Wide_Text_IO,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o id19}@anchor{2c2}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2c3}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id19}@anchor{2c1}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2c2}
@section Stream_IO
@@ -22490,7 +22004,7 @@ manner described for stream attributes.
@end itemize
@node Text Translation,Shared Files,Stream_IO,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o id20}@anchor{2c4}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2c5}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id20}@anchor{2c3}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2c4}
@section Text Translation
@@ -22524,7 +22038,7 @@ mode. (corresponds to_O_U16TEXT).
@end itemize
@node Shared Files,Filenames encoding,Text Translation,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o id21}@anchor{2c6}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2c7}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id21}@anchor{2c5}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2c6}
@section Shared Files
@@ -22587,7 +22101,7 @@ heterogeneous input-output. Although this approach will work in GNAT if
for this purpose (using the stream attributes)
@node Filenames encoding,File content encoding,Shared Files,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o filenames-encoding}@anchor{2c8}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2c9}
+@anchor{gnat_rm/the_implementation_of_standard_i_o filenames-encoding}@anchor{2c7}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2c8}
@section Filenames encoding
@@ -22627,7 +22141,7 @@ platform. On the other Operating Systems the run-time is supporting
UTF-8 natively.
@node File content encoding,Open Modes,Filenames encoding,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o file-content-encoding}@anchor{2ca}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2cb}
+@anchor{gnat_rm/the_implementation_of_standard_i_o file-content-encoding}@anchor{2c9}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2ca}
@section File content encoding
@@ -22660,7 +22174,7 @@ Unicode 8-bit encoding
This encoding is only supported on the Windows platform.
@node Open Modes,Operations on C Streams,File content encoding,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{2cc}@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{2cd}
+@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{2cb}@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{2cc}
@section Open Modes
@@ -22763,7 +22277,7 @@ subsequently requires switching from reading to writing or vice-versa,
then the file is reopened in @code{r+} mode to permit the required operation.
@node Operations on C Streams,Interfacing to C Streams,Open Modes,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{2ce}@anchor{gnat_rm/the_implementation_of_standard_i_o id25}@anchor{2cf}
+@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{2cd}@anchor{gnat_rm/the_implementation_of_standard_i_o id25}@anchor{2ce}
@section Operations on C Streams
@@ -22923,7 +22437,7 @@ end Interfaces.C_Streams;
@end example
@node Interfacing to C Streams,,Operations on C Streams,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{2d0}@anchor{gnat_rm/the_implementation_of_standard_i_o id26}@anchor{2d1}
+@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{2cf}@anchor{gnat_rm/the_implementation_of_standard_i_o id26}@anchor{2d0}
@section Interfacing to C Streams
@@ -23016,7 +22530,7 @@ imported from a C program, allowing an Ada file to operate on an
existing C file.
@node The GNAT Library,Interfacing to Other Languages,The Implementation of Standard I/O,Top
-@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10}@anchor{gnat_rm/the_gnat_library doc}@anchor{2d2}@anchor{gnat_rm/the_gnat_library id1}@anchor{2d3}
+@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10}@anchor{gnat_rm/the_gnat_library doc}@anchor{2d1}@anchor{gnat_rm/the_gnat_library id1}@anchor{2d2}
@chapter The GNAT Library
@@ -23209,7 +22723,7 @@ of GNAT, and will generate a warning message.
@end menu
@node Ada Characters Latin_9 a-chlat9 ads,Ada Characters Wide_Latin_1 a-cwila1 ads,,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id2}@anchor{2d4}@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{2d5}
+@anchor{gnat_rm/the_gnat_library id2}@anchor{2d3}@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{2d4}
@section @code{Ada.Characters.Latin_9} (@code{a-chlat9.ads})
@@ -23226,7 +22740,7 @@ is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
@node Ada Characters Wide_Latin_1 a-cwila1 ads,Ada Characters Wide_Latin_9 a-cwila1 ads,Ada Characters Latin_9 a-chlat9 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{2d6}@anchor{gnat_rm/the_gnat_library id3}@anchor{2d7}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{2d5}@anchor{gnat_rm/the_gnat_library id3}@anchor{2d6}
@section @code{Ada.Characters.Wide_Latin_1} (@code{a-cwila1.ads})
@@ -23243,7 +22757,7 @@ is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
@node Ada Characters Wide_Latin_9 a-cwila1 ads,Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,Ada Characters Wide_Latin_1 a-cwila1 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id4}@anchor{2d8}@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila1-ads}@anchor{2d9}
+@anchor{gnat_rm/the_gnat_library id4}@anchor{2d7}@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila1-ads}@anchor{2d8}
@section @code{Ada.Characters.Wide_Latin_9} (@code{a-cwila1.ads})
@@ -23260,7 +22774,7 @@ is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
@node Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,Ada Characters Wide_Latin_9 a-cwila1 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{2da}@anchor{gnat_rm/the_gnat_library id5}@anchor{2db}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{2d9}@anchor{gnat_rm/the_gnat_library id5}@anchor{2da}
@section @code{Ada.Characters.Wide_Wide_Latin_1} (@code{a-chzla1.ads})
@@ -23277,7 +22791,7 @@ is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
@node Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-9-a-chzla9-ads}@anchor{2dc}@anchor{gnat_rm/the_gnat_library id6}@anchor{2dd}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-9-a-chzla9-ads}@anchor{2db}@anchor{gnat_rm/the_gnat_library id6}@anchor{2dc}
@section @code{Ada.Characters.Wide_Wide_Latin_9} (@code{a-chzla9.ads})
@@ -23294,7 +22808,7 @@ is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
@node Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,Ada Containers Formal_Hashed_Maps a-cfhama ads,Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id7}@anchor{2de}@anchor{gnat_rm/the_gnat_library ada-containers-formal-doubly-linked-lists-a-cfdlli-ads}@anchor{2df}
+@anchor{gnat_rm/the_gnat_library id7}@anchor{2dd}@anchor{gnat_rm/the_gnat_library ada-containers-formal-doubly-linked-lists-a-cfdlli-ads}@anchor{2de}
@section @code{Ada.Containers.Formal_Doubly_Linked_Lists} (@code{a-cfdlli.ads})
@@ -23313,7 +22827,7 @@ efficient version than the one defined in the standard. In particular it
does not have the complex overhead required to detect cursor tampering.
@node Ada Containers Formal_Hashed_Maps a-cfhama ads,Ada Containers Formal_Hashed_Sets a-cfhase ads,Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id8}@anchor{2e0}@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-maps-a-cfhama-ads}@anchor{2e1}
+@anchor{gnat_rm/the_gnat_library id8}@anchor{2df}@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-maps-a-cfhama-ads}@anchor{2e0}
@section @code{Ada.Containers.Formal_Hashed_Maps} (@code{a-cfhama.ads})
@@ -23332,7 +22846,7 @@ efficient version than the one defined in the standard. In particular it
does not have the complex overhead required to detect cursor tampering.
@node Ada Containers Formal_Hashed_Sets a-cfhase ads,Ada Containers Formal_Ordered_Maps a-cforma ads,Ada Containers Formal_Hashed_Maps a-cfhama ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id9}@anchor{2e2}@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-sets-a-cfhase-ads}@anchor{2e3}
+@anchor{gnat_rm/the_gnat_library id9}@anchor{2e1}@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-sets-a-cfhase-ads}@anchor{2e2}
@section @code{Ada.Containers.Formal_Hashed_Sets} (@code{a-cfhase.ads})
@@ -23351,7 +22865,7 @@ efficient version than the one defined in the standard. In particular it
does not have the complex overhead required to detect cursor tampering.
@node Ada Containers Formal_Ordered_Maps a-cforma ads,Ada Containers Formal_Ordered_Sets a-cforse ads,Ada Containers Formal_Hashed_Sets a-cfhase ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id10}@anchor{2e4}@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-maps-a-cforma-ads}@anchor{2e5}
+@anchor{gnat_rm/the_gnat_library id10}@anchor{2e3}@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-maps-a-cforma-ads}@anchor{2e4}
@section @code{Ada.Containers.Formal_Ordered_Maps} (@code{a-cforma.ads})
@@ -23370,7 +22884,7 @@ efficient version than the one defined in the standard. In particular it
does not have the complex overhead required to detect cursor tampering.
@node Ada Containers Formal_Ordered_Sets a-cforse ads,Ada Containers Formal_Vectors a-cofove ads,Ada Containers Formal_Ordered_Maps a-cforma ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-sets-a-cforse-ads}@anchor{2e6}@anchor{gnat_rm/the_gnat_library id11}@anchor{2e7}
+@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-sets-a-cforse-ads}@anchor{2e5}@anchor{gnat_rm/the_gnat_library id11}@anchor{2e6}
@section @code{Ada.Containers.Formal_Ordered_Sets} (@code{a-cforse.ads})
@@ -23389,7 +22903,7 @@ efficient version than the one defined in the standard. In particular it
does not have the complex overhead required to detect cursor tampering.
@node Ada Containers Formal_Vectors a-cofove ads,Ada Containers Formal_Indefinite_Vectors a-cfinve ads,Ada Containers Formal_Ordered_Sets a-cforse ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id12}@anchor{2e8}@anchor{gnat_rm/the_gnat_library ada-containers-formal-vectors-a-cofove-ads}@anchor{2e9}
+@anchor{gnat_rm/the_gnat_library id12}@anchor{2e7}@anchor{gnat_rm/the_gnat_library ada-containers-formal-vectors-a-cofove-ads}@anchor{2e8}
@section @code{Ada.Containers.Formal_Vectors} (@code{a-cofove.ads})
@@ -23408,7 +22922,7 @@ efficient version than the one defined in the standard. In particular it
does not have the complex overhead required to detect cursor tampering.
@node Ada Containers Formal_Indefinite_Vectors a-cfinve ads,Ada Containers Functional_Vectors a-cofuve ads,Ada Containers Formal_Vectors a-cofove ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id13}@anchor{2ea}@anchor{gnat_rm/the_gnat_library ada-containers-formal-indefinite-vectors-a-cfinve-ads}@anchor{2eb}
+@anchor{gnat_rm/the_gnat_library id13}@anchor{2e9}@anchor{gnat_rm/the_gnat_library ada-containers-formal-indefinite-vectors-a-cfinve-ads}@anchor{2ea}
@section @code{Ada.Containers.Formal_Indefinite_Vectors} (@code{a-cfinve.ads})
@@ -23427,7 +22941,7 @@ efficient version than the one defined in the standard. In particular it
does not have the complex overhead required to detect cursor tampering.
@node Ada Containers Functional_Vectors a-cofuve ads,Ada Containers Functional_Sets a-cofuse ads,Ada Containers Formal_Indefinite_Vectors a-cfinve ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id14}@anchor{2ec}@anchor{gnat_rm/the_gnat_library ada-containers-functional-vectors-a-cofuve-ads}@anchor{2ed}
+@anchor{gnat_rm/the_gnat_library id14}@anchor{2eb}@anchor{gnat_rm/the_gnat_library ada-containers-functional-vectors-a-cofuve-ads}@anchor{2ec}
@section @code{Ada.Containers.Functional_Vectors} (@code{a-cofuve.ads})
@@ -23449,7 +22963,7 @@ and annotations, so that they can be removed from the final executable. The
specification of this unit is compatible with SPARK 2014.
@node Ada Containers Functional_Sets a-cofuse ads,Ada Containers Functional_Maps a-cofuma ads,Ada Containers Functional_Vectors a-cofuve ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-functional-sets-a-cofuse-ads}@anchor{2ee}@anchor{gnat_rm/the_gnat_library id15}@anchor{2ef}
+@anchor{gnat_rm/the_gnat_library ada-containers-functional-sets-a-cofuse-ads}@anchor{2ed}@anchor{gnat_rm/the_gnat_library id15}@anchor{2ee}
@section @code{Ada.Containers.Functional_Sets} (@code{a-cofuse.ads})
@@ -23471,7 +22985,7 @@ and annotations, so that they can be removed from the final executable. The
specification of this unit is compatible with SPARK 2014.
@node Ada Containers Functional_Maps a-cofuma ads,Ada Containers Bounded_Holders a-coboho ads,Ada Containers Functional_Sets a-cofuse ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id16}@anchor{2f0}@anchor{gnat_rm/the_gnat_library ada-containers-functional-maps-a-cofuma-ads}@anchor{2f1}
+@anchor{gnat_rm/the_gnat_library id16}@anchor{2ef}@anchor{gnat_rm/the_gnat_library ada-containers-functional-maps-a-cofuma-ads}@anchor{2f0}
@section @code{Ada.Containers.Functional_Maps} (@code{a-cofuma.ads})
@@ -23493,7 +23007,7 @@ and annotations, so that they can be removed from the final executable. The
specification of this unit is compatible with SPARK 2014.
@node Ada Containers Bounded_Holders a-coboho ads,Ada Command_Line Environment a-colien ads,Ada Containers Functional_Maps a-cofuma ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{2f2}@anchor{gnat_rm/the_gnat_library id17}@anchor{2f3}
+@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{2f1}@anchor{gnat_rm/the_gnat_library id17}@anchor{2f2}
@section @code{Ada.Containers.Bounded_Holders} (@code{a-coboho.ads})
@@ -23505,7 +23019,7 @@ This child of @code{Ada.Containers} defines a modified version of
Indefinite_Holders that avoids heap allocation.
@node Ada Command_Line Environment a-colien ads,Ada Command_Line Remove a-colire ads,Ada Containers Bounded_Holders a-coboho ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-command-line-environment-a-colien-ads}@anchor{2f4}@anchor{gnat_rm/the_gnat_library id18}@anchor{2f5}
+@anchor{gnat_rm/the_gnat_library ada-command-line-environment-a-colien-ads}@anchor{2f3}@anchor{gnat_rm/the_gnat_library id18}@anchor{2f4}
@section @code{Ada.Command_Line.Environment} (@code{a-colien.ads})
@@ -23518,7 +23032,7 @@ provides a mechanism for obtaining environment values on systems
where this concept makes sense.
@node Ada Command_Line Remove a-colire ads,Ada Command_Line Response_File a-clrefi ads,Ada Command_Line Environment a-colien ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id19}@anchor{2f6}@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{2f7}
+@anchor{gnat_rm/the_gnat_library id19}@anchor{2f5}@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{2f6}
@section @code{Ada.Command_Line.Remove} (@code{a-colire.ads})
@@ -23536,7 +23050,7 @@ to further calls on the subprograms in @code{Ada.Command_Line} will not
see the removed argument.
@node Ada Command_Line Response_File a-clrefi ads,Ada Direct_IO C_Streams a-diocst ads,Ada Command_Line Remove a-colire ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id20}@anchor{2f8}@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{2f9}
+@anchor{gnat_rm/the_gnat_library id20}@anchor{2f7}@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{2f8}
@section @code{Ada.Command_Line.Response_File} (@code{a-clrefi.ads})
@@ -23556,7 +23070,7 @@ Using a response file allow passing a set of arguments to an executable longer
than the maximum allowed by the system on the command line.
@node Ada Direct_IO C_Streams a-diocst ads,Ada Exceptions Is_Null_Occurrence a-einuoc ads,Ada Command_Line Response_File a-clrefi ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id21}@anchor{2fa}@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{2fb}
+@anchor{gnat_rm/the_gnat_library id21}@anchor{2f9}@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{2fa}
@section @code{Ada.Direct_IO.C_Streams} (@code{a-diocst.ads})
@@ -23571,7 +23085,7 @@ extracted from a file opened on the Ada side, and an Ada file
can be constructed from a stream opened on the C side.
@node Ada Exceptions Is_Null_Occurrence a-einuoc ads,Ada Exceptions Last_Chance_Handler a-elchha ads,Ada Direct_IO C_Streams a-diocst ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id22}@anchor{2fc}@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{2fd}
+@anchor{gnat_rm/the_gnat_library id22}@anchor{2fb}@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{2fc}
@section @code{Ada.Exceptions.Is_Null_Occurrence} (@code{a-einuoc.ads})
@@ -23585,7 +23099,7 @@ exception occurrence (@code{Null_Occurrence}) without raising
an exception.
@node Ada Exceptions Last_Chance_Handler a-elchha ads,Ada Exceptions Traceback a-exctra ads,Ada Exceptions Is_Null_Occurrence a-einuoc ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id23}@anchor{2fe}@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{2ff}
+@anchor{gnat_rm/the_gnat_library id23}@anchor{2fd}@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{2fe}
@section @code{Ada.Exceptions.Last_Chance_Handler} (@code{a-elchha.ads})
@@ -23599,7 +23113,7 @@ exceptions (hence the name last chance), and perform clean ups before
terminating the program. Note that this subprogram never returns.
@node Ada Exceptions Traceback a-exctra ads,Ada Sequential_IO C_Streams a-siocst ads,Ada Exceptions Last_Chance_Handler a-elchha ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-exceptions-traceback-a-exctra-ads}@anchor{300}@anchor{gnat_rm/the_gnat_library id24}@anchor{301}
+@anchor{gnat_rm/the_gnat_library ada-exceptions-traceback-a-exctra-ads}@anchor{2ff}@anchor{gnat_rm/the_gnat_library id24}@anchor{300}
@section @code{Ada.Exceptions.Traceback} (@code{a-exctra.ads})
@@ -23612,7 +23126,7 @@ give a traceback array of addresses based on an exception
occurrence.
@node Ada Sequential_IO C_Streams a-siocst ads,Ada Streams Stream_IO C_Streams a-ssicst ads,Ada Exceptions Traceback a-exctra ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-sequential-io-c-streams-a-siocst-ads}@anchor{302}@anchor{gnat_rm/the_gnat_library id25}@anchor{303}
+@anchor{gnat_rm/the_gnat_library ada-sequential-io-c-streams-a-siocst-ads}@anchor{301}@anchor{gnat_rm/the_gnat_library id25}@anchor{302}
@section @code{Ada.Sequential_IO.C_Streams} (@code{a-siocst.ads})
@@ -23627,7 +23141,7 @@ extracted from a file opened on the Ada side, and an Ada file
can be constructed from a stream opened on the C side.
@node Ada Streams Stream_IO C_Streams a-ssicst ads,Ada Strings Unbounded Text_IO a-suteio ads,Ada Sequential_IO C_Streams a-siocst ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id26}@anchor{304}@anchor{gnat_rm/the_gnat_library ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{305}
+@anchor{gnat_rm/the_gnat_library id26}@anchor{303}@anchor{gnat_rm/the_gnat_library ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{304}
@section @code{Ada.Streams.Stream_IO.C_Streams} (@code{a-ssicst.ads})
@@ -23642,7 +23156,7 @@ extracted from a file opened on the Ada side, and an Ada file
can be constructed from a stream opened on the C side.
@node Ada Strings Unbounded Text_IO a-suteio ads,Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,Ada Streams Stream_IO C_Streams a-ssicst ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-strings-unbounded-text-io-a-suteio-ads}@anchor{306}@anchor{gnat_rm/the_gnat_library id27}@anchor{307}
+@anchor{gnat_rm/the_gnat_library ada-strings-unbounded-text-io-a-suteio-ads}@anchor{305}@anchor{gnat_rm/the_gnat_library id27}@anchor{306}
@section @code{Ada.Strings.Unbounded.Text_IO} (@code{a-suteio.ads})
@@ -23659,7 +23173,7 @@ strings, avoiding the necessity for an intermediate operation
with ordinary strings.
@node Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,Ada Strings Unbounded Text_IO a-suteio ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id28}@anchor{308}@anchor{gnat_rm/the_gnat_library ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{309}
+@anchor{gnat_rm/the_gnat_library id28}@anchor{307}@anchor{gnat_rm/the_gnat_library ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{308}
@section @code{Ada.Strings.Wide_Unbounded.Wide_Text_IO} (@code{a-swuwti.ads})
@@ -23676,7 +23190,7 @@ wide strings, avoiding the necessity for an intermediate operation
with ordinary wide strings.
@node Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,Ada Text_IO C_Streams a-tiocst ads,Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id29}@anchor{30a}@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{30b}
+@anchor{gnat_rm/the_gnat_library id29}@anchor{309}@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{30a}
@section @code{Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO} (@code{a-szuzti.ads})
@@ -23693,7 +23207,7 @@ wide wide strings, avoiding the necessity for an intermediate operation
with ordinary wide wide strings.
@node Ada Text_IO C_Streams a-tiocst ads,Ada Text_IO Reset_Standard_Files a-tirsfi ads,Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{30c}@anchor{gnat_rm/the_gnat_library id30}@anchor{30d}
+@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{30b}@anchor{gnat_rm/the_gnat_library id30}@anchor{30c}
@section @code{Ada.Text_IO.C_Streams} (@code{a-tiocst.ads})
@@ -23708,7 +23222,7 @@ extracted from a file opened on the Ada side, and an Ada file
can be constructed from a stream opened on the C side.
@node Ada Text_IO Reset_Standard_Files a-tirsfi ads,Ada Wide_Characters Unicode a-wichun ads,Ada Text_IO C_Streams a-tiocst ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-text-io-reset-standard-files-a-tirsfi-ads}@anchor{30e}@anchor{gnat_rm/the_gnat_library id31}@anchor{30f}
+@anchor{gnat_rm/the_gnat_library ada-text-io-reset-standard-files-a-tirsfi-ads}@anchor{30d}@anchor{gnat_rm/the_gnat_library id31}@anchor{30e}
@section @code{Ada.Text_IO.Reset_Standard_Files} (@code{a-tirsfi.ads})
@@ -23723,7 +23237,7 @@ execution (for example a standard input file may be redefined to be
interactive).
@node Ada Wide_Characters Unicode a-wichun ads,Ada Wide_Text_IO C_Streams a-wtcstr ads,Ada Text_IO Reset_Standard_Files a-tirsfi ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id32}@anchor{310}@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{311}
+@anchor{gnat_rm/the_gnat_library id32}@anchor{30f}@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{310}
@section @code{Ada.Wide_Characters.Unicode} (@code{a-wichun.ads})
@@ -23736,7 +23250,7 @@ This package provides subprograms that allow categorization of
Wide_Character values according to Unicode categories.
@node Ada Wide_Text_IO C_Streams a-wtcstr ads,Ada Wide_Text_IO Reset_Standard_Files a-wrstfi ads,Ada Wide_Characters Unicode a-wichun ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{312}@anchor{gnat_rm/the_gnat_library id33}@anchor{313}
+@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{311}@anchor{gnat_rm/the_gnat_library id33}@anchor{312}
@section @code{Ada.Wide_Text_IO.C_Streams} (@code{a-wtcstr.ads})
@@ -23751,7 +23265,7 @@ extracted from a file opened on the Ada side, and an Ada file
can be constructed from a stream opened on the C side.
@node Ada Wide_Text_IO Reset_Standard_Files a-wrstfi ads,Ada Wide_Wide_Characters Unicode a-zchuni ads,Ada Wide_Text_IO C_Streams a-wtcstr ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-wide-text-io-reset-standard-files-a-wrstfi-ads}@anchor{314}@anchor{gnat_rm/the_gnat_library id34}@anchor{315}
+@anchor{gnat_rm/the_gnat_library ada-wide-text-io-reset-standard-files-a-wrstfi-ads}@anchor{313}@anchor{gnat_rm/the_gnat_library id34}@anchor{314}
@section @code{Ada.Wide_Text_IO.Reset_Standard_Files} (@code{a-wrstfi.ads})
@@ -23766,7 +23280,7 @@ execution (for example a standard input file may be redefined to be
interactive).
@node Ada Wide_Wide_Characters Unicode a-zchuni ads,Ada Wide_Wide_Text_IO C_Streams a-ztcstr ads,Ada Wide_Text_IO Reset_Standard_Files a-wrstfi ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id35}@anchor{316}@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{317}
+@anchor{gnat_rm/the_gnat_library id35}@anchor{315}@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{316}
@section @code{Ada.Wide_Wide_Characters.Unicode} (@code{a-zchuni.ads})
@@ -23779,7 +23293,7 @@ This package provides subprograms that allow categorization of
Wide_Wide_Character values according to Unicode categories.
@node Ada Wide_Wide_Text_IO C_Streams a-ztcstr ads,Ada Wide_Wide_Text_IO Reset_Standard_Files a-zrstfi ads,Ada Wide_Wide_Characters Unicode a-zchuni ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id36}@anchor{318}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{319}
+@anchor{gnat_rm/the_gnat_library id36}@anchor{317}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{318}
@section @code{Ada.Wide_Wide_Text_IO.C_Streams} (@code{a-ztcstr.ads})
@@ -23794,7 +23308,7 @@ extracted from a file opened on the Ada side, and an Ada file
can be constructed from a stream opened on the C side.
@node Ada Wide_Wide_Text_IO Reset_Standard_Files a-zrstfi ads,GNAT Altivec g-altive ads,Ada Wide_Wide_Text_IO C_Streams a-ztcstr ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id37}@anchor{31a}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{31b}
+@anchor{gnat_rm/the_gnat_library id37}@anchor{319}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{31a}
@section @code{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@code{a-zrstfi.ads})
@@ -23809,7 +23323,7 @@ change during execution (for example a standard input file may be
redefined to be interactive).
@node GNAT Altivec g-altive ads,GNAT Altivec Conversions g-altcon ads,Ada Wide_Wide_Text_IO Reset_Standard_Files a-zrstfi ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{31c}@anchor{gnat_rm/the_gnat_library id38}@anchor{31d}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{31b}@anchor{gnat_rm/the_gnat_library id38}@anchor{31c}
@section @code{GNAT.Altivec} (@code{g-altive.ads})
@@ -23822,7 +23336,7 @@ definitions of constants and types common to all the versions of the
binding.
@node GNAT Altivec Conversions g-altcon ads,GNAT Altivec Vector_Operations g-alveop ads,GNAT Altivec g-altive ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{31e}@anchor{gnat_rm/the_gnat_library id39}@anchor{31f}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{31d}@anchor{gnat_rm/the_gnat_library id39}@anchor{31e}
@section @code{GNAT.Altivec.Conversions} (@code{g-altcon.ads})
@@ -23833,7 +23347,7 @@ binding.
This package provides the Vector/View conversion routines.
@node GNAT Altivec Vector_Operations g-alveop ads,GNAT Altivec Vector_Types g-alvety ads,GNAT Altivec Conversions g-altcon ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{320}@anchor{gnat_rm/the_gnat_library id40}@anchor{321}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{31f}@anchor{gnat_rm/the_gnat_library id40}@anchor{320}
@section @code{GNAT.Altivec.Vector_Operations} (@code{g-alveop.ads})
@@ -23847,7 +23361,7 @@ library. The hard binding is provided as a separate package. This unit
is common to both bindings.
@node GNAT Altivec Vector_Types g-alvety ads,GNAT Altivec Vector_Views g-alvevi ads,GNAT Altivec Vector_Operations g-alveop ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{322}@anchor{gnat_rm/the_gnat_library id41}@anchor{323}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{321}@anchor{gnat_rm/the_gnat_library id41}@anchor{322}
@section @code{GNAT.Altivec.Vector_Types} (@code{g-alvety.ads})
@@ -23859,7 +23373,7 @@ This package exposes the various vector types part of the Ada binding
to AltiVec facilities.
@node GNAT Altivec Vector_Views g-alvevi ads,GNAT Array_Split g-arrspl ads,GNAT Altivec Vector_Types g-alvety ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{324}@anchor{gnat_rm/the_gnat_library id42}@anchor{325}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{323}@anchor{gnat_rm/the_gnat_library id42}@anchor{324}
@section @code{GNAT.Altivec.Vector_Views} (@code{g-alvevi.ads})
@@ -23874,7 +23388,7 @@ vector elements and provides a simple way to initialize vector
objects.
@node GNAT Array_Split g-arrspl ads,GNAT AWK g-awk ads,GNAT Altivec Vector_Views g-alvevi ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{326}@anchor{gnat_rm/the_gnat_library id43}@anchor{327}
+@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{325}@anchor{gnat_rm/the_gnat_library id43}@anchor{326}
@section @code{GNAT.Array_Split} (@code{g-arrspl.ads})
@@ -23887,7 +23401,7 @@ an array wherever the separators appear, and provide direct access
to the resulting slices.
@node GNAT AWK g-awk ads,GNAT Bind_Environment g-binenv ads,GNAT Array_Split g-arrspl ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id44}@anchor{328}@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{329}
+@anchor{gnat_rm/the_gnat_library id44}@anchor{327}@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{328}
@section @code{GNAT.AWK} (@code{g-awk.ads})
@@ -23902,7 +23416,7 @@ or more files containing formatted data. The file is viewed as a database
where each record is a line and a field is a data element in this line.
@node GNAT Bind_Environment g-binenv ads,GNAT Branch_Prediction g-brapre ads,GNAT AWK g-awk ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{32a}@anchor{gnat_rm/the_gnat_library id45}@anchor{32b}
+@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{329}@anchor{gnat_rm/the_gnat_library id45}@anchor{32a}
@section @code{GNAT.Bind_Environment} (@code{g-binenv.ads})
@@ -23915,7 +23429,7 @@ These associations can be specified using the @code{-V} binder command
line switch.
@node GNAT Branch_Prediction g-brapre ads,GNAT Bounded_Buffers g-boubuf ads,GNAT Bind_Environment g-binenv ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id46}@anchor{32c}@anchor{gnat_rm/the_gnat_library gnat-branch-prediction-g-brapre-ads}@anchor{32d}
+@anchor{gnat_rm/the_gnat_library id46}@anchor{32b}@anchor{gnat_rm/the_gnat_library gnat-branch-prediction-g-brapre-ads}@anchor{32c}
@section @code{GNAT.Branch_Prediction} (@code{g-brapre.ads})
@@ -23926,7 +23440,7 @@ line switch.
Provides routines giving hints to the branch predictor of the code generator.
@node GNAT Bounded_Buffers g-boubuf ads,GNAT Bounded_Mailboxes g-boumai ads,GNAT Branch_Prediction g-brapre ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id47}@anchor{32e}@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{32f}
+@anchor{gnat_rm/the_gnat_library id47}@anchor{32d}@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{32e}
@section @code{GNAT.Bounded_Buffers} (@code{g-boubuf.ads})
@@ -23941,7 +23455,7 @@ useful directly or as parts of the implementations of other abstractions,
such as mailboxes.
@node GNAT Bounded_Mailboxes g-boumai ads,GNAT Bubble_Sort g-bubsor ads,GNAT Bounded_Buffers g-boubuf ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{330}@anchor{gnat_rm/the_gnat_library id48}@anchor{331}
+@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{32f}@anchor{gnat_rm/the_gnat_library id48}@anchor{330}
@section @code{GNAT.Bounded_Mailboxes} (@code{g-boumai.ads})
@@ -23954,7 +23468,7 @@ such as mailboxes.
Provides a thread-safe asynchronous intertask mailbox communication facility.
@node GNAT Bubble_Sort g-bubsor ads,GNAT Bubble_Sort_A g-busora ads,GNAT Bounded_Mailboxes g-boumai ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{332}@anchor{gnat_rm/the_gnat_library id49}@anchor{333}
+@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{331}@anchor{gnat_rm/the_gnat_library id49}@anchor{332}
@section @code{GNAT.Bubble_Sort} (@code{g-bubsor.ads})
@@ -23969,7 +23483,7 @@ data items. Exchange and comparison procedures are provided by passing
access-to-procedure values.
@node GNAT Bubble_Sort_A g-busora ads,GNAT Bubble_Sort_G g-busorg ads,GNAT Bubble_Sort g-bubsor ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id50}@anchor{334}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{335}
+@anchor{gnat_rm/the_gnat_library id50}@anchor{333}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{334}
@section @code{GNAT.Bubble_Sort_A} (@code{g-busora.ads})
@@ -23985,7 +23499,7 @@ access-to-procedure values. This is an older version, retained for
compatibility. Usually @code{GNAT.Bubble_Sort} will be preferable.
@node GNAT Bubble_Sort_G g-busorg ads,GNAT Byte_Order_Mark g-byorma ads,GNAT Bubble_Sort_A g-busora ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{336}@anchor{gnat_rm/the_gnat_library id51}@anchor{337}
+@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{335}@anchor{gnat_rm/the_gnat_library id51}@anchor{336}
@section @code{GNAT.Bubble_Sort_G} (@code{g-busorg.ads})
@@ -24001,7 +23515,7 @@ if the procedures can be inlined, at the expense of duplicating code for
multiple instantiations.
@node GNAT Byte_Order_Mark g-byorma ads,GNAT Byte_Swapping g-bytswa ads,GNAT Bubble_Sort_G g-busorg ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{338}@anchor{gnat_rm/the_gnat_library id52}@anchor{339}
+@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{337}@anchor{gnat_rm/the_gnat_library id52}@anchor{338}
@section @code{GNAT.Byte_Order_Mark} (@code{g-byorma.ads})
@@ -24017,7 +23531,7 @@ the encoding of the string. The routine includes detection of special XML
sequences for various UCS input formats.
@node GNAT Byte_Swapping g-bytswa ads,GNAT Calendar g-calend ads,GNAT Byte_Order_Mark g-byorma ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{33a}@anchor{gnat_rm/the_gnat_library id53}@anchor{33b}
+@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{339}@anchor{gnat_rm/the_gnat_library id53}@anchor{33a}
@section @code{GNAT.Byte_Swapping} (@code{g-bytswa.ads})
@@ -24031,7 +23545,7 @@ General routines for swapping the bytes in 2-, 4-, and 8-byte quantities.
Machine-specific implementations are available in some cases.
@node GNAT Calendar g-calend ads,GNAT Calendar Time_IO g-catiio ads,GNAT Byte_Swapping g-bytswa ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id54}@anchor{33c}@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{33d}
+@anchor{gnat_rm/the_gnat_library id54}@anchor{33b}@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{33c}
@section @code{GNAT.Calendar} (@code{g-calend.ads})
@@ -24045,7 +23559,7 @@ Also provides conversion of @code{Ada.Calendar.Time} values to and from the
C @code{timeval} format.
@node GNAT Calendar Time_IO g-catiio ads,GNAT CRC32 g-crc32 ads,GNAT Calendar g-calend ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id55}@anchor{33e}@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{33f}
+@anchor{gnat_rm/the_gnat_library id55}@anchor{33d}@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{33e}
@section @code{GNAT.Calendar.Time_IO} (@code{g-catiio.ads})
@@ -24056,7 +23570,7 @@ C @code{timeval} format.
@geindex GNAT.Calendar.Time_IO (g-catiio.ads)
@node GNAT CRC32 g-crc32 ads,GNAT Case_Util g-casuti ads,GNAT Calendar Time_IO g-catiio ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id56}@anchor{340}@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{341}
+@anchor{gnat_rm/the_gnat_library id56}@anchor{33f}@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{340}
@section @code{GNAT.CRC32} (@code{g-crc32.ads})
@@ -24073,7 +23587,7 @@ of this algorithm see
Aug. 1988. Sarwate, D.V.
@node GNAT Case_Util g-casuti ads,GNAT CGI g-cgi ads,GNAT CRC32 g-crc32 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id57}@anchor{342}@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{343}
+@anchor{gnat_rm/the_gnat_library id57}@anchor{341}@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{342}
@section @code{GNAT.Case_Util} (@code{g-casuti.ads})
@@ -24088,7 +23602,7 @@ without the overhead of the full casing tables
in @code{Ada.Characters.Handling}.
@node GNAT CGI g-cgi ads,GNAT CGI Cookie g-cgicoo ads,GNAT Case_Util g-casuti ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id58}@anchor{344}@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{345}
+@anchor{gnat_rm/the_gnat_library id58}@anchor{343}@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{344}
@section @code{GNAT.CGI} (@code{g-cgi.ads})
@@ -24103,7 +23617,7 @@ builds a table whose index is the key and provides some services to deal
with this table.
@node GNAT CGI Cookie g-cgicoo ads,GNAT CGI Debug g-cgideb ads,GNAT CGI g-cgi ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{346}@anchor{gnat_rm/the_gnat_library id59}@anchor{347}
+@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{345}@anchor{gnat_rm/the_gnat_library id59}@anchor{346}
@section @code{GNAT.CGI.Cookie} (@code{g-cgicoo.ads})
@@ -24118,7 +23632,7 @@ Common Gateway Interface (CGI). It exports services to deal with Web
cookies (piece of information kept in the Web client software).
@node GNAT CGI Debug g-cgideb ads,GNAT Command_Line g-comlin ads,GNAT CGI Cookie g-cgicoo ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{348}@anchor{gnat_rm/the_gnat_library id60}@anchor{349}
+@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{347}@anchor{gnat_rm/the_gnat_library id60}@anchor{348}
@section @code{GNAT.CGI.Debug} (@code{g-cgideb.ads})
@@ -24130,7 +23644,7 @@ This is a package to help debugging CGI (Common Gateway Interface)
programs written in Ada.
@node GNAT Command_Line g-comlin ads,GNAT Compiler_Version g-comver ads,GNAT CGI Debug g-cgideb ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id61}@anchor{34a}@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{34b}
+@anchor{gnat_rm/the_gnat_library id61}@anchor{349}@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{34a}
@section @code{GNAT.Command_Line} (@code{g-comlin.ads})
@@ -24143,7 +23657,7 @@ including the ability to scan for named switches with optional parameters
and expand file names using wildcard notations.
@node GNAT Compiler_Version g-comver ads,GNAT Ctrl_C g-ctrl_c ads,GNAT Command_Line g-comlin ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{34c}@anchor{gnat_rm/the_gnat_library id62}@anchor{34d}
+@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{34b}@anchor{gnat_rm/the_gnat_library id62}@anchor{34c}
@section @code{GNAT.Compiler_Version} (@code{g-comver.ads})
@@ -24161,7 +23675,7 @@ of the compiler if a consistent tool set is used to compile all units
of a partition).
@node GNAT Ctrl_C g-ctrl_c ads,GNAT Current_Exception g-curexc ads,GNAT Compiler_Version g-comver ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{34e}@anchor{gnat_rm/the_gnat_library id63}@anchor{34f}
+@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{34d}@anchor{gnat_rm/the_gnat_library id63}@anchor{34e}
@section @code{GNAT.Ctrl_C} (@code{g-ctrl_c.ads})
@@ -24172,7 +23686,7 @@ of a partition).
Provides a simple interface to handle Ctrl-C keyboard events.
@node GNAT Current_Exception g-curexc ads,GNAT Debug_Pools g-debpoo ads,GNAT Ctrl_C g-ctrl_c ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id64}@anchor{350}@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{351}
+@anchor{gnat_rm/the_gnat_library id64}@anchor{34f}@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{350}
@section @code{GNAT.Current_Exception} (@code{g-curexc.ads})
@@ -24189,7 +23703,7 @@ This is particularly useful in simulating typical facilities for
obtaining information about exceptions provided by Ada 83 compilers.
@node GNAT Debug_Pools g-debpoo ads,GNAT Debug_Utilities g-debuti ads,GNAT Current_Exception g-curexc ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{352}@anchor{gnat_rm/the_gnat_library id65}@anchor{353}
+@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{351}@anchor{gnat_rm/the_gnat_library id65}@anchor{352}
@section @code{GNAT.Debug_Pools} (@code{g-debpoo.ads})
@@ -24206,7 +23720,7 @@ problems.
See @code{The GNAT Debug_Pool Facility} section in the @cite{GNAT User's Guide}.
@node GNAT Debug_Utilities g-debuti ads,GNAT Decode_String g-decstr ads,GNAT Debug_Pools g-debpoo ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{354}@anchor{gnat_rm/the_gnat_library id66}@anchor{355}
+@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{353}@anchor{gnat_rm/the_gnat_library id66}@anchor{354}
@section @code{GNAT.Debug_Utilities} (@code{g-debuti.ads})
@@ -24219,7 +23733,7 @@ to and from string images of address values. Supports both C and Ada formats
for hexadecimal literals.
@node GNAT Decode_String g-decstr ads,GNAT Decode_UTF8_String g-deutst ads,GNAT Debug_Utilities g-debuti ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id67}@anchor{356}@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{357}
+@anchor{gnat_rm/the_gnat_library id67}@anchor{355}@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{356}
@section @code{GNAT.Decode_String} (@code{g-decstr.ads})
@@ -24243,7 +23757,7 @@ Useful in conjunction with Unicode character coding. Note there is a
preinstantiation for UTF-8. See next entry.
@node GNAT Decode_UTF8_String g-deutst ads,GNAT Directory_Operations g-dirope ads,GNAT Decode_String g-decstr ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{358}@anchor{gnat_rm/the_gnat_library id68}@anchor{359}
+@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{357}@anchor{gnat_rm/the_gnat_library id68}@anchor{358}
@section @code{GNAT.Decode_UTF8_String} (@code{g-deutst.ads})
@@ -24264,7 +23778,7 @@ preinstantiation for UTF-8. See next entry.
A preinstantiation of GNAT.Decode_Strings for UTF-8 encoding.
@node GNAT Directory_Operations g-dirope ads,GNAT Directory_Operations Iteration g-diopit ads,GNAT Decode_UTF8_String g-deutst ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id69}@anchor{35a}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{35b}
+@anchor{gnat_rm/the_gnat_library id69}@anchor{359}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{35a}
@section @code{GNAT.Directory_Operations} (@code{g-dirope.ads})
@@ -24277,7 +23791,7 @@ the current directory, making new directories, and scanning the files in a
directory.
@node GNAT Directory_Operations Iteration g-diopit ads,GNAT Dynamic_HTables g-dynhta ads,GNAT Directory_Operations g-dirope ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id70}@anchor{35c}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{35d}
+@anchor{gnat_rm/the_gnat_library id70}@anchor{35b}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{35c}
@section @code{GNAT.Directory_Operations.Iteration} (@code{g-diopit.ads})
@@ -24289,7 +23803,7 @@ A child unit of GNAT.Directory_Operations providing additional operations
for iterating through directories.
@node GNAT Dynamic_HTables g-dynhta ads,GNAT Dynamic_Tables g-dyntab ads,GNAT Directory_Operations Iteration g-diopit ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id71}@anchor{35e}@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{35f}
+@anchor{gnat_rm/the_gnat_library id71}@anchor{35d}@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{35e}
@section @code{GNAT.Dynamic_HTables} (@code{g-dynhta.ads})
@@ -24307,7 +23821,7 @@ dynamic instances of the hash table, while an instantiation of
@code{GNAT.HTable} creates a single instance of the hash table.
@node GNAT Dynamic_Tables g-dyntab ads,GNAT Encode_String g-encstr ads,GNAT Dynamic_HTables g-dynhta ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{360}@anchor{gnat_rm/the_gnat_library id72}@anchor{361}
+@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{35f}@anchor{gnat_rm/the_gnat_library id72}@anchor{360}
@section @code{GNAT.Dynamic_Tables} (@code{g-dyntab.ads})
@@ -24327,7 +23841,7 @@ dynamic instances of the table, while an instantiation of
@code{GNAT.Table} creates a single instance of the table type.
@node GNAT Encode_String g-encstr ads,GNAT Encode_UTF8_String g-enutst ads,GNAT Dynamic_Tables g-dyntab ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id73}@anchor{362}@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{363}
+@anchor{gnat_rm/the_gnat_library id73}@anchor{361}@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{362}
@section @code{GNAT.Encode_String} (@code{g-encstr.ads})
@@ -24349,7 +23863,7 @@ encoding method. Useful in conjunction with Unicode character coding.
Note there is a preinstantiation for UTF-8. See next entry.
@node GNAT Encode_UTF8_String g-enutst ads,GNAT Exception_Actions g-excact ads,GNAT Encode_String g-encstr ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{364}@anchor{gnat_rm/the_gnat_library id74}@anchor{365}
+@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{363}@anchor{gnat_rm/the_gnat_library id74}@anchor{364}
@section @code{GNAT.Encode_UTF8_String} (@code{g-enutst.ads})
@@ -24370,7 +23884,7 @@ Note there is a preinstantiation for UTF-8. See next entry.
A preinstantiation of GNAT.Encode_Strings for UTF-8 encoding.
@node GNAT Exception_Actions g-excact ads,GNAT Exception_Traces g-exctra ads,GNAT Encode_UTF8_String g-enutst ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{366}@anchor{gnat_rm/the_gnat_library id75}@anchor{367}
+@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{365}@anchor{gnat_rm/the_gnat_library id75}@anchor{366}
@section @code{GNAT.Exception_Actions} (@code{g-excact.ads})
@@ -24383,7 +23897,7 @@ for specific exceptions, or when any exception is raised. This
can be used for instance to force a core dump to ease debugging.
@node GNAT Exception_Traces g-exctra ads,GNAT Exceptions g-except ads,GNAT Exception_Actions g-excact ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{368}@anchor{gnat_rm/the_gnat_library id76}@anchor{369}
+@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{367}@anchor{gnat_rm/the_gnat_library id76}@anchor{368}
@section @code{GNAT.Exception_Traces} (@code{g-exctra.ads})
@@ -24397,7 +23911,7 @@ Provides an interface allowing to control automatic output upon exception
occurrences.
@node GNAT Exceptions g-except ads,GNAT Expect g-expect ads,GNAT Exception_Traces g-exctra ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id77}@anchor{36a}@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{36b}
+@anchor{gnat_rm/the_gnat_library id77}@anchor{369}@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{36a}
@section @code{GNAT.Exceptions} (@code{g-except.ads})
@@ -24418,7 +23932,7 @@ predefined exceptions, and for example allow raising
@code{Constraint_Error} with a message from a pure subprogram.
@node GNAT Expect g-expect ads,GNAT Expect TTY g-exptty ads,GNAT Exceptions g-except ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id78}@anchor{36c}@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{36d}
+@anchor{gnat_rm/the_gnat_library id78}@anchor{36b}@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{36c}
@section @code{GNAT.Expect} (@code{g-expect.ads})
@@ -24434,7 +23948,7 @@ It is not implemented for cross ports, and in particular is not
implemented for VxWorks or LynxOS.
@node GNAT Expect TTY g-exptty ads,GNAT Float_Control g-flocon ads,GNAT Expect g-expect ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id79}@anchor{36e}@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{36f}
+@anchor{gnat_rm/the_gnat_library id79}@anchor{36d}@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{36e}
@section @code{GNAT.Expect.TTY} (@code{g-exptty.ads})
@@ -24446,7 +23960,7 @@ ports. It is not implemented for cross ports, and
in particular is not implemented for VxWorks or LynxOS.
@node GNAT Float_Control g-flocon ads,GNAT Formatted_String g-forstr ads,GNAT Expect TTY g-exptty ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id80}@anchor{370}@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{371}
+@anchor{gnat_rm/the_gnat_library id80}@anchor{36f}@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{370}
@section @code{GNAT.Float_Control} (@code{g-flocon.ads})
@@ -24460,7 +23974,7 @@ library calls may cause this mode to be modified, and the Reset procedure
in this package can be used to reestablish the required mode.
@node GNAT Formatted_String g-forstr ads,GNAT Heap_Sort g-heasor ads,GNAT Float_Control g-flocon ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id81}@anchor{372}@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{373}
+@anchor{gnat_rm/the_gnat_library id81}@anchor{371}@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{372}
@section @code{GNAT.Formatted_String} (@code{g-forstr.ads})
@@ -24475,7 +23989,7 @@ derived from Integer, Float or enumerations as values for the
formatted string.
@node GNAT Heap_Sort g-heasor ads,GNAT Heap_Sort_A g-hesora ads,GNAT Formatted_String g-forstr ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{374}@anchor{gnat_rm/the_gnat_library id82}@anchor{375}
+@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{373}@anchor{gnat_rm/the_gnat_library id82}@anchor{374}
@section @code{GNAT.Heap_Sort} (@code{g-heasor.ads})
@@ -24489,7 +24003,7 @@ access-to-procedure values. The algorithm used is a modified heap sort
that performs approximately N*log(N) comparisons in the worst case.
@node GNAT Heap_Sort_A g-hesora ads,GNAT Heap_Sort_G g-hesorg ads,GNAT Heap_Sort g-heasor ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id83}@anchor{376}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{377}
+@anchor{gnat_rm/the_gnat_library id83}@anchor{375}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{376}
@section @code{GNAT.Heap_Sort_A} (@code{g-hesora.ads})
@@ -24505,7 +24019,7 @@ This differs from @code{GNAT.Heap_Sort} in having a less convenient
interface, but may be slightly more efficient.
@node GNAT Heap_Sort_G g-hesorg ads,GNAT HTable g-htable ads,GNAT Heap_Sort_A g-hesora ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id84}@anchor{378}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{379}
+@anchor{gnat_rm/the_gnat_library id84}@anchor{377}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{378}
@section @code{GNAT.Heap_Sort_G} (@code{g-hesorg.ads})
@@ -24519,7 +24033,7 @@ if the procedures can be inlined, at the expense of duplicating code for
multiple instantiations.
@node GNAT HTable g-htable ads,GNAT IO g-io ads,GNAT Heap_Sort_G g-hesorg ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id85}@anchor{37a}@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{37b}
+@anchor{gnat_rm/the_gnat_library id85}@anchor{379}@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{37a}
@section @code{GNAT.HTable} (@code{g-htable.ads})
@@ -24532,7 +24046,7 @@ data. Provides two approaches, one a simple static approach, and the other
allowing arbitrary dynamic hash tables.
@node GNAT IO g-io ads,GNAT IO_Aux g-io_aux ads,GNAT HTable g-htable ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id86}@anchor{37c}@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{37d}
+@anchor{gnat_rm/the_gnat_library id86}@anchor{37b}@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{37c}
@section @code{GNAT.IO} (@code{g-io.ads})
@@ -24548,7 +24062,7 @@ Standard_Input, and writing characters, strings and integers to either
Standard_Output or Standard_Error.
@node GNAT IO_Aux g-io_aux ads,GNAT Lock_Files g-locfil ads,GNAT IO g-io ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id87}@anchor{37e}@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{37f}
+@anchor{gnat_rm/the_gnat_library id87}@anchor{37d}@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{37e}
@section @code{GNAT.IO_Aux} (@code{g-io_aux.ads})
@@ -24562,7 +24076,7 @@ Provides some auxiliary functions for use with Text_IO, including a test
for whether a file exists, and functions for reading a line of text.
@node GNAT Lock_Files g-locfil ads,GNAT MBBS_Discrete_Random g-mbdira ads,GNAT IO_Aux g-io_aux ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id88}@anchor{380}@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{381}
+@anchor{gnat_rm/the_gnat_library id88}@anchor{37f}@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{380}
@section @code{GNAT.Lock_Files} (@code{g-locfil.ads})
@@ -24576,7 +24090,7 @@ Provides a general interface for using files as locks. Can be used for
providing program level synchronization.
@node GNAT MBBS_Discrete_Random g-mbdira ads,GNAT MBBS_Float_Random g-mbflra ads,GNAT Lock_Files g-locfil ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id89}@anchor{382}@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{383}
+@anchor{gnat_rm/the_gnat_library id89}@anchor{381}@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{382}
@section @code{GNAT.MBBS_Discrete_Random} (@code{g-mbdira.ads})
@@ -24588,7 +24102,7 @@ The original implementation of @code{Ada.Numerics.Discrete_Random}. Uses
a modified version of the Blum-Blum-Shub generator.
@node GNAT MBBS_Float_Random g-mbflra ads,GNAT MD5 g-md5 ads,GNAT MBBS_Discrete_Random g-mbdira ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id90}@anchor{384}@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{385}
+@anchor{gnat_rm/the_gnat_library id90}@anchor{383}@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{384}
@section @code{GNAT.MBBS_Float_Random} (@code{g-mbflra.ads})
@@ -24600,7 +24114,7 @@ The original implementation of @code{Ada.Numerics.Float_Random}. Uses
a modified version of the Blum-Blum-Shub generator.
@node GNAT MD5 g-md5 ads,GNAT Memory_Dump g-memdum ads,GNAT MBBS_Float_Random g-mbflra ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id91}@anchor{386}@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{387}
+@anchor{gnat_rm/the_gnat_library id91}@anchor{385}@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{386}
@section @code{GNAT.MD5} (@code{g-md5.ads})
@@ -24613,7 +24127,7 @@ the HMAC-MD5 message authentication function as described in RFC 2104 and
FIPS PUB 198.
@node GNAT Memory_Dump g-memdum ads,GNAT Most_Recent_Exception g-moreex ads,GNAT MD5 g-md5 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id92}@anchor{388}@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{389}
+@anchor{gnat_rm/the_gnat_library id92}@anchor{387}@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{388}
@section @code{GNAT.Memory_Dump} (@code{g-memdum.ads})
@@ -24626,7 +24140,7 @@ standard output or standard error files. Uses GNAT.IO for actual
output.
@node GNAT Most_Recent_Exception g-moreex ads,GNAT OS_Lib g-os_lib ads,GNAT Memory_Dump g-memdum ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{38a}@anchor{gnat_rm/the_gnat_library id93}@anchor{38b}
+@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{389}@anchor{gnat_rm/the_gnat_library id93}@anchor{38a}
@section @code{GNAT.Most_Recent_Exception} (@code{g-moreex.ads})
@@ -24640,7 +24154,7 @@ various logging purposes, including duplicating functionality of some
Ada 83 implementation dependent extensions.
@node GNAT OS_Lib g-os_lib ads,GNAT Perfect_Hash_Generators g-pehage ads,GNAT Most_Recent_Exception g-moreex ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{38c}@anchor{gnat_rm/the_gnat_library id94}@anchor{38d}
+@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{38b}@anchor{gnat_rm/the_gnat_library id94}@anchor{38c}
@section @code{GNAT.OS_Lib} (@code{g-os_lib.ads})
@@ -24656,7 +24170,7 @@ including a portable spawn procedure, and access to environment variables
and error return codes.
@node GNAT Perfect_Hash_Generators g-pehage ads,GNAT Random_Numbers g-rannum ads,GNAT OS_Lib g-os_lib ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{38e}@anchor{gnat_rm/the_gnat_library id95}@anchor{38f}
+@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{38d}@anchor{gnat_rm/the_gnat_library id95}@anchor{38e}
@section @code{GNAT.Perfect_Hash_Generators} (@code{g-pehage.ads})
@@ -24674,7 +24188,7 @@ hashcode are in the same order. These hashing functions are very
convenient for use with realtime applications.
@node GNAT Random_Numbers g-rannum ads,GNAT Regexp g-regexp ads,GNAT Perfect_Hash_Generators g-pehage ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{390}@anchor{gnat_rm/the_gnat_library id96}@anchor{391}
+@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{38f}@anchor{gnat_rm/the_gnat_library id96}@anchor{390}
@section @code{GNAT.Random_Numbers} (@code{g-rannum.ads})
@@ -24686,7 +24200,7 @@ Provides random number capabilities which extend those available in the
standard Ada library and are more convenient to use.
@node GNAT Regexp g-regexp ads,GNAT Registry g-regist ads,GNAT Random_Numbers g-rannum ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{259}@anchor{gnat_rm/the_gnat_library id97}@anchor{392}
+@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{258}@anchor{gnat_rm/the_gnat_library id97}@anchor{391}
@section @code{GNAT.Regexp} (@code{g-regexp.ads})
@@ -24702,7 +24216,7 @@ simplest of the three pattern matching packages provided, and is particularly
suitable for 'file globbing' applications.
@node GNAT Registry g-regist ads,GNAT Regpat g-regpat ads,GNAT Regexp g-regexp ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id98}@anchor{393}@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{394}
+@anchor{gnat_rm/the_gnat_library id98}@anchor{392}@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{393}
@section @code{GNAT.Registry} (@code{g-regist.ads})
@@ -24716,7 +24230,7 @@ registry API, but at a lower level of abstraction, refer to the Win32.Winreg
package provided with the Win32Ada binding
@node GNAT Regpat g-regpat ads,GNAT Rewrite_Data g-rewdat ads,GNAT Registry g-regist ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id99}@anchor{395}@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{396}
+@anchor{gnat_rm/the_gnat_library id99}@anchor{394}@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{395}
@section @code{GNAT.Regpat} (@code{g-regpat.ads})
@@ -24731,7 +24245,7 @@ from the original V7 style regular expression library written in C by
Henry Spencer (and binary compatible with this C library).
@node GNAT Rewrite_Data g-rewdat ads,GNAT Secondary_Stack_Info g-sestin ads,GNAT Regpat g-regpat ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id100}@anchor{397}@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{398}
+@anchor{gnat_rm/the_gnat_library id100}@anchor{396}@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{397}
@section @code{GNAT.Rewrite_Data} (@code{g-rewdat.ads})
@@ -24745,7 +24259,7 @@ full content to be processed is not loaded into memory all at once. This makes
this interface usable for large files or socket streams.
@node GNAT Secondary_Stack_Info g-sestin ads,GNAT Semaphores g-semaph ads,GNAT Rewrite_Data g-rewdat ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id101}@anchor{399}@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{39a}
+@anchor{gnat_rm/the_gnat_library id101}@anchor{398}@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{399}
@section @code{GNAT.Secondary_Stack_Info} (@code{g-sestin.ads})
@@ -24757,7 +24271,7 @@ Provide the capability to query the high water mark of the current task's
secondary stack.
@node GNAT Semaphores g-semaph ads,GNAT Serial_Communications g-sercom ads,GNAT Secondary_Stack_Info g-sestin ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id102}@anchor{39b}@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{39c}
+@anchor{gnat_rm/the_gnat_library id102}@anchor{39a}@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{39b}
@section @code{GNAT.Semaphores} (@code{g-semaph.ads})
@@ -24768,7 +24282,7 @@ secondary stack.
Provides classic counting and binary semaphores using protected types.
@node GNAT Serial_Communications g-sercom ads,GNAT SHA1 g-sha1 ads,GNAT Semaphores g-semaph ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{39d}@anchor{gnat_rm/the_gnat_library id103}@anchor{39e}
+@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{39c}@anchor{gnat_rm/the_gnat_library id103}@anchor{39d}
@section @code{GNAT.Serial_Communications} (@code{g-sercom.ads})
@@ -24780,7 +24294,7 @@ Provides a simple interface to send and receive data over a serial
port. This is only supported on GNU/Linux and Windows.
@node GNAT SHA1 g-sha1 ads,GNAT SHA224 g-sha224 ads,GNAT Serial_Communications g-sercom ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{39f}@anchor{gnat_rm/the_gnat_library id104}@anchor{3a0}
+@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{39e}@anchor{gnat_rm/the_gnat_library id104}@anchor{39f}
@section @code{GNAT.SHA1} (@code{g-sha1.ads})
@@ -24793,7 +24307,7 @@ and RFC 3174, and the HMAC-SHA1 message authentication function as described
in RFC 2104 and FIPS PUB 198.
@node GNAT SHA224 g-sha224 ads,GNAT SHA256 g-sha256 ads,GNAT SHA1 g-sha1 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{3a1}@anchor{gnat_rm/the_gnat_library id105}@anchor{3a2}
+@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{3a0}@anchor{gnat_rm/the_gnat_library id105}@anchor{3a1}
@section @code{GNAT.SHA224} (@code{g-sha224.ads})
@@ -24806,7 +24320,7 @@ and the HMAC-SHA224 message authentication function as described
in RFC 2104 and FIPS PUB 198.
@node GNAT SHA256 g-sha256 ads,GNAT SHA384 g-sha384 ads,GNAT SHA224 g-sha224 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{3a3}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a4}
+@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{3a2}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a3}
@section @code{GNAT.SHA256} (@code{g-sha256.ads})
@@ -24819,7 +24333,7 @@ and the HMAC-SHA256 message authentication function as described
in RFC 2104 and FIPS PUB 198.
@node GNAT SHA384 g-sha384 ads,GNAT SHA512 g-sha512 ads,GNAT SHA256 g-sha256 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{3a5}@anchor{gnat_rm/the_gnat_library id107}@anchor{3a6}
+@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{3a4}@anchor{gnat_rm/the_gnat_library id107}@anchor{3a5}
@section @code{GNAT.SHA384} (@code{g-sha384.ads})
@@ -24832,7 +24346,7 @@ and the HMAC-SHA384 message authentication function as described
in RFC 2104 and FIPS PUB 198.
@node GNAT SHA512 g-sha512 ads,GNAT Signals g-signal ads,GNAT SHA384 g-sha384 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id108}@anchor{3a7}@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{3a8}
+@anchor{gnat_rm/the_gnat_library id108}@anchor{3a6}@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{3a7}
@section @code{GNAT.SHA512} (@code{g-sha512.ads})
@@ -24845,7 +24359,7 @@ and the HMAC-SHA512 message authentication function as described
in RFC 2104 and FIPS PUB 198.
@node GNAT Signals g-signal ads,GNAT Sockets g-socket ads,GNAT SHA512 g-sha512 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id109}@anchor{3a9}@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{3aa}
+@anchor{gnat_rm/the_gnat_library id109}@anchor{3a8}@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{3a9}
@section @code{GNAT.Signals} (@code{g-signal.ads})
@@ -24857,7 +24371,7 @@ Provides the ability to manipulate the blocked status of signals on supported
targets.
@node GNAT Sockets g-socket ads,GNAT Source_Info g-souinf ads,GNAT Signals g-signal ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{3ab}@anchor{gnat_rm/the_gnat_library id110}@anchor{3ac}
+@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{3aa}@anchor{gnat_rm/the_gnat_library id110}@anchor{3ab}
@section @code{GNAT.Sockets} (@code{g-socket.ads})
@@ -24872,7 +24386,7 @@ on all native GNAT ports and on VxWorks cross prots. It is not implemented for
the LynxOS cross port.
@node GNAT Source_Info g-souinf ads,GNAT Spelling_Checker g-speche ads,GNAT Sockets g-socket ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{3ad}@anchor{gnat_rm/the_gnat_library id111}@anchor{3ae}
+@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{3ac}@anchor{gnat_rm/the_gnat_library id111}@anchor{3ad}
@section @code{GNAT.Source_Info} (@code{g-souinf.ads})
@@ -24886,7 +24400,7 @@ subprograms yielding the date and time of the current compilation (like the
C macros @code{__DATE__} and @code{__TIME__})
@node GNAT Spelling_Checker g-speche ads,GNAT Spelling_Checker_Generic g-spchge ads,GNAT Source_Info g-souinf ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id112}@anchor{3af}@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{3b0}
+@anchor{gnat_rm/the_gnat_library id112}@anchor{3ae}@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{3af}
@section @code{GNAT.Spelling_Checker} (@code{g-speche.ads})
@@ -24898,7 +24412,7 @@ Provides a function for determining whether one string is a plausible
near misspelling of another string.
@node GNAT Spelling_Checker_Generic g-spchge ads,GNAT Spitbol Patterns g-spipat ads,GNAT Spelling_Checker g-speche ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{3b1}@anchor{gnat_rm/the_gnat_library id113}@anchor{3b2}
+@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{3b0}@anchor{gnat_rm/the_gnat_library id113}@anchor{3b1}
@section @code{GNAT.Spelling_Checker_Generic} (@code{g-spchge.ads})
@@ -24911,7 +24425,7 @@ determining whether one string is a plausible near misspelling of another
string.
@node GNAT Spitbol Patterns g-spipat ads,GNAT Spitbol g-spitbo ads,GNAT Spelling_Checker_Generic g-spchge ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{3b3}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b4}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{3b2}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b3}
@section @code{GNAT.Spitbol.Patterns} (@code{g-spipat.ads})
@@ -24927,7 +24441,7 @@ the SNOBOL4 dynamic pattern construction and matching capabilities, using the
efficient algorithm developed by Robert Dewar for the SPITBOL system.
@node GNAT Spitbol g-spitbo ads,GNAT Spitbol Table_Boolean g-sptabo ads,GNAT Spitbol Patterns g-spipat ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3b5}@anchor{gnat_rm/the_gnat_library id115}@anchor{3b6}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3b4}@anchor{gnat_rm/the_gnat_library id115}@anchor{3b5}
@section @code{GNAT.Spitbol} (@code{g-spitbo.ads})
@@ -24942,7 +24456,7 @@ useful for constructing arbitrary mappings from strings in the style of
the SNOBOL4 TABLE function.
@node GNAT Spitbol Table_Boolean g-sptabo ads,GNAT Spitbol Table_Integer g-sptain ads,GNAT Spitbol g-spitbo ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id116}@anchor{3b7}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{3b8}
+@anchor{gnat_rm/the_gnat_library id116}@anchor{3b6}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{3b7}
@section @code{GNAT.Spitbol.Table_Boolean} (@code{g-sptabo.ads})
@@ -24957,7 +24471,7 @@ for type @code{Standard.Boolean}, giving an implementation of sets of
string values.
@node GNAT Spitbol Table_Integer g-sptain ads,GNAT Spitbol Table_VString g-sptavs ads,GNAT Spitbol Table_Boolean g-sptabo ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{3b9}@anchor{gnat_rm/the_gnat_library id117}@anchor{3ba}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{3b8}@anchor{gnat_rm/the_gnat_library id117}@anchor{3b9}
@section @code{GNAT.Spitbol.Table_Integer} (@code{g-sptain.ads})
@@ -24974,7 +24488,7 @@ for type @code{Standard.Integer}, giving an implementation of maps
from string to integer values.
@node GNAT Spitbol Table_VString g-sptavs ads,GNAT SSE g-sse ads,GNAT Spitbol Table_Integer g-sptain ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id118}@anchor{3bb}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3bc}
+@anchor{gnat_rm/the_gnat_library id118}@anchor{3ba}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3bb}
@section @code{GNAT.Spitbol.Table_VString} (@code{g-sptavs.ads})
@@ -24991,7 +24505,7 @@ a variable length string type, giving an implementation of general
maps from strings to strings.
@node GNAT SSE g-sse ads,GNAT SSE Vector_Types g-ssvety ads,GNAT Spitbol Table_VString g-sptavs ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id119}@anchor{3bd}@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3be}
+@anchor{gnat_rm/the_gnat_library id119}@anchor{3bc}@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3bd}
@section @code{GNAT.SSE} (@code{g-sse.ads})
@@ -25003,7 +24517,7 @@ targets. It exposes vector component types together with a general
introduction to the binding contents and use.
@node GNAT SSE Vector_Types g-ssvety ads,GNAT String_Hash g-strhas ads,GNAT SSE g-sse ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{3bf}@anchor{gnat_rm/the_gnat_library id120}@anchor{3c0}
+@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{3be}@anchor{gnat_rm/the_gnat_library id120}@anchor{3bf}
@section @code{GNAT.SSE.Vector_Types} (@code{g-ssvety.ads})
@@ -25012,7 +24526,7 @@ introduction to the binding contents and use.
SSE vector types for use with SSE related intrinsics.
@node GNAT String_Hash g-strhas ads,GNAT Strings g-string ads,GNAT SSE Vector_Types g-ssvety ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-string-hash-g-strhas-ads}@anchor{3c1}@anchor{gnat_rm/the_gnat_library id121}@anchor{3c2}
+@anchor{gnat_rm/the_gnat_library gnat-string-hash-g-strhas-ads}@anchor{3c0}@anchor{gnat_rm/the_gnat_library id121}@anchor{3c1}
@section @code{GNAT.String_Hash} (@code{g-strhas.ads})
@@ -25024,7 +24538,7 @@ Provides a generic hash function working on arrays of scalars. Both the scalar
type and the hash result type are parameters.
@node GNAT Strings g-string ads,GNAT String_Split g-strspl ads,GNAT String_Hash g-strhas ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3c3}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c4}
+@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3c2}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c3}
@section @code{GNAT.Strings} (@code{g-string.ads})
@@ -25034,7 +24548,7 @@ Common String access types and related subprograms. Basically it
defines a string access and an array of string access types.
@node GNAT String_Split g-strspl ads,GNAT Table g-table ads,GNAT Strings g-string ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{3c5}@anchor{gnat_rm/the_gnat_library id123}@anchor{3c6}
+@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{3c4}@anchor{gnat_rm/the_gnat_library id123}@anchor{3c5}
@section @code{GNAT.String_Split} (@code{g-strspl.ads})
@@ -25048,7 +24562,7 @@ to the resulting slices. This package is instantiated from
@code{GNAT.Array_Split}.
@node GNAT Table g-table ads,GNAT Task_Lock g-tasloc ads,GNAT String_Split g-strspl ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id124}@anchor{3c7}@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3c8}
+@anchor{gnat_rm/the_gnat_library id124}@anchor{3c6}@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3c7}
@section @code{GNAT.Table} (@code{g-table.ads})
@@ -25068,7 +24582,7 @@ while an instantiation of @code{GNAT.Dynamic_Tables} creates a type that can be
used to define dynamic instances of the table.
@node GNAT Task_Lock g-tasloc ads,GNAT Time_Stamp g-timsta ads,GNAT Table g-table ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id125}@anchor{3c9}@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3ca}
+@anchor{gnat_rm/the_gnat_library id125}@anchor{3c8}@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3c9}
@section @code{GNAT.Task_Lock} (@code{g-tasloc.ads})
@@ -25085,7 +24599,7 @@ single global task lock. Appropriate for use in situations where contention
between tasks is very rarely expected.
@node GNAT Time_Stamp g-timsta ads,GNAT Threads g-thread ads,GNAT Task_Lock g-tasloc ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id126}@anchor{3cb}@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3cc}
+@anchor{gnat_rm/the_gnat_library id126}@anchor{3ca}@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3cb}
@section @code{GNAT.Time_Stamp} (@code{g-timsta.ads})
@@ -25100,7 +24614,7 @@ represents the current date and time in ISO 8601 format. This is a very simple
routine with minimal code and there are no dependencies on any other unit.
@node GNAT Threads g-thread ads,GNAT Traceback g-traceb ads,GNAT Time_Stamp g-timsta ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id127}@anchor{3cd}@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{3ce}
+@anchor{gnat_rm/the_gnat_library id127}@anchor{3cc}@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{3cd}
@section @code{GNAT.Threads} (@code{g-thread.ads})
@@ -25117,7 +24631,7 @@ further details if your program has threads that are created by a non-Ada
environment which then accesses Ada code.
@node GNAT Traceback g-traceb ads,GNAT Traceback Symbolic g-trasym ads,GNAT Threads g-thread ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id128}@anchor{3cf}@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3d0}
+@anchor{gnat_rm/the_gnat_library id128}@anchor{3ce}@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3cf}
@section @code{GNAT.Traceback} (@code{g-traceb.ads})
@@ -25129,7 +24643,7 @@ Provides a facility for obtaining non-symbolic traceback information, useful
in various debugging situations.
@node GNAT Traceback Symbolic g-trasym ads,GNAT UTF_32 g-table ads,GNAT Traceback g-traceb ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3d1}@anchor{gnat_rm/the_gnat_library id129}@anchor{3d2}
+@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3d0}@anchor{gnat_rm/the_gnat_library id129}@anchor{3d1}
@section @code{GNAT.Traceback.Symbolic} (@code{g-trasym.ads})
@@ -25138,7 +24652,7 @@ in various debugging situations.
@geindex Trace back facilities
@node GNAT UTF_32 g-table ads,GNAT Wide_Spelling_Checker g-u3spch ads,GNAT Traceback Symbolic g-trasym ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id130}@anchor{3d3}@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{3d4}
+@anchor{gnat_rm/the_gnat_library id130}@anchor{3d2}@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{3d3}
@section @code{GNAT.UTF_32} (@code{g-table.ads})
@@ -25157,7 +24671,7 @@ lower case to upper case fold routine corresponding to
the Ada 2005 rules for identifier equivalence.
@node GNAT Wide_Spelling_Checker g-u3spch ads,GNAT Wide_Spelling_Checker g-wispch ads,GNAT UTF_32 g-table ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-u3spch-ads}@anchor{3d5}@anchor{gnat_rm/the_gnat_library id131}@anchor{3d6}
+@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-u3spch-ads}@anchor{3d4}@anchor{gnat_rm/the_gnat_library id131}@anchor{3d5}
@section @code{GNAT.Wide_Spelling_Checker} (@code{g-u3spch.ads})
@@ -25170,7 +24684,7 @@ near misspelling of another wide wide string, where the strings are represented
using the UTF_32_String type defined in System.Wch_Cnv.
@node GNAT Wide_Spelling_Checker g-wispch ads,GNAT Wide_String_Split g-wistsp ads,GNAT Wide_Spelling_Checker g-u3spch ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3d7}@anchor{gnat_rm/the_gnat_library id132}@anchor{3d8}
+@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3d6}@anchor{gnat_rm/the_gnat_library id132}@anchor{3d7}
@section @code{GNAT.Wide_Spelling_Checker} (@code{g-wispch.ads})
@@ -25182,7 +24696,7 @@ Provides a function for determining whether one wide string is a plausible
near misspelling of another wide string.
@node GNAT Wide_String_Split g-wistsp ads,GNAT Wide_Wide_Spelling_Checker g-zspche ads,GNAT Wide_Spelling_Checker g-wispch ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id133}@anchor{3d9}@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3da}
+@anchor{gnat_rm/the_gnat_library id133}@anchor{3d8}@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3d9}
@section @code{GNAT.Wide_String_Split} (@code{g-wistsp.ads})
@@ -25196,7 +24710,7 @@ to the resulting slices. This package is instantiated from
@code{GNAT.Array_Split}.
@node GNAT Wide_Wide_Spelling_Checker g-zspche ads,GNAT Wide_Wide_String_Split g-zistsp ads,GNAT Wide_String_Split g-wistsp ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{3db}@anchor{gnat_rm/the_gnat_library id134}@anchor{3dc}
+@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{3da}@anchor{gnat_rm/the_gnat_library id134}@anchor{3db}
@section @code{GNAT.Wide_Wide_Spelling_Checker} (@code{g-zspche.ads})
@@ -25208,7 +24722,7 @@ Provides a function for determining whether one wide wide string is a plausible
near misspelling of another wide wide string.
@node GNAT Wide_Wide_String_Split g-zistsp ads,Interfaces C Extensions i-cexten ads,GNAT Wide_Wide_Spelling_Checker g-zspche ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{3dd}@anchor{gnat_rm/the_gnat_library id135}@anchor{3de}
+@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{3dc}@anchor{gnat_rm/the_gnat_library id135}@anchor{3dd}
@section @code{GNAT.Wide_Wide_String_Split} (@code{g-zistsp.ads})
@@ -25222,7 +24736,7 @@ to the resulting slices. This package is instantiated from
@code{GNAT.Array_Split}.
@node Interfaces C Extensions i-cexten ads,Interfaces C Streams i-cstrea ads,GNAT Wide_Wide_String_Split g-zistsp ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3df}@anchor{gnat_rm/the_gnat_library id136}@anchor{3e0}
+@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3de}@anchor{gnat_rm/the_gnat_library id136}@anchor{3df}
@section @code{Interfaces.C.Extensions} (@code{i-cexten.ads})
@@ -25233,7 +24747,7 @@ for use with either manually or automatically generated bindings
to C libraries.
@node Interfaces C Streams i-cstrea ads,Interfaces Packed_Decimal i-pacdec ads,Interfaces C Extensions i-cexten ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3e1}@anchor{gnat_rm/the_gnat_library id137}@anchor{3e2}
+@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3e0}@anchor{gnat_rm/the_gnat_library id137}@anchor{3e1}
@section @code{Interfaces.C.Streams} (@code{i-cstrea.ads})
@@ -25246,7 +24760,7 @@ This package is a binding for the most commonly used operations
on C streams.
@node Interfaces Packed_Decimal i-pacdec ads,Interfaces VxWorks i-vxwork ads,Interfaces C Streams i-cstrea ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id138}@anchor{3e3}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3e4}
+@anchor{gnat_rm/the_gnat_library id138}@anchor{3e2}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3e3}
@section @code{Interfaces.Packed_Decimal} (@code{i-pacdec.ads})
@@ -25261,7 +24775,7 @@ from a packed decimal format compatible with that used on IBM
mainframes.
@node Interfaces VxWorks i-vxwork ads,Interfaces VxWorks Int_Connection i-vxinco ads,Interfaces Packed_Decimal i-pacdec ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id139}@anchor{3e5}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3e6}
+@anchor{gnat_rm/the_gnat_library id139}@anchor{3e4}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3e5}
@section @code{Interfaces.VxWorks} (@code{i-vxwork.ads})
@@ -25277,7 +24791,7 @@ In particular, it interfaces with the
VxWorks hardware interrupt facilities.
@node Interfaces VxWorks Int_Connection i-vxinco ads,Interfaces VxWorks IO i-vxwoio ads,Interfaces VxWorks i-vxwork ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3e7}@anchor{gnat_rm/the_gnat_library id140}@anchor{3e8}
+@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3e6}@anchor{gnat_rm/the_gnat_library id140}@anchor{3e7}
@section @code{Interfaces.VxWorks.Int_Connection} (@code{i-vxinco.ads})
@@ -25293,7 +24807,7 @@ intConnect() with a custom routine for installing interrupt
handlers.
@node Interfaces VxWorks IO i-vxwoio ads,System Address_Image s-addima ads,Interfaces VxWorks Int_Connection i-vxinco ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3e9}@anchor{gnat_rm/the_gnat_library id141}@anchor{3ea}
+@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3e8}@anchor{gnat_rm/the_gnat_library id141}@anchor{3e9}
@section @code{Interfaces.VxWorks.IO} (@code{i-vxwoio.ads})
@@ -25316,7 +24830,7 @@ function codes. A particular use of this package is
to enable the use of Get_Immediate under VxWorks.
@node System Address_Image s-addima ads,System Assertions s-assert ads,Interfaces VxWorks IO i-vxwoio ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3eb}@anchor{gnat_rm/the_gnat_library id142}@anchor{3ec}
+@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3ea}@anchor{gnat_rm/the_gnat_library id142}@anchor{3eb}
@section @code{System.Address_Image} (@code{s-addima.ads})
@@ -25332,7 +24846,7 @@ function that gives an (implementation dependent)
string which identifies an address.
@node System Assertions s-assert ads,System Atomic_Counters s-atocou ads,System Address_Image s-addima ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3ed}@anchor{gnat_rm/the_gnat_library id143}@anchor{3ee}
+@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3ec}@anchor{gnat_rm/the_gnat_library id143}@anchor{3ed}
@section @code{System.Assertions} (@code{s-assert.ads})
@@ -25348,7 +24862,7 @@ by an run-time assertion failure, as well as the routine that
is used internally to raise this assertion.
@node System Atomic_Counters s-atocou ads,System Memory s-memory ads,System Assertions s-assert ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id144}@anchor{3ef}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3f0}
+@anchor{gnat_rm/the_gnat_library id144}@anchor{3ee}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3ef}
@section @code{System.Atomic_Counters} (@code{s-atocou.ads})
@@ -25362,7 +24876,7 @@ on most targets, including all Alpha, ia64, PowerPC, SPARC V9,
x86, and x86_64 platforms.
@node System Memory s-memory ads,System Multiprocessors s-multip ads,System Atomic_Counters s-atocou ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3f1}@anchor{gnat_rm/the_gnat_library id145}@anchor{3f2}
+@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3f0}@anchor{gnat_rm/the_gnat_library id145}@anchor{3f1}
@section @code{System.Memory} (@code{s-memory.ads})
@@ -25380,7 +24894,7 @@ calls to this unit may be made for low level allocation uses (for
example see the body of @code{GNAT.Tables}).
@node System Multiprocessors s-multip ads,System Multiprocessors Dispatching_Domains s-mudido ads,System Memory s-memory ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id146}@anchor{3f3}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3f4}
+@anchor{gnat_rm/the_gnat_library id146}@anchor{3f2}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3f3}
@section @code{System.Multiprocessors} (@code{s-multip.ads})
@@ -25393,7 +24907,7 @@ in GNAT we also make it available in Ada 95 and Ada 2005 (where it is
technically an implementation-defined addition).
@node System Multiprocessors Dispatching_Domains s-mudido ads,System Partition_Interface s-parint ads,System Multiprocessors s-multip ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{3f5}@anchor{gnat_rm/the_gnat_library id147}@anchor{3f6}
+@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{3f4}@anchor{gnat_rm/the_gnat_library id147}@anchor{3f5}
@section @code{System.Multiprocessors.Dispatching_Domains} (@code{s-mudido.ads})
@@ -25406,7 +24920,7 @@ in GNAT we also make it available in Ada 95 and Ada 2005 (where it is
technically an implementation-defined addition).
@node System Partition_Interface s-parint ads,System Pool_Global s-pooglo ads,System Multiprocessors Dispatching_Domains s-mudido ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id148}@anchor{3f7}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3f8}
+@anchor{gnat_rm/the_gnat_library id148}@anchor{3f6}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3f7}
@section @code{System.Partition_Interface} (@code{s-parint.ads})
@@ -25419,7 +24933,7 @@ is used primarily in a distribution context when using Annex E
with @code{GLADE}.
@node System Pool_Global s-pooglo ads,System Pool_Local s-pooloc ads,System Partition_Interface s-parint ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id149}@anchor{3f9}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3fa}
+@anchor{gnat_rm/the_gnat_library id149}@anchor{3f8}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3f9}
@section @code{System.Pool_Global} (@code{s-pooglo.ads})
@@ -25436,7 +24950,7 @@ declared. It uses malloc/free to allocate/free and does not attempt to
do any automatic reclamation.
@node System Pool_Local s-pooloc ads,System Restrictions s-restri ads,System Pool_Global s-pooglo ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{3fb}@anchor{gnat_rm/the_gnat_library id150}@anchor{3fc}
+@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{3fa}@anchor{gnat_rm/the_gnat_library id150}@anchor{3fb}
@section @code{System.Pool_Local} (@code{s-pooloc.ads})
@@ -25453,7 +24967,7 @@ a list of allocated blocks, so that all storage allocated for the pool can
be freed automatically when the pool is finalized.
@node System Restrictions s-restri ads,System Rident s-rident ads,System Pool_Local s-pooloc ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{3fd}@anchor{gnat_rm/the_gnat_library id151}@anchor{3fe}
+@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{3fc}@anchor{gnat_rm/the_gnat_library id151}@anchor{3fd}
@section @code{System.Restrictions} (@code{s-restri.ads})
@@ -25469,7 +24983,7 @@ compiler determined information on which restrictions
are violated by one or more packages in the partition.
@node System Rident s-rident ads,System Strings Stream_Ops s-ststop ads,System Restrictions s-restri ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{3ff}@anchor{gnat_rm/the_gnat_library id152}@anchor{400}
+@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{3fe}@anchor{gnat_rm/the_gnat_library id152}@anchor{3ff}
@section @code{System.Rident} (@code{s-rident.ads})
@@ -25485,7 +24999,7 @@ since the necessary instantiation is included in
package System.Restrictions.
@node System Strings Stream_Ops s-ststop ads,System Unsigned_Types s-unstyp ads,System Rident s-rident ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id153}@anchor{401}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{402}
+@anchor{gnat_rm/the_gnat_library id153}@anchor{400}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{401}
@section @code{System.Strings.Stream_Ops} (@code{s-ststop.ads})
@@ -25501,7 +25015,7 @@ stream attributes are applied to string types, but the subprograms in this
package can be used directly by application programs.
@node System Unsigned_Types s-unstyp ads,System Wch_Cnv s-wchcnv ads,System Strings Stream_Ops s-ststop ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{403}@anchor{gnat_rm/the_gnat_library id154}@anchor{404}
+@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{402}@anchor{gnat_rm/the_gnat_library id154}@anchor{403}
@section @code{System.Unsigned_Types} (@code{s-unstyp.ads})
@@ -25514,7 +25028,7 @@ also contains some related definitions for other specialized types
used by the compiler in connection with packed array types.
@node System Wch_Cnv s-wchcnv ads,System Wch_Con s-wchcon ads,System Unsigned_Types s-unstyp ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{405}@anchor{gnat_rm/the_gnat_library id155}@anchor{406}
+@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{404}@anchor{gnat_rm/the_gnat_library id155}@anchor{405}
@section @code{System.Wch_Cnv} (@code{s-wchcnv.ads})
@@ -25535,7 +25049,7 @@ encoding method. It uses definitions in
package @code{System.Wch_Con}.
@node System Wch_Con s-wchcon ads,,System Wch_Cnv s-wchcnv ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id156}@anchor{407}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{408}
+@anchor{gnat_rm/the_gnat_library id156}@anchor{406}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{407}
@section @code{System.Wch_Con} (@code{s-wchcon.ads})
@@ -25547,7 +25061,7 @@ in ordinary strings. These definitions are used by
the package @code{System.Wch_Cnv}.
@node Interfacing to Other Languages,Specialized Needs Annexes,The GNAT Library,Top
-@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11}@anchor{gnat_rm/interfacing_to_other_languages doc}@anchor{409}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{40a}
+@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11}@anchor{gnat_rm/interfacing_to_other_languages doc}@anchor{408}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{409}
@chapter Interfacing to Other Languages
@@ -25565,7 +25079,7 @@ provided.
@end menu
@node Interfacing to C,Interfacing to C++,,Interfacing to Other Languages
-@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{40b}@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{40c}
+@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{40a}@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{40b}
@section Interfacing to C
@@ -25705,7 +25219,7 @@ of the length corresponding to the @code{type'Size} value in Ada.
@end itemize
@node Interfacing to C++,Interfacing to COBOL,Interfacing to C,Interfacing to Other Languages
-@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{40d}@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{4a}
+@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{40c}@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{47}
@section Interfacing to C++
@@ -25762,7 +25276,7 @@ The @code{External_Name} is the name of the C++ RTTI symbol. You can then
cover a specific C++ exception in an exception handler.
@node Interfacing to COBOL,Interfacing to Fortran,Interfacing to C++,Interfacing to Other Languages
-@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{40e}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{40f}
+@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{40d}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{40e}
@section Interfacing to COBOL
@@ -25770,7 +25284,7 @@ Interfacing to COBOL is achieved as described in section B.4 of
the Ada Reference Manual.
@node Interfacing to Fortran,Interfacing to non-GNAT Ada code,Interfacing to COBOL,Interfacing to Other Languages
-@anchor{gnat_rm/interfacing_to_other_languages id6}@anchor{410}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{411}
+@anchor{gnat_rm/interfacing_to_other_languages id6}@anchor{40f}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{410}
@section Interfacing to Fortran
@@ -25780,7 +25294,7 @@ multi-dimensional array causes the array to be stored in column-major
order as required for convenient interface to Fortran.
@node Interfacing to non-GNAT Ada code,,Interfacing to Fortran,Interfacing to Other Languages
-@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{412}@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{413}
+@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{411}@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{412}
@section Interfacing to non-GNAT Ada code
@@ -25804,7 +25318,7 @@ values or simple record types without variants, or simple array
types with fixed bounds.
@node Specialized Needs Annexes,Implementation of Specific Ada Features,Interfacing to Other Languages,Top
-@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12}@anchor{gnat_rm/specialized_needs_annexes doc}@anchor{414}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{415}
+@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12}@anchor{gnat_rm/specialized_needs_annexes doc}@anchor{413}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{414}
@chapter Specialized Needs Annexes
@@ -25845,7 +25359,7 @@ in Ada 2005) is fully implemented.
@end table
@node Implementation of Specific Ada Features,Implementation of Ada 2012 Features,Specialized Needs Annexes,Top
-@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13}@anchor{gnat_rm/implementation_of_specific_ada_features doc}@anchor{416}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{417}
+@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13}@anchor{gnat_rm/implementation_of_specific_ada_features doc}@anchor{415}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{416}
@chapter Implementation of Specific Ada Features
@@ -25863,7 +25377,7 @@ facilities.
@end menu
@node Machine Code Insertions,GNAT Implementation of Tasking,,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{16c}@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{418}
+@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{16a}@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{417}
@section Machine Code Insertions
@@ -26031,7 +25545,7 @@ according to normal visibility rules. In particular if there is no
qualification is required.
@node GNAT Implementation of Tasking,GNAT Implementation of Shared Passive Packages,Machine Code Insertions,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{419}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{41a}
+@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{418}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{419}
@section GNAT Implementation of Tasking
@@ -26047,7 +25561,7 @@ to compliance with the Real-Time Systems Annex.
@end menu
@node Mapping Ada Tasks onto the Underlying Kernel Threads,Ensuring Compliance with the Real-Time Annex,,GNAT Implementation of Tasking
-@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{41b}@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{41c}
+@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{41a}@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{41b}
@subsection Mapping Ada Tasks onto the Underlying Kernel Threads
@@ -26116,7 +25630,7 @@ support this functionality when the parent contains more than one task.
@geindex Forking a new process
@node Ensuring Compliance with the Real-Time Annex,Support for Locking Policies,Mapping Ada Tasks onto the Underlying Kernel Threads,GNAT Implementation of Tasking
-@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{41d}@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{41e}
+@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{41c}@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{41d}
@subsection Ensuring Compliance with the Real-Time Annex
@@ -26167,7 +25681,7 @@ placed at the end.
@c Support_for_Locking_Policies
@node Support for Locking Policies,,Ensuring Compliance with the Real-Time Annex,GNAT Implementation of Tasking
-@anchor{gnat_rm/implementation_of_specific_ada_features support-for-locking-policies}@anchor{41f}
+@anchor{gnat_rm/implementation_of_specific_ada_features support-for-locking-policies}@anchor{41e}
@subsection Support for Locking Policies
@@ -26201,7 +25715,7 @@ then ceiling locking is used.
Otherwise, the @code{Ceiling_Locking} policy is ignored.
@node GNAT Implementation of Shared Passive Packages,Code Generation for Array Aggregates,GNAT Implementation of Tasking,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{420}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{421}
+@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{41f}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{420}
@section GNAT Implementation of Shared Passive Packages
@@ -26299,7 +25813,7 @@ This is used to provide the required locking
semantics for proper protected object synchronization.
@node Code Generation for Array Aggregates,The Size of Discriminated Records with Default Discriminants,GNAT Implementation of Shared Passive Packages,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features code-generation-for-array-aggregates}@anchor{422}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{423}
+@anchor{gnat_rm/implementation_of_specific_ada_features code-generation-for-array-aggregates}@anchor{421}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{422}
@section Code Generation for Array Aggregates
@@ -26330,7 +25844,7 @@ component values and static subtypes also lead to simpler code.
@end menu
@node Static constant aggregates with static bounds,Constant aggregates with unconstrained nominal types,,Code Generation for Array Aggregates
-@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{424}@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{425}
+@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{423}@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{424}
@subsection Static constant aggregates with static bounds
@@ -26377,7 +25891,7 @@ Zero2: constant two_dim := (others => (others => 0));
@end example
@node Constant aggregates with unconstrained nominal types,Aggregates with static bounds,Static constant aggregates with static bounds,Code Generation for Array Aggregates
-@anchor{gnat_rm/implementation_of_specific_ada_features constant-aggregates-with-unconstrained-nominal-types}@anchor{426}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{427}
+@anchor{gnat_rm/implementation_of_specific_ada_features constant-aggregates-with-unconstrained-nominal-types}@anchor{425}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{426}
@subsection Constant aggregates with unconstrained nominal types
@@ -26392,7 +25906,7 @@ Cr_Unc : constant One_Unc := (12,24,36);
@end example
@node Aggregates with static bounds,Aggregates with nonstatic bounds,Constant aggregates with unconstrained nominal types,Code Generation for Array Aggregates
-@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{428}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{429}
+@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{427}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{428}
@subsection Aggregates with static bounds
@@ -26420,7 +25934,7 @@ end loop;
@end example
@node Aggregates with nonstatic bounds,Aggregates in assignment statements,Aggregates with static bounds,Code Generation for Array Aggregates
-@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{42a}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{42b}
+@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{429}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{42a}
@subsection Aggregates with nonstatic bounds
@@ -26431,7 +25945,7 @@ have to be applied to sub-arrays individually, if they do not have statically
compatible subtypes.
@node Aggregates in assignment statements,,Aggregates with nonstatic bounds,Code Generation for Array Aggregates
-@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{42c}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{42d}
+@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{42b}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{42c}
@subsection Aggregates in assignment statements
@@ -26473,7 +25987,7 @@ a temporary (created either by the front-end or the code generator) and then
that temporary will be copied onto the target.
@node The Size of Discriminated Records with Default Discriminants,Strict Conformance to the Ada Reference Manual,Code Generation for Array Aggregates,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{42e}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{42f}
+@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{42d}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{42e}
@section The Size of Discriminated Records with Default Discriminants
@@ -26553,7 +26067,7 @@ say) must be consistent, so it is imperative that the object, once created,
remain invariant.
@node Strict Conformance to the Ada Reference Manual,,The Size of Discriminated Records with Default Discriminants,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{430}@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{431}
+@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{42f}@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{430}
@section Strict Conformance to the Ada Reference Manual
@@ -26580,7 +26094,7 @@ behavior (although at the cost of a significant performance penalty), so
infinite and NaN values are properly generated.
@node Implementation of Ada 2012 Features,Obsolescent Features,Implementation of Specific Ada Features,Top
-@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{432}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{433}
+@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{431}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{432}
@chapter Implementation of Ada 2012 Features
@@ -28746,7 +28260,7 @@ RM References: H.04 (8/1)
@end itemize
@node Obsolescent Features,Compatibility and Porting Guide,Implementation of Ada 2012 Features,Top
-@anchor{gnat_rm/obsolescent_features id1}@anchor{434}@anchor{gnat_rm/obsolescent_features doc}@anchor{435}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{15}
+@anchor{gnat_rm/obsolescent_features id1}@anchor{433}@anchor{gnat_rm/obsolescent_features doc}@anchor{434}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{15}
@chapter Obsolescent Features
@@ -28765,7 +28279,7 @@ compatibility purposes.
@end menu
@node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features id2}@anchor{436}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{437}
+@anchor{gnat_rm/obsolescent_features id2}@anchor{435}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{436}
@section pragma No_Run_Time
@@ -28778,7 +28292,7 @@ preferred usage is to use an appropriately configured run-time that
includes just those features that are to be made accessible.
@node pragma Ravenscar,pragma Restricted_Run_Time,pragma No_Run_Time,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features id3}@anchor{438}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{439}
+@anchor{gnat_rm/obsolescent_features id3}@anchor{437}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{438}
@section pragma Ravenscar
@@ -28787,7 +28301,7 @@ The pragma @code{Ravenscar} has exactly the same effect as pragma
is part of the new Ada 2005 standard.
@node pragma Restricted_Run_Time,pragma Task_Info,pragma Ravenscar,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{43a}@anchor{gnat_rm/obsolescent_features id4}@anchor{43b}
+@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{439}@anchor{gnat_rm/obsolescent_features id4}@anchor{43a}
@section pragma Restricted_Run_Time
@@ -28797,7 +28311,7 @@ preferred since the Ada 2005 pragma @code{Profile} is intended for
this kind of implementation dependent addition.
@node pragma Task_Info,package System Task_Info s-tasinf ads,pragma Restricted_Run_Time,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{43c}@anchor{gnat_rm/obsolescent_features id5}@anchor{43d}
+@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{43b}@anchor{gnat_rm/obsolescent_features id5}@anchor{43c}
@section pragma Task_Info
@@ -28823,7 +28337,7 @@ in the spec of package System.Task_Info in the runtime
library.
@node package System Task_Info s-tasinf ads,,pragma Task_Info,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{43e}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{43f}
+@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{43d}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{43e}
@section package System.Task_Info (@code{s-tasinf.ads})
@@ -28833,7 +28347,7 @@ to support the @code{Task_Info} pragma. The predefined Ada package
standard replacement for GNAT's @code{Task_Info} functionality.
@node Compatibility and Porting Guide,GNU Free Documentation License,Obsolescent Features,Top
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{16}@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{440}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{441}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{16}@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{43f}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{440}
@chapter Compatibility and Porting Guide
@@ -28855,7 +28369,7 @@ applications developed in other Ada environments.
@end menu
@node Writing Portable Fixed-Point Declarations,Compatibility with Ada 83,,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{442}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{443}
+@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{441}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{442}
@section Writing Portable Fixed-Point Declarations
@@ -28977,7 +28491,7 @@ If you follow this scheme you will be guaranteed that your fixed-point
types will be portable.
@node Compatibility with Ada 83,Compatibility between Ada 95 and Ada 2005,Writing Portable Fixed-Point Declarations,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{444}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{445}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{443}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{444}
@section Compatibility with Ada 83
@@ -29005,7 +28519,7 @@ following subsections treat the most likely issues to be encountered.
@end menu
@node Legal Ada 83 programs that are illegal in Ada 95,More deterministic semantics,,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{446}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{447}
+@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{445}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{446}
@subsection Legal Ada 83 programs that are illegal in Ada 95
@@ -29105,7 +28619,7 @@ the fix is usually simply to add the @code{(<>)} to the generic declaration.
@end itemize
@node More deterministic semantics,Changed semantics,Legal Ada 83 programs that are illegal in Ada 95,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{448}@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{449}
+@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{447}@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{448}
@subsection More deterministic semantics
@@ -29133,7 +28647,7 @@ which open select branches are executed.
@end itemize
@node Changed semantics,Other language compatibility issues,More deterministic semantics,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{44a}@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{44b}
+@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{449}@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{44a}
@subsection Changed semantics
@@ -29175,7 +28689,7 @@ covers only the restricted range.
@end itemize
@node Other language compatibility issues,,Changed semantics,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{44c}@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{44d}
+@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{44b}@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{44c}
@subsection Other language compatibility issues
@@ -29208,7 +28722,7 @@ include @code{pragma Interface} and the floating point type attributes
@end itemize
@node Compatibility between Ada 95 and Ada 2005,Implementation-dependent characteristics,Compatibility with Ada 83,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{44e}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{44f}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{44d}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{44e}
@section Compatibility between Ada 95 and Ada 2005
@@ -29280,7 +28794,7 @@ can declare a function returning a value from an anonymous access type.
@end itemize
@node Implementation-dependent characteristics,Compatibility with Other Ada Systems,Compatibility between Ada 95 and Ada 2005,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{450}@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{451}
+@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{44f}@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{450}
@section Implementation-dependent characteristics
@@ -29303,7 +28817,7 @@ transition from certain Ada 83 compilers.
@end menu
@node Implementation-defined pragmas,Implementation-defined attributes,,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{452}@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{453}
+@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{451}@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{452}
@subsection Implementation-defined pragmas
@@ -29325,7 +28839,7 @@ avoiding compiler rejection of units that contain such pragmas; they are not
relevant in a GNAT context and hence are not otherwise implemented.
@node Implementation-defined attributes,Libraries,Implementation-defined pragmas,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{454}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{455}
+@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{453}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{454}
@subsection Implementation-defined attributes
@@ -29339,7 +28853,7 @@ Ada 83, GNAT supplies the attributes @code{Bit}, @code{Machine_Size} and
@code{Type_Class}.
@node Libraries,Elaboration order,Implementation-defined attributes,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{456}@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{457}
+@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{455}@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{456}
@subsection Libraries
@@ -29368,7 +28882,7 @@ be preferable to retrofit the application using modular types.
@end itemize
@node Elaboration order,Target-specific aspects,Libraries,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{458}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{459}
+@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{457}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{458}
@subsection Elaboration order
@@ -29404,7 +28918,7 @@ pragmas either globally (as an effect of the @emph{-gnatE} switch) or locally
@end itemize
@node Target-specific aspects,,Elaboration order,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{45a}@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{45b}
+@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{459}@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{45a}
@subsection Target-specific aspects
@@ -29417,10 +28931,10 @@ on the robustness of the original design. Moreover, Ada 95 (and thus
Ada 2005 and Ada 2012) are sometimes
incompatible with typical Ada 83 compiler practices regarding implicit
packing, the meaning of the Size attribute, and the size of access values.
-GNAT's approach to these issues is described in @ref{45c,,Representation Clauses}.
+GNAT's approach to these issues is described in @ref{45b,,Representation Clauses}.
@node Compatibility with Other Ada Systems,Representation Clauses,Implementation-dependent characteristics,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{45d}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{45e}
+@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{45c}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{45d}
@section Compatibility with Other Ada Systems
@@ -29463,7 +28977,7 @@ far beyond this minimal set, as described in the next section.
@end itemize
@node Representation Clauses,Compatibility with HP Ada 83,Compatibility with Other Ada Systems,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{45c}@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{45f}
+@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{45b}@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{45e}
@section Representation Clauses
@@ -29556,7 +29070,7 @@ with thin pointers.
@end itemize
@node Compatibility with HP Ada 83,,Representation Clauses,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{460}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{461}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{45f}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{460}
@section Compatibility with HP Ada 83
@@ -29586,7 +29100,7 @@ extension of package System.
@end itemize
@node GNU Free Documentation License,Index,Compatibility and Porting Guide,Top
-@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{462}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{463}
+@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{461}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{462}
@chapter GNU Free Documentation License
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 861a92e..ab47192 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -21,7 +21,7 @@
@copying
@quotation
-GNAT User's Guide for Native Platforms , Dec 10, 2019
+GNAT User's Guide for Native Platforms , Jul 01, 2020
AdaCore
@@ -85,15 +85,14 @@ About This Guide
* What This Guide Contains::
* What You Should Know before Reading This Guide::
* Related Information::
-* A Note to Readers of Previous Versions of the Manual::
* Conventions::
Getting Started with GNAT
+* System Requirements::
* Running GNAT::
* Running a Simple Ada Program::
* Running a Program with Multiple Units::
-* Using the gnatmake Utility::
The GNAT Compilation Model
@@ -313,8 +312,6 @@ GNAT Utility Programs
* The File Cleanup Utility gnatclean::
* The GNAT Library Browser gnatls::
-* The Cross-Referencing Tools gnatxref and gnatfind::
-* The Ada to HTML Converter gnathtml::
The File Cleanup Utility gnatclean
@@ -327,25 +324,6 @@ The GNAT Library Browser gnatls
* Switches for gnatls::
* Example of gnatls Usage::
-The Cross-Referencing Tools gnatxref and gnatfind
-
-* gnatxref Switches::
-* gnatfind Switches::
-* Configuration Files for gnatxref and gnatfind::
-* Regular Expressions in gnatfind and gnatxref::
-* Examples of gnatxref Usage::
-* Examples of gnatfind Usage::
-
-Examples of gnatxref Usage
-
-* General Usage::
-* Using gnatxref with vi::
-
-The Ada to HTML Converter gnathtml
-
-* Invoking gnathtml::
-* Installing gnathtml::
-
GNAT and Program Execution
* Running and Debugging Ada Programs::
@@ -571,19 +549,18 @@ toolset for the full Ada programming language.
It documents the features of the compiler and tools, and explains
how to use them to build Ada applications.
-GNAT implements Ada 95, Ada 2005 and Ada 2012, and it may also be
+GNAT implements Ada 95, Ada 2005, Ada 2012, and Ada 202x, and it may also be
invoked in Ada 83 compatibility mode.
By default, GNAT assumes Ada 2012, but you can override with a
compiler switch (@ref{6,,Compiling Different Versions of Ada})
to explicitly specify the language version.
Throughout this manual, references to 'Ada' without a year suffix
-apply to all Ada 95/2005/2012 versions of the language.
+apply to all Ada versions of the language, starting with Ada 95.
@menu
* What This Guide Contains::
* What You Should Know before Reading This Guide::
* Related Information::
-* A Note to Readers of Previous Versions of the Manual::
* Conventions::
@end menu
@@ -656,12 +633,10 @@ in an Ada program.
This guide assumes a basic familiarity with the Ada 95 language, as
described in the International Standard ANSI/ISO/IEC-8652:1995, January
1995.
-It does not require knowledge of the features introduced by Ada 2005
-or Ada 2012.
Reference manuals for Ada 95, Ada 2005, and Ada 2012 are included in
the GNAT documentation package.
-@node Related Information,A Note to Readers of Previous Versions of the Manual,What You Should Know before Reading This Guide,About This Guide
+@node Related Information,Conventions,What You Should Know before Reading This Guide,About This Guide
@anchor{gnat_ugn/about_this_guide related-information}@anchor{12}
@section Related Information
@@ -699,145 +674,8 @@ for full information on the extensible editor and programming
environment Emacs.
@end itemize
-@node A Note to Readers of Previous Versions of the Manual,Conventions,Related Information,About This Guide
-@anchor{gnat_ugn/about_this_guide a-note-to-readers-of-previous-versions-of-the-manual}@anchor{13}
-@section A Note to Readers of Previous Versions of the Manual
-
-
-In early 2015 the GNAT manuals were transitioned to the
-reStructuredText (rst) / Sphinx documentation generator technology.
-During that process the @cite{GNAT User's Guide} was reorganized
-so that related topics would be described together in the same chapter
-or appendix. Here's a summary of the major changes realized in
-the new document structure.
-
-
-@itemize *
-
-@item
-@ref{9,,The GNAT Compilation Model} has been extended so that it now covers
-the following material:
-
-
-@itemize -
-
-@item
-The @code{gnatname}, @code{gnatkr}, and @code{gnatchop} tools
-
-@item
-@ref{14,,Configuration Pragmas}
-
-@item
-@ref{15,,GNAT and Libraries}
-
-@item
-@ref{16,,Conditional Compilation} including @ref{17,,Preprocessing with gnatprep}
-and @ref{18,,Integrated Preprocessing}
-
-@item
-@ref{19,,Generating Ada Bindings for C and C++ headers}
-
-@item
-@ref{1a,,Using GNAT Files with External Tools}
-@end itemize
-
-@item
-@ref{a,,Building Executable Programs with GNAT} is a new chapter consolidating
-the following content:
-
-
-@itemize -
-
-@item
-@ref{1b,,Building with gnatmake}
-
-@item
-@ref{1c,,Compiling with gcc}
-
-@item
-@ref{1d,,Binding with gnatbind}
-
-@item
-@ref{1e,,Linking with gnatlink}
-
-@item
-@ref{1f,,Using the GNU make Utility}
-@end itemize
-
-@item
-@ref{b,,GNAT Utility Programs} is a new chapter consolidating the information about several
-GNAT tools:
-
-
-
-@itemize -
-
-@item
-@ref{20,,The File Cleanup Utility gnatclean}
-
-@item
-@ref{21,,The GNAT Library Browser gnatls}
-
-@item
-@ref{22,,The Cross-Referencing Tools gnatxref and gnatfind}
-
-@item
-@ref{23,,The Ada to HTML Converter gnathtml}
-@end itemize
-
-@item
-@ref{c,,GNAT and Program Execution} is a new chapter consolidating the following:
-
-
-@itemize -
-
-@item
-@ref{24,,Running and Debugging Ada Programs}
-
-@item
-@ref{25,,Profiling}
-
-@item
-@ref{26,,Improving Performance}
-
-@item
-@ref{27,,Overflow Check Handling in GNAT}
-
-@item
-@ref{28,,Performing Dimensionality Analysis in GNAT}
-
-@item
-@ref{29,,Stack Related Facilities}
-
-@item
-@ref{2a,,Memory Management Issues}
-@end itemize
-
-@item
-@ref{d,,Platform-Specific Information} is a new appendix consolidating the following:
-
-
-@itemize -
-
-@item
-@ref{2b,,Run-Time Libraries}
-
-@item
-@ref{2c,,Microsoft Windows Topics}
-
-@item
-@ref{2d,,Mac OS Topics}
-@end itemize
-
-@item
-The @emph{Compatibility and Porting Guide} appendix has been moved to the
-@cite{GNAT Reference Manual}. It now includes a section
-@emph{Writing Portable Fixed-Point Declarations} which was previously
-a separate chapter in the @cite{GNAT User's Guide}.
-@end itemize
-
-@node Conventions,,A Note to Readers of Previous Versions of the Manual,About This Guide
-@anchor{gnat_ugn/about_this_guide conventions}@anchor{2e}
+@node Conventions,,Related Information,About This Guide
+@anchor{gnat_ugn/about_this_guide conventions}@anchor{13}
@section Conventions
@@ -890,30 +728,59 @@ the '\' character should be used instead.
@end itemize
@node Getting Started with GNAT,The GNAT Compilation Model,About This Guide,Top
-@anchor{gnat_ugn/getting_started_with_gnat getting-started-with-gnat}@anchor{8}@anchor{gnat_ugn/getting_started_with_gnat doc}@anchor{2f}@anchor{gnat_ugn/getting_started_with_gnat id1}@anchor{30}
+@anchor{gnat_ugn/getting_started_with_gnat getting-started-with-gnat}@anchor{8}@anchor{gnat_ugn/getting_started_with_gnat doc}@anchor{14}@anchor{gnat_ugn/getting_started_with_gnat id1}@anchor{15}
@chapter Getting Started with GNAT
This chapter describes how to use GNAT's command line interface to build
executable Ada programs.
On most platforms a visually oriented Integrated Development Environment
-is also available, the GNAT Programming Studio (GNAT Studio).
+is also available: GNAT Studio.
GNAT Studio offers a graphical "look and feel", support for development in
other programming languages, comprehensive browsing features, and
many other capabilities.
-For information on GNAT Studio please refer to
-@cite{Using the GNAT Programming Studio}.
+For information on GNAT Studio please refer to the
+@cite{GNAT Studio documentation}.
@menu
+* System Requirements::
* Running GNAT::
* Running a Simple Ada Program::
* Running a Program with Multiple Units::
-* Using the gnatmake Utility::
@end menu
-@node Running GNAT,Running a Simple Ada Program,,Getting Started with GNAT
-@anchor{gnat_ugn/getting_started_with_gnat running-gnat}@anchor{31}@anchor{gnat_ugn/getting_started_with_gnat id2}@anchor{32}
+@node System Requirements,Running GNAT,,Getting Started with GNAT
+@anchor{gnat_ugn/getting_started_with_gnat id2}@anchor{16}@anchor{gnat_ugn/getting_started_with_gnat system-requirements}@anchor{17}
+@section System Requirements
+
+
+Even though any machine can run the GNAT toolset and GNAT Studio IDE, in order
+to get the best experience, we recommend using a machine with as many cores
+as possible since all individual compilations can run in parallel.
+A comfortable setup for a compiler server is a machine with 24 physical cores
+or more, with at least 48 GB of memory (2 GB per core).
+
+For a desktop machine, a minimum of 4 cores is recommended (8 preferred),
+with at least 2GB per core (so 8 to 16GB).
+
+In addition, for running and navigating sources in GNAT Studio smoothly, we
+recommend at least 1.5 GB plus 3 GB of RAM per 1 million source line of code.
+In other words, we recommend at least 3 GB for for 500K lines of code and
+7.5 GB for 2 million lines of code.
+
+Note that using local and fast drives will also make a difference in terms of
+build and link time. Network drives such as NFS, SMB, or worse, configuration
+management filesystems (such as ClearCase dynamic views) should be avoided as
+much as possible and will produce very degraded performance (typically 2 to 3
+times slower than on local fast drives). If such slow drives cannot be avoided
+for accessing the source code, then you should at least configure your project
+file so that the result of the compilation is stored on a drive local to the
+machine performing the run. This can be achieved by setting the @code{Object_Dir}
+project file attribute.
+
+@node Running GNAT,Running a Simple Ada Program,System Requirements,Getting Started with GNAT
+@anchor{gnat_ugn/getting_started_with_gnat running-gnat}@anchor{18}@anchor{gnat_ugn/getting_started_with_gnat id3}@anchor{19}
@section Running GNAT
@@ -938,7 +805,7 @@ utility program that, given the name of the main program, automatically
performs the necessary compilation, binding and linking steps.
@node Running a Simple Ada Program,Running a Program with Multiple Units,Running GNAT,Getting Started with GNAT
-@anchor{gnat_ugn/getting_started_with_gnat running-a-simple-ada-program}@anchor{33}@anchor{gnat_ugn/getting_started_with_gnat id3}@anchor{34}
+@anchor{gnat_ugn/getting_started_with_gnat running-a-simple-ada-program}@anchor{1a}@anchor{gnat_ugn/getting_started_with_gnat id4}@anchor{1b}
@section Running a Simple Ada Program
@@ -967,12 +834,12 @@ extension is @code{ads} for a
spec and @code{adb} for a body.
You can override this default file naming convention by use of the
special pragma @code{Source_File_Name} (for further information please
-see @ref{35,,Using Other File Names}).
+see @ref{1c,,Using Other File Names}).
Alternatively, if you want to rename your files according to this default
convention, which is probably more convenient if you will be using GNAT
for all your compilations, then the @code{gnatchop} utility
can be used to generate correctly-named source files
-(see @ref{36,,Renaming Files with gnatchop}).
+(see @ref{1d,,Renaming Files with gnatchop}).
You can compile the program using the following command (@code{$} is used
as the command prompt in the examples in this document):
@@ -998,24 +865,12 @@ file corresponding to your Ada program. It also generates
an 'Ada Library Information' file @code{hello.ali},
which contains additional information used to check
that an Ada program is consistent.
-To build an executable file,
-use @code{gnatbind} to bind the program
-and @code{gnatlink} to link it. The
-argument to both @code{gnatbind} and @code{gnatlink} is the name of the
-@code{ALI} file, but the default extension of @code{.ali} can
-be omitted. This means that in the most common case, the argument
-is simply the name of the main program:
-
-@example
-$ gnatbind hello
-$ gnatlink hello
-@end example
-A simpler method of carrying out these steps is to use @code{gnatmake},
-a master program that invokes all the required
-compilation, binding and linking tools in the correct order. In particular,
-@code{gnatmake} automatically recompiles any sources that have been
-modified since they were last compiled, or sources that depend
+To build an executable file, use either @code{gnatmake} or gprbuild with
+the name of the main file: these tools are builders that will take care of
+all the necessary build steps in the correct order.
+In particular, these builders automatically recompile any sources that have
+been modified since they were last compiled, or sources that depend
on such modified sources, so that 'version skew' is avoided.
@geindex Version skew (avoided by `@w{`}gnatmake`@w{`})
@@ -1042,8 +897,8 @@ Hello WORLD!
appear in response to this command.
-@node Running a Program with Multiple Units,Using the gnatmake Utility,Running a Simple Ada Program,Getting Started with GNAT
-@anchor{gnat_ugn/getting_started_with_gnat id4}@anchor{37}@anchor{gnat_ugn/getting_started_with_gnat running-a-program-with-multiple-units}@anchor{38}
+@node Running a Program with Multiple Units,,Running a Simple Ada Program,Getting Started with GNAT
+@anchor{gnat_ugn/getting_started_with_gnat id5}@anchor{1e}@anchor{gnat_ugn/getting_started_with_gnat running-a-program-with-multiple-units}@anchor{1f}
@section Running a Program with Multiple Units
@@ -1096,17 +951,6 @@ body of package @code{Greetings}
body of main program
@end table
-To build an executable version of
-this program, we could use four separate steps to compile, bind, and link
-the program, as follows:
-
-@example
-$ gcc -c gmain.adb
-$ gcc -c greetings.adb
-$ gnatbind gmain
-$ gnatlink gmain
-@end example
-
Note that there is no required order of compilation when using GNAT.
In particular it is perfectly fine to compile the main program first.
Also, it is not necessary to compile package specs in the case where
@@ -1118,74 +962,17 @@ generation, then use the @code{-gnatc} switch:
$ gcc -c greetings.ads -gnatc
@end example
-Although the compilation can be done in separate steps as in the
-above example, in practice it is almost always more convenient
-to use the @code{gnatmake} tool. All you need to know in this case
-is the name of the main program's source file. The effect of the above four
-commands can be achieved with a single one:
+Although the compilation can be done in separate steps, in practice it is
+almost always more convenient to use the @code{gnatmake} or @code{gprbuild} tools:
@example
$ gnatmake gmain.adb
@end example
-In the next section we discuss the advantages of using @code{gnatmake} in
-more detail.
-
-@node Using the gnatmake Utility,,Running a Program with Multiple Units,Getting Started with GNAT
-@anchor{gnat_ugn/getting_started_with_gnat using-the-gnatmake-utility}@anchor{39}@anchor{gnat_ugn/getting_started_with_gnat id5}@anchor{3a}
-@section Using the @code{gnatmake} Utility
-
-
-If you work on a program by compiling single components at a time using
-@code{gcc}, you typically keep track of the units you modify. In order to
-build a consistent system, you compile not only these units, but also any
-units that depend on the units you have modified.
-For example, in the preceding case,
-if you edit @code{gmain.adb}, you only need to recompile that file. But if
-you edit @code{greetings.ads}, you must recompile both
-@code{greetings.adb} and @code{gmain.adb}, because both files contain
-units that depend on @code{greetings.ads}.
-
-@code{gnatbind} will warn you if you forget one of these compilation
-steps, so that it is impossible to generate an inconsistent program as a
-result of forgetting to do a compilation. Nevertheless it is tedious and
-error-prone to keep track of dependencies among units.
-One approach to handle the dependency-bookkeeping is to use a
-makefile. However, makefiles present maintenance problems of their own:
-if the dependencies change as you change the program, you must make
-sure that the makefile is kept up-to-date manually, which is also an
-error-prone process.
-
-The @code{gnatmake} utility takes care of these details automatically.
-Invoke it using either one of the following forms:
-
-@example
-$ gnatmake gmain.adb
-$ gnatmake gmain
-@end example
-
-The argument is the name of the file containing the main program;
-you may omit the extension. @code{gnatmake}
-examines the environment, automatically recompiles any files that need
-recompiling, and binds and links the resulting set of object files,
-generating the executable file, @code{gmain}.
-In a large program, it
-can be extremely helpful to use @code{gnatmake}, because working out by hand
-what needs to be recompiled can be difficult.
-
-Note that @code{gnatmake} takes into account all the Ada rules that
-establish dependencies among units. These include dependencies that result
-from inlining subprogram bodies, and from
-generic instantiation. Unlike some other
-Ada make tools, @code{gnatmake} does not rely on the dependencies that were
-found by the compiler on a previous compilation, which may possibly
-be wrong when sources change. @code{gnatmake} determines the exact set of
-dependencies from scratch each time it is run.
-
@c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit
@node The GNAT Compilation Model,Building Executable Programs with GNAT,Getting Started with GNAT,Top
-@anchor{gnat_ugn/the_gnat_compilation_model doc}@anchor{3b}@anchor{gnat_ugn/the_gnat_compilation_model the-gnat-compilation-model}@anchor{9}@anchor{gnat_ugn/the_gnat_compilation_model id1}@anchor{3c}
+@anchor{gnat_ugn/the_gnat_compilation_model doc}@anchor{20}@anchor{gnat_ugn/the_gnat_compilation_model the-gnat-compilation-model}@anchor{9}@anchor{gnat_ugn/the_gnat_compilation_model id1}@anchor{21}
@chapter The GNAT Compilation Model
@@ -1209,44 +996,44 @@ Topics related to source file makeup and naming
@itemize *
@item
-@ref{3d,,Source Representation}
+@ref{22,,Source Representation}
@item
-@ref{3e,,Foreign Language Representation}
+@ref{23,,Foreign Language Representation}
@item
-@ref{3f,,File Naming Topics and Utilities}
+@ref{24,,File Naming Topics and Utilities}
@end itemize
@item
-@ref{14,,Configuration Pragmas}
+@ref{25,,Configuration Pragmas}
@item
-@ref{40,,Generating Object Files}
+@ref{26,,Generating Object Files}
@item
-@ref{41,,Source Dependencies}
+@ref{27,,Source Dependencies}
@item
-@ref{42,,The Ada Library Information Files}
+@ref{28,,The Ada Library Information Files}
@item
-@ref{43,,Binding an Ada Program}
+@ref{29,,Binding an Ada Program}
@item
-@ref{15,,GNAT and Libraries}
+@ref{2a,,GNAT and Libraries}
@item
-@ref{16,,Conditional Compilation}
+@ref{2b,,Conditional Compilation}
@item
-@ref{44,,Mixed Language Programming}
+@ref{2c,,Mixed Language Programming}
@item
-@ref{45,,GNAT and Other Compilation Models}
+@ref{2d,,GNAT and Other Compilation Models}
@item
-@ref{1a,,Using GNAT Files with External Tools}
+@ref{2e,,Using GNAT Files with External Tools}
@end itemize
@menu
@@ -1267,7 +1054,7 @@ Topics related to source file makeup and naming
@end menu
@node Source Representation,Foreign Language Representation,,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model source-representation}@anchor{3d}@anchor{gnat_ugn/the_gnat_compilation_model id2}@anchor{46}
+@anchor{gnat_ugn/the_gnat_compilation_model source-representation}@anchor{22}@anchor{gnat_ugn/the_gnat_compilation_model id2}@anchor{2f}
@section Source Representation
@@ -1282,7 +1069,7 @@ Topics related to source file makeup and naming
Ada source programs are represented in standard text files, using
Latin-1 coding. Latin-1 is an 8-bit code that includes the familiar
7-bit ASCII set, plus additional characters used for
-representing foreign languages (see @ref{3e,,Foreign Language Representation}
+representing foreign languages (see @ref{23,,Foreign Language Representation}
for support of non-USA character sets). The format effector characters
are represented using their standard ASCII encodings, as follows:
@@ -1393,13 +1180,13 @@ compilation units) is represented using a sequence of files. Similarly,
you will place each subunit or child unit in a separate file.
@node Foreign Language Representation,File Naming Topics and Utilities,Source Representation,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model foreign-language-representation}@anchor{3e}@anchor{gnat_ugn/the_gnat_compilation_model id3}@anchor{47}
+@anchor{gnat_ugn/the_gnat_compilation_model foreign-language-representation}@anchor{23}@anchor{gnat_ugn/the_gnat_compilation_model id3}@anchor{30}
@section Foreign Language Representation
GNAT supports the standard character sets defined in Ada as well as
several other non-standard character sets for use in localized versions
-of the compiler (@ref{48,,Character Set Control}).
+of the compiler (@ref{31,,Character Set Control}).
@menu
* Latin-1::
@@ -1410,7 +1197,7 @@ of the compiler (@ref{48,,Character Set Control}).
@end menu
@node Latin-1,Other 8-Bit Codes,,Foreign Language Representation
-@anchor{gnat_ugn/the_gnat_compilation_model id4}@anchor{49}@anchor{gnat_ugn/the_gnat_compilation_model latin-1}@anchor{4a}
+@anchor{gnat_ugn/the_gnat_compilation_model id4}@anchor{32}@anchor{gnat_ugn/the_gnat_compilation_model latin-1}@anchor{33}
@subsection Latin-1
@@ -1433,7 +1220,7 @@ string literals. In addition, the extended characters that represent
letters can be used in identifiers.
@node Other 8-Bit Codes,Wide_Character Encodings,Latin-1,Foreign Language Representation
-@anchor{gnat_ugn/the_gnat_compilation_model other-8-bit-codes}@anchor{4b}@anchor{gnat_ugn/the_gnat_compilation_model id5}@anchor{4c}
+@anchor{gnat_ugn/the_gnat_compilation_model other-8-bit-codes}@anchor{34}@anchor{gnat_ugn/the_gnat_compilation_model id5}@anchor{35}
@subsection Other 8-Bit Codes
@@ -1550,7 +1337,7 @@ the GNAT compiler sources. You will need to obtain a full source release
of GNAT to obtain this file.
@node Wide_Character Encodings,Wide_Wide_Character Encodings,Other 8-Bit Codes,Foreign Language Representation
-@anchor{gnat_ugn/the_gnat_compilation_model id6}@anchor{4d}@anchor{gnat_ugn/the_gnat_compilation_model wide-character-encodings}@anchor{4e}
+@anchor{gnat_ugn/the_gnat_compilation_model id6}@anchor{36}@anchor{gnat_ugn/the_gnat_compilation_model wide-character-encodings}@anchor{37}
@subsection Wide_Character Encodings
@@ -1661,7 +1448,7 @@ use of the upper half of the Latin-1 set.
@end cartouche
@node Wide_Wide_Character Encodings,,Wide_Character Encodings,Foreign Language Representation
-@anchor{gnat_ugn/the_gnat_compilation_model id7}@anchor{4f}@anchor{gnat_ugn/the_gnat_compilation_model wide-wide-character-encodings}@anchor{50}
+@anchor{gnat_ugn/the_gnat_compilation_model id7}@anchor{38}@anchor{gnat_ugn/the_gnat_compilation_model wide-wide-character-encodings}@anchor{39}
@subsection Wide_Wide_Character Encodings
@@ -1713,7 +1500,7 @@ ACATS (Ada Conformity Assessment Test Suite) test suite distributions.
@end table
@node File Naming Topics and Utilities,Configuration Pragmas,Foreign Language Representation,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model id8}@anchor{51}@anchor{gnat_ugn/the_gnat_compilation_model file-naming-topics-and-utilities}@anchor{3f}
+@anchor{gnat_ugn/the_gnat_compilation_model id8}@anchor{3a}@anchor{gnat_ugn/the_gnat_compilation_model file-naming-topics-and-utilities}@anchor{24}
@section File Naming Topics and Utilities
@@ -1732,7 +1519,7 @@ source files correspond to the Ada compilation units that they contain.
@end menu
@node File Naming Rules,Using Other File Names,,File Naming Topics and Utilities
-@anchor{gnat_ugn/the_gnat_compilation_model file-naming-rules}@anchor{52}@anchor{gnat_ugn/the_gnat_compilation_model id9}@anchor{53}
+@anchor{gnat_ugn/the_gnat_compilation_model file-naming-rules}@anchor{3b}@anchor{gnat_ugn/the_gnat_compilation_model id9}@anchor{3c}
@subsection File Naming Rules
@@ -1841,7 +1628,7 @@ unit names are long (for example, if child units or subunits are
heavily nested). An option is available to shorten such long file names
(called file name 'krunching'). This may be particularly useful when
programs being developed with GNAT are to be used on operating systems
-with limited file name lengths. @ref{54,,Using gnatkr}.
+with limited file name lengths. @ref{3d,,Using gnatkr}.
Of course, no file shortening algorithm can guarantee uniqueness over
all possible unit names; if file name krunching is used, it is your
@@ -1850,7 +1637,7 @@ can specify the exact file names that you want used, as described
in the next section. Finally, if your Ada programs are migrating from a
compiler with a different naming convention, you can use the gnatchop
utility to produce source files that follow the GNAT naming conventions.
-(For details see @ref{36,,Renaming Files with gnatchop}.)
+(For details see @ref{1d,,Renaming Files with gnatchop}.)
Note: in the case of Windows or Mac OS operating systems, case is not
significant. So for example on Windows if the canonical name is
@@ -1860,7 +1647,7 @@ if you want to use other than canonically cased file names on a Unix system,
you need to follow the procedures described in the next section.
@node Using Other File Names,Alternative File Naming Schemes,File Naming Rules,File Naming Topics and Utilities
-@anchor{gnat_ugn/the_gnat_compilation_model id10}@anchor{55}@anchor{gnat_ugn/the_gnat_compilation_model using-other-file-names}@anchor{35}
+@anchor{gnat_ugn/the_gnat_compilation_model id10}@anchor{3e}@anchor{gnat_ugn/the_gnat_compilation_model using-other-file-names}@anchor{1c}
@subsection Using Other File Names
@@ -1898,7 +1685,7 @@ normally it will be placed in the @code{gnat.adc}
file used to hold configuration
pragmas that apply to a complete compilation environment.
For more details on how the @code{gnat.adc} file is created and used
-see @ref{56,,Handling of Configuration Pragmas}.
+see @ref{3f,,Handling of Configuration Pragmas}.
@geindex gnat.adc
@@ -1920,7 +1707,7 @@ then it must be included in the @code{gnatmake} command, it may not
be omitted.
@node Alternative File Naming Schemes,Handling Arbitrary File Naming Conventions with gnatname,Using Other File Names,File Naming Topics and Utilities
-@anchor{gnat_ugn/the_gnat_compilation_model id11}@anchor{57}@anchor{gnat_ugn/the_gnat_compilation_model alternative-file-naming-schemes}@anchor{58}
+@anchor{gnat_ugn/the_gnat_compilation_model id11}@anchor{40}@anchor{gnat_ugn/the_gnat_compilation_model alternative-file-naming-schemes}@anchor{41}
@subsection Alternative File Naming Schemes
@@ -2064,7 +1851,7 @@ pragma Source_File_Name
@geindex gnatname
@node Handling Arbitrary File Naming Conventions with gnatname,File Name Krunching with gnatkr,Alternative File Naming Schemes,File Naming Topics and Utilities
-@anchor{gnat_ugn/the_gnat_compilation_model handling-arbitrary-file-naming-conventions-with-gnatname}@anchor{59}@anchor{gnat_ugn/the_gnat_compilation_model id12}@anchor{5a}
+@anchor{gnat_ugn/the_gnat_compilation_model handling-arbitrary-file-naming-conventions-with-gnatname}@anchor{42}@anchor{gnat_ugn/the_gnat_compilation_model id12}@anchor{43}
@subsection Handling Arbitrary File Naming Conventions with @code{gnatname}
@@ -2079,7 +1866,7 @@ pragma Source_File_Name
@end menu
@node Arbitrary File Naming Conventions,Running gnatname,,Handling Arbitrary File Naming Conventions with gnatname
-@anchor{gnat_ugn/the_gnat_compilation_model arbitrary-file-naming-conventions}@anchor{5b}@anchor{gnat_ugn/the_gnat_compilation_model id13}@anchor{5c}
+@anchor{gnat_ugn/the_gnat_compilation_model arbitrary-file-naming-conventions}@anchor{44}@anchor{gnat_ugn/the_gnat_compilation_model id13}@anchor{45}
@subsubsection Arbitrary File Naming Conventions
@@ -2090,11 +1877,11 @@ does not need additional information.
When the source file names do not follow the standard GNAT default file naming
conventions, the GNAT compiler must be given additional information through
-a configuration pragmas file (@ref{14,,Configuration Pragmas})
+a configuration pragmas file (@ref{25,,Configuration Pragmas})
or a project file.
When the non-standard file naming conventions are well-defined,
a small number of pragmas @code{Source_File_Name} specifying a naming pattern
-(@ref{58,,Alternative File Naming Schemes}) may be sufficient. However,
+(@ref{41,,Alternative File Naming Schemes}) may be sufficient. However,
if the file naming conventions are irregular or arbitrary, a number
of pragma @code{Source_File_Name} for individual compilation units
must be defined.
@@ -2104,7 +1891,7 @@ GNAT provides a tool @code{gnatname} to generate the required pragmas for a
set of files.
@node Running gnatname,Switches for gnatname,Arbitrary File Naming Conventions,Handling Arbitrary File Naming Conventions with gnatname
-@anchor{gnat_ugn/the_gnat_compilation_model running-gnatname}@anchor{5d}@anchor{gnat_ugn/the_gnat_compilation_model id14}@anchor{5e}
+@anchor{gnat_ugn/the_gnat_compilation_model running-gnatname}@anchor{46}@anchor{gnat_ugn/the_gnat_compilation_model id14}@anchor{47}
@subsubsection Running @code{gnatname}
@@ -2155,7 +1942,7 @@ with pragmas @code{Source_File_Name} for each file that contains a valid Ada
unit.
@node Switches for gnatname,Examples of gnatname Usage,Running gnatname,Handling Arbitrary File Naming Conventions with gnatname
-@anchor{gnat_ugn/the_gnat_compilation_model id15}@anchor{5f}@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatname}@anchor{60}
+@anchor{gnat_ugn/the_gnat_compilation_model id15}@anchor{48}@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatname}@anchor{49}
@subsubsection Switches for @code{gnatname}
@@ -2338,7 +2125,7 @@ except those whose names end with @code{_nt.ada}.
@end table
@node Examples of gnatname Usage,,Switches for gnatname,Handling Arbitrary File Naming Conventions with gnatname
-@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatname-usage}@anchor{61}@anchor{gnat_ugn/the_gnat_compilation_model id16}@anchor{62}
+@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatname-usage}@anchor{4a}@anchor{gnat_ugn/the_gnat_compilation_model id16}@anchor{4b}
@subsubsection Examples of @code{gnatname} Usage
@@ -2364,7 +2151,7 @@ even in conjunction with one or several switches
are used in this example.
@node File Name Krunching with gnatkr,Renaming Files with gnatchop,Handling Arbitrary File Naming Conventions with gnatname,File Naming Topics and Utilities
-@anchor{gnat_ugn/the_gnat_compilation_model file-name-krunching-with-gnatkr}@anchor{63}@anchor{gnat_ugn/the_gnat_compilation_model id17}@anchor{64}
+@anchor{gnat_ugn/the_gnat_compilation_model file-name-krunching-with-gnatkr}@anchor{4c}@anchor{gnat_ugn/the_gnat_compilation_model id17}@anchor{4d}
@subsection File Name Krunching with @code{gnatkr}
@@ -2385,7 +2172,7 @@ applying this shortening.
@end menu
@node About gnatkr,Using gnatkr,,File Name Krunching with gnatkr
-@anchor{gnat_ugn/the_gnat_compilation_model id18}@anchor{65}@anchor{gnat_ugn/the_gnat_compilation_model about-gnatkr}@anchor{66}
+@anchor{gnat_ugn/the_gnat_compilation_model id18}@anchor{4e}@anchor{gnat_ugn/the_gnat_compilation_model about-gnatkr}@anchor{4f}
@subsubsection About @code{gnatkr}
@@ -2423,7 +2210,7 @@ The @code{gnatkr} utility can be used to determine the krunched name for
a given file, when krunched to a specified maximum length.
@node Using gnatkr,Krunching Method,About gnatkr,File Name Krunching with gnatkr
-@anchor{gnat_ugn/the_gnat_compilation_model id19}@anchor{67}@anchor{gnat_ugn/the_gnat_compilation_model using-gnatkr}@anchor{54}
+@anchor{gnat_ugn/the_gnat_compilation_model id19}@anchor{50}@anchor{gnat_ugn/the_gnat_compilation_model using-gnatkr}@anchor{3d}
@subsubsection Using @code{gnatkr}
@@ -2460,7 +2247,7 @@ The output is the krunched name. The output has an extension only if the
original argument was a file name with an extension.
@node Krunching Method,Examples of gnatkr Usage,Using gnatkr,File Name Krunching with gnatkr
-@anchor{gnat_ugn/the_gnat_compilation_model id20}@anchor{68}@anchor{gnat_ugn/the_gnat_compilation_model krunching-method}@anchor{69}
+@anchor{gnat_ugn/the_gnat_compilation_model id20}@anchor{51}@anchor{gnat_ugn/the_gnat_compilation_model krunching-method}@anchor{52}
@subsubsection Krunching Method
@@ -2590,7 +2377,7 @@ program @code{gnatkr} is supplied for conveniently determining the
krunched name of a file.
@node Examples of gnatkr Usage,,Krunching Method,File Name Krunching with gnatkr
-@anchor{gnat_ugn/the_gnat_compilation_model id21}@anchor{6a}@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatkr-usage}@anchor{6b}
+@anchor{gnat_ugn/the_gnat_compilation_model id21}@anchor{53}@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatkr-usage}@anchor{54}
@subsubsection Examples of @code{gnatkr} Usage
@@ -2604,7 +2391,7 @@ $ gnatkr very_long_unit_name.ads/count=0 --> very_long_unit_name.ads
@end example
@node Renaming Files with gnatchop,,File Name Krunching with gnatkr,File Naming Topics and Utilities
-@anchor{gnat_ugn/the_gnat_compilation_model id22}@anchor{6c}@anchor{gnat_ugn/the_gnat_compilation_model renaming-files-with-gnatchop}@anchor{36}
+@anchor{gnat_ugn/the_gnat_compilation_model id22}@anchor{55}@anchor{gnat_ugn/the_gnat_compilation_model renaming-files-with-gnatchop}@anchor{1d}
@subsection Renaming Files with @code{gnatchop}
@@ -2624,7 +2411,7 @@ files to meet the standard GNAT default file naming conventions.
@end menu
@node Handling Files with Multiple Units,Operating gnatchop in Compilation Mode,,Renaming Files with gnatchop
-@anchor{gnat_ugn/the_gnat_compilation_model id23}@anchor{6d}@anchor{gnat_ugn/the_gnat_compilation_model handling-files-with-multiple-units}@anchor{6e}
+@anchor{gnat_ugn/the_gnat_compilation_model id23}@anchor{56}@anchor{gnat_ugn/the_gnat_compilation_model handling-files-with-multiple-units}@anchor{57}
@subsubsection Handling Files with Multiple Units
@@ -2632,23 +2419,18 @@ The basic compilation model of GNAT requires that a file submitted to the
compiler have only one unit and there be a strict correspondence
between the file name and the unit name.
-The @code{gnatchop} utility allows both of these rules to be relaxed,
-allowing GNAT to process files which contain multiple compilation units
-and files with arbitrary file names. @code{gnatchop}
-reads the specified file and generates one or more output files,
-containing one unit per file. The unit and the file name correspond,
-as required by GNAT.
+If you want to keep your files with multiple units,
+perhaps to maintain compatibility with some other Ada compilation system,
+you can use @code{gnatname} to generate or update your project files.
+Generated or modified project files can be processed by GNAT.
-If you want to permanently restructure a set of 'foreign' files so that
-they match the GNAT rules, and do the remaining development using the
-GNAT structure, you can simply use @code{gnatchop} once, generate the
-new set of files and work with them from that point on.
+See @ref{42,,Handling Arbitrary File Naming Conventions with gnatname}
+for more details on how to use @cite{gnatname}.
-Alternatively, if you want to keep your files in the 'foreign' format,
-perhaps to maintain compatibility with some other Ada compilation
-system, you can set up a procedure where you use @code{gnatchop} each
-time you compile, regarding the source files that it writes as temporary
-files that you throw away.
+Alternatively, if you want to permanently restructure a set of 'foreign'
+files so that they match the GNAT rules, and do the remaining development
+using the GNAT structure, you can simply use @code{gnatchop} once, generate the
+new set of files and work with them from that point on.
Note that if your file containing multiple units starts with a byte order
mark (BOM) specifying UTF-8 encoding, then the files generated by gnatchop
@@ -2656,7 +2438,7 @@ will each start with a copy of this BOM, meaning that they can be compiled
automatically in UTF-8 mode without needing to specify an explicit encoding.
@node Operating gnatchop in Compilation Mode,Command Line for gnatchop,Handling Files with Multiple Units,Renaming Files with gnatchop
-@anchor{gnat_ugn/the_gnat_compilation_model operating-gnatchop-in-compilation-mode}@anchor{6f}@anchor{gnat_ugn/the_gnat_compilation_model id24}@anchor{70}
+@anchor{gnat_ugn/the_gnat_compilation_model operating-gnatchop-in-compilation-mode}@anchor{58}@anchor{gnat_ugn/the_gnat_compilation_model id24}@anchor{59}
@subsubsection Operating gnatchop in Compilation Mode
@@ -2689,7 +2471,7 @@ should apply to all subsequent compilations in the same compilation
environment. Using GNAT, the current directory, possibly containing a
@code{gnat.adc} file is the representation
of a compilation environment. For more information on the
-@code{gnat.adc} file, see @ref{56,,Handling of Configuration Pragmas}.
+@code{gnat.adc} file, see @ref{3f,,Handling of Configuration Pragmas}.
Second, in compilation mode, if @code{gnatchop}
is given a file that starts with
@@ -2716,7 +2498,7 @@ switch provides the required behavior, and is for example the mode
in which GNAT processes the ACVC tests.
@node Command Line for gnatchop,Switches for gnatchop,Operating gnatchop in Compilation Mode,Renaming Files with gnatchop
-@anchor{gnat_ugn/the_gnat_compilation_model id25}@anchor{71}@anchor{gnat_ugn/the_gnat_compilation_model command-line-for-gnatchop}@anchor{72}
+@anchor{gnat_ugn/the_gnat_compilation_model id25}@anchor{5a}@anchor{gnat_ugn/the_gnat_compilation_model command-line-for-gnatchop}@anchor{5b}
@subsubsection Command Line for @code{gnatchop}
@@ -2790,7 +2572,7 @@ no source files written
@end example
@node Switches for gnatchop,Examples of gnatchop Usage,Command Line for gnatchop,Renaming Files with gnatchop
-@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatchop}@anchor{73}@anchor{gnat_ugn/the_gnat_compilation_model id26}@anchor{74}
+@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatchop}@anchor{5c}@anchor{gnat_ugn/the_gnat_compilation_model id26}@anchor{5d}
@subsubsection Switches for @code{gnatchop}
@@ -2956,7 +2738,7 @@ no attempt is made to add the prefix to the GNAT parser executable.
@end table
@node Examples of gnatchop Usage,,Switches for gnatchop,Renaming Files with gnatchop
-@anchor{gnat_ugn/the_gnat_compilation_model id27}@anchor{75}@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatchop-usage}@anchor{76}
+@anchor{gnat_ugn/the_gnat_compilation_model id27}@anchor{5e}@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatchop-usage}@anchor{5f}
@subsubsection Examples of @code{gnatchop} Usage
@@ -2997,7 +2779,7 @@ be the one that is output, and earlier duplicate occurrences for a given
unit will be skipped.
@node Configuration Pragmas,Generating Object Files,File Naming Topics and Utilities,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model id28}@anchor{77}@anchor{gnat_ugn/the_gnat_compilation_model configuration-pragmas}@anchor{14}
+@anchor{gnat_ugn/the_gnat_compilation_model id28}@anchor{60}@anchor{gnat_ugn/the_gnat_compilation_model configuration-pragmas}@anchor{25}
@section Configuration Pragmas
@@ -3108,7 +2890,7 @@ Wide_Character_Encoding
@end menu
@node Handling of Configuration Pragmas,The Configuration Pragmas Files,,Configuration Pragmas
-@anchor{gnat_ugn/the_gnat_compilation_model id29}@anchor{78}@anchor{gnat_ugn/the_gnat_compilation_model handling-of-configuration-pragmas}@anchor{56}
+@anchor{gnat_ugn/the_gnat_compilation_model id29}@anchor{61}@anchor{gnat_ugn/the_gnat_compilation_model handling-of-configuration-pragmas}@anchor{3f}
@subsection Handling of Configuration Pragmas
@@ -3119,7 +2901,7 @@ all compilations performed in a given compilation environment.
GNAT also provides the @code{gnatchop} utility to provide an automatic
way to handle configuration pragmas following the semantics for
compilations (that is, files with multiple units), described in the RM.
-See @ref{6f,,Operating gnatchop in Compilation Mode} for details.
+See @ref{58,,Operating gnatchop in Compilation Mode} for details.
However, for most purposes, it will be more convenient to edit the
@code{gnat.adc} file that contains configuration pragmas directly,
as described in the following section.
@@ -3149,7 +2931,7 @@ relevant units). It can appear on a subunit only if it has previously
appeared in the body of spec.
@node The Configuration Pragmas Files,,Handling of Configuration Pragmas,Configuration Pragmas
-@anchor{gnat_ugn/the_gnat_compilation_model the-configuration-pragmas-files}@anchor{79}@anchor{gnat_ugn/the_gnat_compilation_model id30}@anchor{7a}
+@anchor{gnat_ugn/the_gnat_compilation_model the-configuration-pragmas-files}@anchor{62}@anchor{gnat_ugn/the_gnat_compilation_model id30}@anchor{63}
@subsection The Configuration Pragmas Files
@@ -3196,7 +2978,7 @@ project attributes.
@c See :ref:`Specifying_Configuration_Pragmas` for more details.
@node Generating Object Files,Source Dependencies,Configuration Pragmas,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model generating-object-files}@anchor{40}@anchor{gnat_ugn/the_gnat_compilation_model id31}@anchor{7b}
+@anchor{gnat_ugn/the_gnat_compilation_model generating-object-files}@anchor{26}@anchor{gnat_ugn/the_gnat_compilation_model id31}@anchor{64}
@section Generating Object Files
@@ -3267,7 +3049,7 @@ part of the process of building a program. To compile a file in this
checking mode, use the @code{-gnatc} switch.
@node Source Dependencies,The Ada Library Information Files,Generating Object Files,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model id32}@anchor{7c}@anchor{gnat_ugn/the_gnat_compilation_model source-dependencies}@anchor{41}
+@anchor{gnat_ugn/the_gnat_compilation_model id32}@anchor{65}@anchor{gnat_ugn/the_gnat_compilation_model source-dependencies}@anchor{27}
@section Source Dependencies
@@ -3362,7 +3144,7 @@ recompilations is done automatically when one uses @code{gnatmake}.
@end itemize
@node The Ada Library Information Files,Binding an Ada Program,Source Dependencies,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model id33}@anchor{7d}@anchor{gnat_ugn/the_gnat_compilation_model the-ada-library-information-files}@anchor{42}
+@anchor{gnat_ugn/the_gnat_compilation_model id33}@anchor{66}@anchor{gnat_ugn/the_gnat_compilation_model the-ada-library-information-files}@anchor{28}
@section The Ada Library Information Files
@@ -3430,7 +3212,7 @@ see the source of the body of unit @code{Lib.Writ}, contained in file
@code{lib-writ.adb} in the GNAT compiler sources.
@node Binding an Ada Program,GNAT and Libraries,The Ada Library Information Files,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model id34}@anchor{7e}@anchor{gnat_ugn/the_gnat_compilation_model binding-an-ada-program}@anchor{43}
+@anchor{gnat_ugn/the_gnat_compilation_model id34}@anchor{67}@anchor{gnat_ugn/the_gnat_compilation_model binding-an-ada-program}@anchor{29}
@section Binding an Ada Program
@@ -3466,7 +3248,7 @@ using the object from the main program from the bind step as well as the
object files for the Ada units of the program.
@node GNAT and Libraries,Conditional Compilation,Binding an Ada Program,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model gnat-and-libraries}@anchor{15}@anchor{gnat_ugn/the_gnat_compilation_model id35}@anchor{7f}
+@anchor{gnat_ugn/the_gnat_compilation_model gnat-and-libraries}@anchor{2a}@anchor{gnat_ugn/the_gnat_compilation_model id35}@anchor{68}
@section GNAT and Libraries
@@ -3486,7 +3268,7 @@ Project Manager facility (see the @emph{GNAT_Project_Manager} chapter of the
@end menu
@node Introduction to Libraries in GNAT,General Ada Libraries,,GNAT and Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model introduction-to-libraries-in-gnat}@anchor{80}@anchor{gnat_ugn/the_gnat_compilation_model id36}@anchor{81}
+@anchor{gnat_ugn/the_gnat_compilation_model introduction-to-libraries-in-gnat}@anchor{69}@anchor{gnat_ugn/the_gnat_compilation_model id36}@anchor{6a}
@subsection Introduction to Libraries in GNAT
@@ -3513,7 +3295,7 @@ In the GNAT environment, a library has three types of components:
Source files,
@item
-@code{ALI} files (see @ref{42,,The Ada Library Information Files}), and
+@code{ALI} files (see @ref{28,,The Ada Library Information Files}), and
@item
Object files, an archive or a shared library.
@@ -3525,7 +3307,7 @@ an external user to make use of the library. That is to say, the specs
reflecting the library services along with all the units needed to compile
those specs, which can include generic bodies or any body implementing an
inlined routine. In the case of @emph{stand-alone libraries} those exposed
-units are called @emph{interface units} (@ref{82,,Stand-alone Ada Libraries}).
+units are called @emph{interface units} (@ref{6b,,Stand-alone Ada Libraries}).
All compilation units comprising an application, including those in a library,
need to be elaborated in an order partially defined by Ada's semantics. GNAT
@@ -3536,7 +3318,7 @@ library elaboration routine is produced independently of the application(s)
using the library.
@node General Ada Libraries,Stand-alone Ada Libraries,Introduction to Libraries in GNAT,GNAT and Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model general-ada-libraries}@anchor{83}@anchor{gnat_ugn/the_gnat_compilation_model id37}@anchor{84}
+@anchor{gnat_ugn/the_gnat_compilation_model general-ada-libraries}@anchor{6c}@anchor{gnat_ugn/the_gnat_compilation_model id37}@anchor{6d}
@subsection General Ada Libraries
@@ -3548,7 +3330,7 @@ using the library.
@end menu
@node Building a library,Installing a library,,General Ada Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model building-a-library}@anchor{85}@anchor{gnat_ugn/the_gnat_compilation_model id38}@anchor{86}
+@anchor{gnat_ugn/the_gnat_compilation_model building-a-library}@anchor{6e}@anchor{gnat_ugn/the_gnat_compilation_model id38}@anchor{6f}
@subsubsection Building a library
@@ -3630,7 +3412,7 @@ for this task. In special cases where this is not desired, the necessary
steps are discussed below.
There are various possibilities for compiling the units that make up the
-library: for example with a Makefile (@ref{1f,,Using the GNU make Utility}) or
+library: for example with a Makefile (@ref{70,,Using the GNU make Utility}) or
with a conventional script. For simple libraries, it is also possible to create
a dummy main program which depends upon all the packages that comprise the
interface of the library. This dummy main program can then be given to
@@ -3681,7 +3463,7 @@ or @code{lib@emph{xxx}.so} (or @code{lib@emph{xxx}.dll} on Windows) in order to
be accessed by the directive @code{-l@emph{xxx}} at link time.
@node Installing a library,Using a library,Building a library,General Ada Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model installing-a-library}@anchor{87}@anchor{gnat_ugn/the_gnat_compilation_model id39}@anchor{88}
+@anchor{gnat_ugn/the_gnat_compilation_model installing-a-library}@anchor{71}@anchor{gnat_ugn/the_gnat_compilation_model id39}@anchor{72}
@subsubsection Installing a library
@@ -3696,7 +3478,7 @@ process (see the @emph{Installing a Library with Project Files} section of the
When project files are not an option, it is also possible, but not recommended,
to install the library so that the sources needed to use the library are on the
Ada source path and the ALI files & libraries be on the Ada Object path (see
-@ref{89,,Search Paths and the Run-Time Library (RTL)}. Alternatively, the system
+@ref{73,,Search Paths and the Run-Time Library (RTL)}. Alternatively, the system
administrator can place general-purpose libraries in the default compiler
paths, by specifying the libraries' location in the configuration files
@code{ada_source_path} and @code{ada_object_path}. These configuration files
@@ -3738,7 +3520,7 @@ library must be installed before the GNAT library if it redefines
any part of it.
@node Using a library,,Installing a library,General Ada Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model using-a-library}@anchor{8a}@anchor{gnat_ugn/the_gnat_compilation_model id40}@anchor{8b}
+@anchor{gnat_ugn/the_gnat_compilation_model using-a-library}@anchor{74}@anchor{gnat_ugn/the_gnat_compilation_model id40}@anchor{75}
@subsubsection Using a library
@@ -3777,8 +3559,8 @@ left to the tools having visibility over project dependence information.
In order to use an Ada library manually, you need to make sure that this
library is on both your source and object path
-(see @ref{89,,Search Paths and the Run-Time Library (RTL)}
-and @ref{8c,,Search Paths for gnatbind}). Furthermore, when the objects are grouped
+(see @ref{73,,Search Paths and the Run-Time Library (RTL)}
+and @ref{76,,Search Paths for gnatbind}). Furthermore, when the objects are grouped
in an archive or a shared library, you need to specify the desired
library at link time.
@@ -3832,7 +3614,7 @@ in the directory @code{share/examples/gnat/plugins} within the GNAT
install area.
@node Stand-alone Ada Libraries,Rebuilding the GNAT Run-Time Library,General Ada Libraries,GNAT and Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model stand-alone-ada-libraries}@anchor{82}@anchor{gnat_ugn/the_gnat_compilation_model id41}@anchor{8d}
+@anchor{gnat_ugn/the_gnat_compilation_model stand-alone-ada-libraries}@anchor{6b}@anchor{gnat_ugn/the_gnat_compilation_model id41}@anchor{77}
@subsection Stand-alone Ada Libraries
@@ -3847,7 +3629,7 @@ install area.
@end menu
@node Introduction to Stand-alone Libraries,Building a Stand-alone Library,,Stand-alone Ada Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model introduction-to-stand-alone-libraries}@anchor{8e}@anchor{gnat_ugn/the_gnat_compilation_model id42}@anchor{8f}
+@anchor{gnat_ugn/the_gnat_compilation_model introduction-to-stand-alone-libraries}@anchor{78}@anchor{gnat_ugn/the_gnat_compilation_model id42}@anchor{79}
@subsubsection Introduction to Stand-alone Libraries
@@ -3882,7 +3664,7 @@ Stand-alone libraries are also well suited to be used in an executable whose
main routine is not written in Ada.
@node Building a Stand-alone Library,Creating a Stand-alone Library to be used in a non-Ada context,Introduction to Stand-alone Libraries,Stand-alone Ada Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model id43}@anchor{90}@anchor{gnat_ugn/the_gnat_compilation_model building-a-stand-alone-library}@anchor{91}
+@anchor{gnat_ugn/the_gnat_compilation_model id43}@anchor{7a}@anchor{gnat_ugn/the_gnat_compilation_model building-a-stand-alone-library}@anchor{7b}
@subsubsection Building a Stand-alone Library
@@ -4001,10 +3783,10 @@ read-only.
@end itemize
Using SALs is not different from using other libraries
-(see @ref{8a,,Using a library}).
+(see @ref{74,,Using a library}).
@node Creating a Stand-alone Library to be used in a non-Ada context,Restrictions in Stand-alone Libraries,Building a Stand-alone Library,Stand-alone Ada Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model creating-a-stand-alone-library-to-be-used-in-a-non-ada-context}@anchor{92}@anchor{gnat_ugn/the_gnat_compilation_model id44}@anchor{93}
+@anchor{gnat_ugn/the_gnat_compilation_model creating-a-stand-alone-library-to-be-used-in-a-non-ada-context}@anchor{7c}@anchor{gnat_ugn/the_gnat_compilation_model id44}@anchor{7d}
@subsubsection Creating a Stand-alone Library to be used in a non-Ada context
@@ -4089,7 +3871,7 @@ must be ensured at the application level using a specific operating
system services like a mutex or a critical-section.
@node Restrictions in Stand-alone Libraries,,Creating a Stand-alone Library to be used in a non-Ada context,Stand-alone Ada Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model id45}@anchor{94}@anchor{gnat_ugn/the_gnat_compilation_model restrictions-in-stand-alone-libraries}@anchor{95}
+@anchor{gnat_ugn/the_gnat_compilation_model id45}@anchor{7e}@anchor{gnat_ugn/the_gnat_compilation_model restrictions-in-stand-alone-libraries}@anchor{7f}
@subsubsection Restrictions in Stand-alone Libraries
@@ -4135,7 +3917,7 @@ In practice these attributes are rarely used, so this is unlikely
to be a consideration.
@node Rebuilding the GNAT Run-Time Library,,Stand-alone Ada Libraries,GNAT and Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model id46}@anchor{96}@anchor{gnat_ugn/the_gnat_compilation_model rebuilding-the-gnat-run-time-library}@anchor{97}
+@anchor{gnat_ugn/the_gnat_compilation_model id46}@anchor{80}@anchor{gnat_ugn/the_gnat_compilation_model rebuilding-the-gnat-run-time-library}@anchor{81}
@subsection Rebuilding the GNAT Run-Time Library
@@ -4149,10 +3931,9 @@ to be a consideration.
@geindex Run-Time Library
@geindex rebuilding
-It may be useful to recompile the GNAT library in various contexts, the
-most important one being the use of partition-wide configuration pragmas
-such as @code{Normalize_Scalars}. A special Makefile called
-@code{Makefile.adalib} is provided to that effect and can be found in
+It may be useful to recompile the GNAT library in various debugging or
+experimentation contexts. A project file called
+@code{libada.gpr} is provided to that effect and can be found in
the directory containing the GNAT library. The location of this
directory depends on the way the GNAT environment has been installed and can
be determined by means of the command:
@@ -4161,15 +3942,18 @@ be determined by means of the command:
$ gnatls -v
@end example
-The last entry in the object search path usually contains the
-gnat library. This Makefile contains its own documentation and in
-particular the set of instructions needed to rebuild a new library and
-to use it.
+The last entry in the source search path usually contains the
+gnat library (the @code{adainclude} directory). This project file contains its
+own documentation and in particular the set of instructions needed to rebuild a
+new library and to use it.
+
+Note that rebuilding the GNAT Run-Time is only recommended for temporary
+experiments or debugging, and is not supported.
@geindex Conditional compilation
@node Conditional Compilation,Mixed Language Programming,GNAT and Libraries,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model id47}@anchor{98}@anchor{gnat_ugn/the_gnat_compilation_model conditional-compilation}@anchor{16}
+@anchor{gnat_ugn/the_gnat_compilation_model id47}@anchor{82}@anchor{gnat_ugn/the_gnat_compilation_model conditional-compilation}@anchor{2b}
@section Conditional Compilation
@@ -4186,7 +3970,7 @@ gnatprep preprocessor utility.
@end menu
@node Modeling Conditional Compilation in Ada,Preprocessing with gnatprep,,Conditional Compilation
-@anchor{gnat_ugn/the_gnat_compilation_model modeling-conditional-compilation-in-ada}@anchor{99}@anchor{gnat_ugn/the_gnat_compilation_model id48}@anchor{9a}
+@anchor{gnat_ugn/the_gnat_compilation_model modeling-conditional-compilation-in-ada}@anchor{83}@anchor{gnat_ugn/the_gnat_compilation_model id48}@anchor{84}
@subsection Modeling Conditional Compilation in Ada
@@ -4237,7 +4021,7 @@ be achieved using Ada in general, and GNAT in particular.
@end menu
@node Use of Boolean Constants,Debugging - A Special Case,,Modeling Conditional Compilation in Ada
-@anchor{gnat_ugn/the_gnat_compilation_model id49}@anchor{9b}@anchor{gnat_ugn/the_gnat_compilation_model use-of-boolean-constants}@anchor{9c}
+@anchor{gnat_ugn/the_gnat_compilation_model id49}@anchor{85}@anchor{gnat_ugn/the_gnat_compilation_model use-of-boolean-constants}@anchor{86}
@subsubsection Use of Boolean Constants
@@ -4281,7 +4065,7 @@ Then any other unit requiring conditional compilation can do a @emph{with}
of @code{Config} to make the constants visible.
@node Debugging - A Special Case,Conditionalizing Declarations,Use of Boolean Constants,Modeling Conditional Compilation in Ada
-@anchor{gnat_ugn/the_gnat_compilation_model debugging-a-special-case}@anchor{9d}@anchor{gnat_ugn/the_gnat_compilation_model id50}@anchor{9e}
+@anchor{gnat_ugn/the_gnat_compilation_model debugging-a-special-case}@anchor{87}@anchor{gnat_ugn/the_gnat_compilation_model id50}@anchor{88}
@subsubsection Debugging - A Special Case
@@ -4394,7 +4178,7 @@ end if;
@end example
@node Conditionalizing Declarations,Use of Alternative Implementations,Debugging - A Special Case,Modeling Conditional Compilation in Ada
-@anchor{gnat_ugn/the_gnat_compilation_model conditionalizing-declarations}@anchor{9f}@anchor{gnat_ugn/the_gnat_compilation_model id51}@anchor{a0}
+@anchor{gnat_ugn/the_gnat_compilation_model conditionalizing-declarations}@anchor{89}@anchor{gnat_ugn/the_gnat_compilation_model id51}@anchor{8a}
@subsubsection Conditionalizing Declarations
@@ -4459,7 +4243,7 @@ constant was introduced as @code{System.Default_Bit_Order}, so you do not
need to define this one yourself).
@node Use of Alternative Implementations,Preprocessing,Conditionalizing Declarations,Modeling Conditional Compilation in Ada
-@anchor{gnat_ugn/the_gnat_compilation_model use-of-alternative-implementations}@anchor{a1}@anchor{gnat_ugn/the_gnat_compilation_model id52}@anchor{a2}
+@anchor{gnat_ugn/the_gnat_compilation_model use-of-alternative-implementations}@anchor{8b}@anchor{gnat_ugn/the_gnat_compilation_model id52}@anchor{8c}
@subsubsection Use of Alternative Implementations
@@ -4593,7 +4377,7 @@ The same idea can also be implemented using tagged types and dispatching
calls.
@node Preprocessing,,Use of Alternative Implementations,Modeling Conditional Compilation in Ada
-@anchor{gnat_ugn/the_gnat_compilation_model preprocessing}@anchor{a3}@anchor{gnat_ugn/the_gnat_compilation_model id53}@anchor{a4}
+@anchor{gnat_ugn/the_gnat_compilation_model preprocessing}@anchor{8d}@anchor{gnat_ugn/the_gnat_compilation_model id53}@anchor{8e}
@subsubsection Preprocessing
@@ -4616,7 +4400,7 @@ The preprocessor may be used in two separate modes. It can be used quite
separately from the compiler, to generate a separate output source file
that is then fed to the compiler as a separate step. This is the
@code{gnatprep} utility, whose use is fully described in
-@ref{17,,Preprocessing with gnatprep}.
+@ref{8f,,Preprocessing with gnatprep}.
The preprocessing language allows such constructs as
@@ -4636,10 +4420,10 @@ often more convenient. In this approach the preprocessing is integrated into
the compilation process. The compiler is given the preprocessor input which
includes @code{#if} lines etc, and then the compiler carries out the
preprocessing internally and processes the resulting output.
-For more details on this approach, see @ref{18,,Integrated Preprocessing}.
+For more details on this approach, see @ref{90,,Integrated Preprocessing}.
@node Preprocessing with gnatprep,Integrated Preprocessing,Modeling Conditional Compilation in Ada,Conditional Compilation
-@anchor{gnat_ugn/the_gnat_compilation_model id54}@anchor{a5}@anchor{gnat_ugn/the_gnat_compilation_model preprocessing-with-gnatprep}@anchor{17}
+@anchor{gnat_ugn/the_gnat_compilation_model id54}@anchor{91}@anchor{gnat_ugn/the_gnat_compilation_model preprocessing-with-gnatprep}@anchor{8f}
@subsection Preprocessing with @code{gnatprep}
@@ -4652,7 +4436,7 @@ preprocessing.
Although designed for use with GNAT, @code{gnatprep} does not depend on any
special GNAT features.
For further discussion of conditional compilation in general, see
-@ref{16,,Conditional Compilation}.
+@ref{2b,,Conditional Compilation}.
@menu
* Preprocessing Symbols::
@@ -4664,7 +4448,7 @@ For further discussion of conditional compilation in general, see
@end menu
@node Preprocessing Symbols,Using gnatprep,,Preprocessing with gnatprep
-@anchor{gnat_ugn/the_gnat_compilation_model id55}@anchor{a6}@anchor{gnat_ugn/the_gnat_compilation_model preprocessing-symbols}@anchor{a7}
+@anchor{gnat_ugn/the_gnat_compilation_model id55}@anchor{92}@anchor{gnat_ugn/the_gnat_compilation_model preprocessing-symbols}@anchor{93}
@subsubsection Preprocessing Symbols
@@ -4674,7 +4458,7 @@ normal Ada (case-insensitive) rules for its syntax, with the restriction that
all characters need to be in the ASCII set (no accented letters).
@node Using gnatprep,Switches for gnatprep,Preprocessing Symbols,Preprocessing with gnatprep
-@anchor{gnat_ugn/the_gnat_compilation_model using-gnatprep}@anchor{a8}@anchor{gnat_ugn/the_gnat_compilation_model id56}@anchor{a9}
+@anchor{gnat_ugn/the_gnat_compilation_model using-gnatprep}@anchor{94}@anchor{gnat_ugn/the_gnat_compilation_model id56}@anchor{95}
@subsubsection Using @code{gnatprep}
@@ -4732,7 +4516,7 @@ optional, and can be replaced by the use of the @code{-D} switch.
@end itemize
@node Switches for gnatprep,Form of Definitions File,Using gnatprep,Preprocessing with gnatprep
-@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatprep}@anchor{aa}@anchor{gnat_ugn/the_gnat_compilation_model id57}@anchor{ab}
+@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatprep}@anchor{96}@anchor{gnat_ugn/the_gnat_compilation_model id57}@anchor{97}
@subsubsection Switches for @code{gnatprep}
@@ -4883,7 +4667,7 @@ deleted lines are completely removed from the output, unless -r is
specified, in which case -b is assumed.
@node Form of Definitions File,Form of Input Text for gnatprep,Switches for gnatprep,Preprocessing with gnatprep
-@anchor{gnat_ugn/the_gnat_compilation_model form-of-definitions-file}@anchor{ac}@anchor{gnat_ugn/the_gnat_compilation_model id58}@anchor{ad}
+@anchor{gnat_ugn/the_gnat_compilation_model form-of-definitions-file}@anchor{98}@anchor{gnat_ugn/the_gnat_compilation_model id58}@anchor{99}
@subsubsection Form of Definitions File
@@ -4913,7 +4697,7 @@ the usual @code{--},
and comments may be added to the definitions lines.
@node Form of Input Text for gnatprep,,Form of Definitions File,Preprocessing with gnatprep
-@anchor{gnat_ugn/the_gnat_compilation_model id59}@anchor{ae}@anchor{gnat_ugn/the_gnat_compilation_model form-of-input-text-for-gnatprep}@anchor{af}
+@anchor{gnat_ugn/the_gnat_compilation_model id59}@anchor{9a}@anchor{gnat_ugn/the_gnat_compilation_model form-of-input-text-for-gnatprep}@anchor{9b}
@subsubsection Form of Input Text for @code{gnatprep}
@@ -5045,7 +4829,7 @@ Header : String := $XYZ;
and then the substitution will occur as desired.
@node Integrated Preprocessing,,Preprocessing with gnatprep,Conditional Compilation
-@anchor{gnat_ugn/the_gnat_compilation_model id60}@anchor{b0}@anchor{gnat_ugn/the_gnat_compilation_model integrated-preprocessing}@anchor{18}
+@anchor{gnat_ugn/the_gnat_compilation_model id60}@anchor{9c}@anchor{gnat_ugn/the_gnat_compilation_model integrated-preprocessing}@anchor{90}
@subsection Integrated Preprocessing
@@ -5106,7 +4890,7 @@ because @code{gnatmake} cannot compute the checksum of the source after
preprocessing.
The actual preprocessing function is described in detail in
-@ref{17,,Preprocessing with gnatprep}. This section explains the switches
+@ref{8f,,Preprocessing with gnatprep}. This section explains the switches
that relate to integrated preprocessing.
@geindex -gnatep (gcc)
@@ -5205,7 +4989,7 @@ lines starting with the character '*'.
After the file name or '*', an optional literal string specifies the name of
the definition file to be used for preprocessing
-(@ref{ac,,Form of Definitions File}). The definition files are found by the
+(@ref{98,,Form of Definitions File}). The definition files are found by the
compiler in one of the source directories. In some cases, when compiling
a source in a directory other than the current directory, if the definition
file is in the current directory, it may be necessary to add the current
@@ -5297,7 +5081,7 @@ the output file will be @code{foo.adb.prep}.
@end table
@node Mixed Language Programming,GNAT and Other Compilation Models,Conditional Compilation,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model mixed-language-programming}@anchor{44}@anchor{gnat_ugn/the_gnat_compilation_model id61}@anchor{b1}
+@anchor{gnat_ugn/the_gnat_compilation_model mixed-language-programming}@anchor{2c}@anchor{gnat_ugn/the_gnat_compilation_model id61}@anchor{9d}
@section Mixed Language Programming
@@ -5316,7 +5100,7 @@ with a focus on combining Ada with C or C++.
@end menu
@node Interfacing to C,Calling Conventions,,Mixed Language Programming
-@anchor{gnat_ugn/the_gnat_compilation_model interfacing-to-c}@anchor{b2}@anchor{gnat_ugn/the_gnat_compilation_model id62}@anchor{b3}
+@anchor{gnat_ugn/the_gnat_compilation_model interfacing-to-c}@anchor{9e}@anchor{gnat_ugn/the_gnat_compilation_model id62}@anchor{9f}
@subsection Interfacing to C
@@ -5427,7 +5211,7 @@ $ gnatmake my_main.adb -largs file1.o file2.o
If the main program is in a language other than Ada, then you may have
more than one entry point into the Ada subsystem. You must use a special
binder option to generate callable routines that initialize and
-finalize the Ada units (@ref{b4,,Binding with Non-Ada Main Programs}).
+finalize the Ada units (@ref{a0,,Binding with Non-Ada Main Programs}).
Calls to the initialization and finalization routines must be inserted
in the main program, or some other appropriate point in the code. The
call to initialize the Ada units must occur before the first Ada
@@ -5543,7 +5327,7 @@ GNAT linker not to include the standard startup objects by passing the
@code{-nostartfiles} switch to @code{gnatlink}.
@node Calling Conventions,Building Mixed Ada and C++ Programs,Interfacing to C,Mixed Language Programming
-@anchor{gnat_ugn/the_gnat_compilation_model calling-conventions}@anchor{b5}@anchor{gnat_ugn/the_gnat_compilation_model id63}@anchor{b6}
+@anchor{gnat_ugn/the_gnat_compilation_model calling-conventions}@anchor{a1}@anchor{gnat_ugn/the_gnat_compilation_model id63}@anchor{a2}
@subsection Calling Conventions
@@ -5867,7 +5651,7 @@ identifier (for example in an @code{Import} pragma) with the same
meaning as Fortran.
@node Building Mixed Ada and C++ Programs,Generating Ada Bindings for C and C++ headers,Calling Conventions,Mixed Language Programming
-@anchor{gnat_ugn/the_gnat_compilation_model id64}@anchor{b7}@anchor{gnat_ugn/the_gnat_compilation_model building-mixed-ada-and-c-programs}@anchor{b8}
+@anchor{gnat_ugn/the_gnat_compilation_model id64}@anchor{a3}@anchor{gnat_ugn/the_gnat_compilation_model building-mixed-ada-and-c-programs}@anchor{a4}
@subsection Building Mixed Ada and C++ Programs
@@ -5885,7 +5669,7 @@ challenge. This section gives a few hints that should make this task easier.
@end menu
@node Interfacing to C++,Linking a Mixed C++ & Ada Program,,Building Mixed Ada and C++ Programs
-@anchor{gnat_ugn/the_gnat_compilation_model id65}@anchor{b9}@anchor{gnat_ugn/the_gnat_compilation_model id66}@anchor{ba}
+@anchor{gnat_ugn/the_gnat_compilation_model id65}@anchor{a5}@anchor{gnat_ugn/the_gnat_compilation_model id66}@anchor{a6}
@subsubsection Interfacing to C++
@@ -5897,7 +5681,7 @@ Interfacing can be done at 3 levels: simple data, subprograms, and
classes. In the first two cases, GNAT offers a specific @code{Convention C_Plus_Plus}
(or @code{CPP}) that behaves exactly like @code{Convention C}.
Usually, C++ mangles the names of subprograms. To generate proper mangled
-names automatically, see @ref{19,,Generating Ada Bindings for C and C++ headers}).
+names automatically, see @ref{a7,,Generating Ada Bindings for C and C++ headers}).
This problem can also be addressed manually in two ways:
@@ -5916,7 +5700,7 @@ Interfacing at the class level can be achieved by using the GNAT specific
pragmas such as @code{CPP_Constructor}. See the @cite{GNAT_Reference_Manual} for additional information.
@node Linking a Mixed C++ & Ada Program,A Simple Example,Interfacing to C++,Building Mixed Ada and C++ Programs
-@anchor{gnat_ugn/the_gnat_compilation_model linking-a-mixed-c-ada-program}@anchor{bb}@anchor{gnat_ugn/the_gnat_compilation_model linking-a-mixed-c-and-ada-program}@anchor{bc}
+@anchor{gnat_ugn/the_gnat_compilation_model linking-a-mixed-c-ada-program}@anchor{a8}@anchor{gnat_ugn/the_gnat_compilation_model linking-a-mixed-c-and-ada-program}@anchor{a9}
@subsubsection Linking a Mixed C++ & Ada Program
@@ -6031,7 +5815,7 @@ which has a large knowledge base and knows how to link Ada and C++ code
together automatically in most cases.
@node A Simple Example,Interfacing with C++ constructors,Linking a Mixed C++ & Ada Program,Building Mixed Ada and C++ Programs
-@anchor{gnat_ugn/the_gnat_compilation_model id67}@anchor{bd}@anchor{gnat_ugn/the_gnat_compilation_model a-simple-example}@anchor{be}
+@anchor{gnat_ugn/the_gnat_compilation_model id67}@anchor{aa}@anchor{gnat_ugn/the_gnat_compilation_model a-simple-example}@anchor{ab}
@subsubsection A Simple Example
@@ -6039,7 +5823,7 @@ The following example, provided as part of the GNAT examples, shows how
to achieve procedural interfacing between Ada and C++ in both
directions. The C++ class A has two methods. The first method is exported
to Ada by the means of an extern C wrapper function. The second method
-calls an Ada subprogram. On the Ada side, The C++ calls are modelled by
+calls an Ada subprogram. On the Ada side, the C++ calls are modelled by
a limited record with a layout comparable to the C++ class. The Ada
subprogram, in turn, calls the C++ method. So, starting from the C++
main program, the process passes back and forth between the two
@@ -6160,7 +5944,7 @@ end Simple_Cpp_Interface;
@end example
@node Interfacing with C++ constructors,Interfacing with C++ at the Class Level,A Simple Example,Building Mixed Ada and C++ Programs
-@anchor{gnat_ugn/the_gnat_compilation_model id68}@anchor{bf}@anchor{gnat_ugn/the_gnat_compilation_model interfacing-with-c-constructors}@anchor{c0}
+@anchor{gnat_ugn/the_gnat_compilation_model id68}@anchor{ac}@anchor{gnat_ugn/the_gnat_compilation_model interfacing-with-c-constructors}@anchor{ad}
@subsubsection Interfacing with C++ constructors
@@ -6187,8 +5971,8 @@ public:
For this purpose we can write the following package spec (further
information on how to build this spec is available in
-@ref{c1,,Interfacing with C++ at the Class Level} and
-@ref{19,,Generating Ada Bindings for C and C++ headers}).
+@ref{ae,,Interfacing with C++ at the Class Level} and
+@ref{a7,,Generating Ada Bindings for C and C++ headers}).
@example
with Interfaces.C; use Interfaces.C;
@@ -6357,7 +6141,7 @@ by means of a limited aggregate. Any further action associated with
the constructor can be placed inside the construct.
@node Interfacing with C++ at the Class Level,,Interfacing with C++ constructors,Building Mixed Ada and C++ Programs
-@anchor{gnat_ugn/the_gnat_compilation_model interfacing-with-c-at-the-class-level}@anchor{c1}@anchor{gnat_ugn/the_gnat_compilation_model id69}@anchor{c2}
+@anchor{gnat_ugn/the_gnat_compilation_model interfacing-with-c-at-the-class-level}@anchor{ae}@anchor{gnat_ugn/the_gnat_compilation_model id69}@anchor{af}
@subsubsection Interfacing with C++ at the Class Level
@@ -6603,7 +6387,7 @@ int main ()
@end example
@node Generating Ada Bindings for C and C++ headers,Generating C Headers for Ada Specifications,Building Mixed Ada and C++ Programs,Mixed Language Programming
-@anchor{gnat_ugn/the_gnat_compilation_model id70}@anchor{c3}@anchor{gnat_ugn/the_gnat_compilation_model generating-ada-bindings-for-c-and-c-headers}@anchor{19}
+@anchor{gnat_ugn/the_gnat_compilation_model id70}@anchor{b0}@anchor{gnat_ugn/the_gnat_compilation_model generating-ada-bindings-for-c-and-c-headers}@anchor{a7}
@subsection Generating Ada Bindings for C and C++ headers
@@ -6654,7 +6438,7 @@ even if your code is compiled using earlier versions of Ada (e.g. @code{-gnat95}
@end menu
@node Running the Binding Generator,Generating Bindings for C++ Headers,,Generating Ada Bindings for C and C++ headers
-@anchor{gnat_ugn/the_gnat_compilation_model id71}@anchor{c4}@anchor{gnat_ugn/the_gnat_compilation_model running-the-binding-generator}@anchor{c5}
+@anchor{gnat_ugn/the_gnat_compilation_model id71}@anchor{b1}@anchor{gnat_ugn/the_gnat_compilation_model running-the-binding-generator}@anchor{b2}
@subsubsection Running the Binding Generator
@@ -6748,7 +6532,7 @@ $ g++ -c -fdump-ada-spec readline1.h
@end example
@node Generating Bindings for C++ Headers,Switches,Running the Binding Generator,Generating Ada Bindings for C and C++ headers
-@anchor{gnat_ugn/the_gnat_compilation_model id72}@anchor{c6}@anchor{gnat_ugn/the_gnat_compilation_model generating-bindings-for-c-headers}@anchor{c7}
+@anchor{gnat_ugn/the_gnat_compilation_model id72}@anchor{b3}@anchor{gnat_ugn/the_gnat_compilation_model generating-bindings-for-c-headers}@anchor{b4}
@subsubsection Generating Bindings for C++ Headers
@@ -6849,7 +6633,7 @@ use Class_Dog;
@end example
@node Switches,,Generating Bindings for C++ Headers,Generating Ada Bindings for C and C++ headers
-@anchor{gnat_ugn/the_gnat_compilation_model switches}@anchor{c8}@anchor{gnat_ugn/the_gnat_compilation_model switches-for-ada-binding-generation}@anchor{c9}
+@anchor{gnat_ugn/the_gnat_compilation_model switches}@anchor{b5}@anchor{gnat_ugn/the_gnat_compilation_model switches-for-ada-binding-generation}@anchor{b6}
@subsubsection Switches
@@ -6897,7 +6681,7 @@ Extract comments from headers and generate Ada comments in the Ada spec files.
@end table
@node Generating C Headers for Ada Specifications,,Generating Ada Bindings for C and C++ headers,Mixed Language Programming
-@anchor{gnat_ugn/the_gnat_compilation_model generating-c-headers-for-ada-specifications}@anchor{ca}@anchor{gnat_ugn/the_gnat_compilation_model id73}@anchor{cb}
+@anchor{gnat_ugn/the_gnat_compilation_model generating-c-headers-for-ada-specifications}@anchor{b7}@anchor{gnat_ugn/the_gnat_compilation_model id73}@anchor{b8}
@subsection Generating C Headers for Ada Specifications
@@ -6940,7 +6724,7 @@ Subprogram declarations
@end menu
@node Running the C Header Generator,,,Generating C Headers for Ada Specifications
-@anchor{gnat_ugn/the_gnat_compilation_model running-the-c-header-generator}@anchor{cc}
+@anchor{gnat_ugn/the_gnat_compilation_model running-the-c-header-generator}@anchor{b9}
@subsubsection Running the C Header Generator
@@ -7008,7 +6792,7 @@ You can then @code{include} @code{pack1.h} from a C source file and use the type
call subprograms, reference objects, and constants.
@node GNAT and Other Compilation Models,Using GNAT Files with External Tools,Mixed Language Programming,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model id74}@anchor{cd}@anchor{gnat_ugn/the_gnat_compilation_model gnat-and-other-compilation-models}@anchor{45}
+@anchor{gnat_ugn/the_gnat_compilation_model id74}@anchor{ba}@anchor{gnat_ugn/the_gnat_compilation_model gnat-and-other-compilation-models}@anchor{2d}
@section GNAT and Other Compilation Models
@@ -7024,7 +6808,7 @@ used for Ada 83.
@end menu
@node Comparison between GNAT and C/C++ Compilation Models,Comparison between GNAT and Conventional Ada Library Models,,GNAT and Other Compilation Models
-@anchor{gnat_ugn/the_gnat_compilation_model comparison-between-gnat-and-c-c-compilation-models}@anchor{ce}@anchor{gnat_ugn/the_gnat_compilation_model id75}@anchor{cf}
+@anchor{gnat_ugn/the_gnat_compilation_model comparison-between-gnat-and-c-c-compilation-models}@anchor{bb}@anchor{gnat_ugn/the_gnat_compilation_model id75}@anchor{bc}
@subsection Comparison between GNAT and C/C++ Compilation Models
@@ -7058,7 +6842,7 @@ elaboration, a C++ compiler would simply construct a program that
malfunctioned at run time.
@node Comparison between GNAT and Conventional Ada Library Models,,Comparison between GNAT and C/C++ Compilation Models,GNAT and Other Compilation Models
-@anchor{gnat_ugn/the_gnat_compilation_model comparison-between-gnat-and-conventional-ada-library-models}@anchor{d0}@anchor{gnat_ugn/the_gnat_compilation_model id76}@anchor{d1}
+@anchor{gnat_ugn/the_gnat_compilation_model comparison-between-gnat-and-conventional-ada-library-models}@anchor{bd}@anchor{gnat_ugn/the_gnat_compilation_model id76}@anchor{be}
@subsection Comparison between GNAT and Conventional Ada Library Models
@@ -7126,7 +6910,7 @@ of rules saying what source files must be present when a file is
compiled.
@node Using GNAT Files with External Tools,,GNAT and Other Compilation Models,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model using-gnat-files-with-external-tools}@anchor{1a}@anchor{gnat_ugn/the_gnat_compilation_model id77}@anchor{d2}
+@anchor{gnat_ugn/the_gnat_compilation_model using-gnat-files-with-external-tools}@anchor{2e}@anchor{gnat_ugn/the_gnat_compilation_model id77}@anchor{bf}
@section Using GNAT Files with External Tools
@@ -7140,7 +6924,7 @@ used with tools designed for other languages.
@end menu
@node Using Other Utility Programs with GNAT,The External Symbol Naming Scheme of GNAT,,Using GNAT Files with External Tools
-@anchor{gnat_ugn/the_gnat_compilation_model using-other-utility-programs-with-gnat}@anchor{d3}@anchor{gnat_ugn/the_gnat_compilation_model id78}@anchor{d4}
+@anchor{gnat_ugn/the_gnat_compilation_model using-other-utility-programs-with-gnat}@anchor{c0}@anchor{gnat_ugn/the_gnat_compilation_model id78}@anchor{c1}
@subsection Using Other Utility Programs with GNAT
@@ -7155,7 +6939,7 @@ gprof (a profiling program), gdb (the FSF debugger), and utilities such
as Purify.
@node The External Symbol Naming Scheme of GNAT,,Using Other Utility Programs with GNAT,Using GNAT Files with External Tools
-@anchor{gnat_ugn/the_gnat_compilation_model the-external-symbol-naming-scheme-of-gnat}@anchor{d5}@anchor{gnat_ugn/the_gnat_compilation_model id79}@anchor{d6}
+@anchor{gnat_ugn/the_gnat_compilation_model the-external-symbol-naming-scheme-of-gnat}@anchor{c2}@anchor{gnat_ugn/the_gnat_compilation_model id79}@anchor{c3}
@subsection The External Symbol Naming Scheme of GNAT
@@ -7214,23 +6998,23 @@ the external name of this procedure will be @code{_ada_hello}.
@c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit
@node Building Executable Programs with GNAT,GNAT Utility Programs,The GNAT Compilation Model,Top
-@anchor{gnat_ugn/building_executable_programs_with_gnat building-executable-programs-with-gnat}@anchor{a}@anchor{gnat_ugn/building_executable_programs_with_gnat doc}@anchor{d7}@anchor{gnat_ugn/building_executable_programs_with_gnat id1}@anchor{d8}
+@anchor{gnat_ugn/building_executable_programs_with_gnat building-executable-programs-with-gnat}@anchor{a}@anchor{gnat_ugn/building_executable_programs_with_gnat doc}@anchor{c4}@anchor{gnat_ugn/building_executable_programs_with_gnat id1}@anchor{c5}
@chapter Building Executable Programs with GNAT
This chapter describes first the gnatmake tool
-(@ref{1b,,Building with gnatmake}),
+(@ref{c6,,Building with gnatmake}),
which automatically determines the set of sources
needed by an Ada compilation unit and executes the necessary
(re)compilations, binding and linking.
It also explains how to use each tool individually: the
-compiler (gcc, see @ref{1c,,Compiling with gcc}),
-binder (gnatbind, see @ref{1d,,Binding with gnatbind}),
-and linker (gnatlink, see @ref{1e,,Linking with gnatlink})
+compiler (gcc, see @ref{c7,,Compiling with gcc}),
+binder (gnatbind, see @ref{c8,,Binding with gnatbind}),
+and linker (gnatlink, see @ref{c9,,Linking with gnatlink})
to build executable programs.
Finally, this chapter provides examples of
how to make use of the general GNU make mechanism
-in a GNAT context (see @ref{1f,,Using the GNU make Utility}).
+in a GNAT context (see @ref{70,,Using the GNU make Utility}).
@menu
@@ -7245,7 +7029,7 @@ in a GNAT context (see @ref{1f,,Using the GNU make Utility}).
@end menu
@node Building with gnatmake,Compiling with gcc,,Building Executable Programs with GNAT
-@anchor{gnat_ugn/building_executable_programs_with_gnat the-gnat-make-program-gnatmake}@anchor{1b}@anchor{gnat_ugn/building_executable_programs_with_gnat building-with-gnatmake}@anchor{d9}
+@anchor{gnat_ugn/building_executable_programs_with_gnat the-gnat-make-program-gnatmake}@anchor{c6}@anchor{gnat_ugn/building_executable_programs_with_gnat building-with-gnatmake}@anchor{ca}
@section Building with @code{gnatmake}
@@ -7309,7 +7093,7 @@ to @code{gnatmake}.
@end menu
@node Running gnatmake,Switches for gnatmake,,Building with gnatmake
-@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatmake}@anchor{da}@anchor{gnat_ugn/building_executable_programs_with_gnat id2}@anchor{db}
+@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatmake}@anchor{cb}@anchor{gnat_ugn/building_executable_programs_with_gnat id2}@anchor{cc}
@subsection Running @code{gnatmake}
@@ -7337,14 +7121,14 @@ be searched for in the specified directory only. Otherwise, the input
source file will first be searched in the directory where
@code{gnatmake} was invoked and if it is not found, it will be search on
the source path of the compiler as described in
-@ref{89,,Search Paths and the Run-Time Library (RTL)}.
+@ref{73,,Search Paths and the Run-Time Library (RTL)}.
All @code{gnatmake} output (except when you specify @code{-M}) is sent to
@code{stderr}. The output produced by the
@code{-M} switch is sent to @code{stdout}.
@node Switches for gnatmake,Mode Switches for gnatmake,Running gnatmake,Building with gnatmake
-@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatmake}@anchor{dc}@anchor{gnat_ugn/building_executable_programs_with_gnat id3}@anchor{dd}
+@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatmake}@anchor{cd}@anchor{gnat_ugn/building_executable_programs_with_gnat id3}@anchor{ce}
@subsection Switches for @code{gnatmake}
@@ -7718,7 +7502,7 @@ then instead object files and ALI files that already exist are overwritten
in place. This means that once a large project is organized into separate
directories in the desired manner, then @code{gnatmake} will automatically
maintain and update this organization. If no ALI files are found on the
-Ada object path (see @ref{89,,Search Paths and the Run-Time Library (RTL)}),
+Ada object path (see @ref{73,,Search Paths and the Run-Time Library (RTL)}),
the new object and ALI files are created in the
directory containing the source being compiled. If another organization
is desired, where objects and sources are kept in different directories,
@@ -7984,7 +7768,7 @@ Verbosity level High. Equivalent to -v.
@item @code{-vP@emph{x}}
Indicate the verbosity of the parsing of GNAT project files.
-See @ref{de,,Switches Related to Project Files}.
+See @ref{cf,,Switches Related to Project Files}.
@end table
@geindex -x (gnatmake)
@@ -8008,7 +7792,7 @@ command line need to be sources of a project file.
Indicate that external variable @code{name} has the value @code{value}.
The Project Manager will use this value for occurrences of
@code{external(name)} when parsing the project file.
-@ref{de,,Switches Related to Project Files}.
+@ref{cf,,Switches Related to Project Files}.
@end table
@geindex -z (gnatmake)
@@ -8042,7 +7826,7 @@ is passed to @code{gcc} (e.g., @code{-O}, @code{-gnato,} etc.)
When looking for source files also look in directory @code{dir}.
The order in which source files search is undertaken is
-described in @ref{89,,Search Paths and the Run-Time Library (RTL)}.
+described in @ref{73,,Search Paths and the Run-Time Library (RTL)}.
@end table
@geindex -aL (gnatmake)
@@ -8074,7 +7858,7 @@ ALI files.
When searching for library and object files, look in directory
@code{dir}. The order in which library files are searched is described in
-@ref{8c,,Search Paths for gnatbind}.
+@ref{76,,Search Paths for gnatbind}.
@end table
@geindex Search paths
@@ -8179,7 +7963,7 @@ The selected path is handled like a normal RTS path.
@end table
@node Mode Switches for gnatmake,Notes on the Command Line,Switches for gnatmake,Building with gnatmake
-@anchor{gnat_ugn/building_executable_programs_with_gnat id4}@anchor{df}@anchor{gnat_ugn/building_executable_programs_with_gnat mode-switches-for-gnatmake}@anchor{e0}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id4}@anchor{d0}@anchor{gnat_ugn/building_executable_programs_with_gnat mode-switches-for-gnatmake}@anchor{d1}
@subsection Mode Switches for @code{gnatmake}
@@ -8239,7 +8023,7 @@ or @code{-largs}.
@end table
@node Notes on the Command Line,How gnatmake Works,Mode Switches for gnatmake,Building with gnatmake
-@anchor{gnat_ugn/building_executable_programs_with_gnat id5}@anchor{e1}@anchor{gnat_ugn/building_executable_programs_with_gnat notes-on-the-command-line}@anchor{e2}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id5}@anchor{d2}@anchor{gnat_ugn/building_executable_programs_with_gnat notes-on-the-command-line}@anchor{d3}
@subsection Notes on the Command Line
@@ -8309,7 +8093,7 @@ that the debugging information may be out of date.
@end itemize
@node How gnatmake Works,Examples of gnatmake Usage,Notes on the Command Line,Building with gnatmake
-@anchor{gnat_ugn/building_executable_programs_with_gnat id6}@anchor{e3}@anchor{gnat_ugn/building_executable_programs_with_gnat how-gnatmake-works}@anchor{e4}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id6}@anchor{d4}@anchor{gnat_ugn/building_executable_programs_with_gnat how-gnatmake-works}@anchor{d5}
@subsection How @code{gnatmake} Works
@@ -8349,14 +8133,14 @@ When invoking @code{gnatmake} with several @code{file_names}, if a unit is
imported by several of the executables, it will be recompiled at most once.
Note: when using non-standard naming conventions
-(@ref{35,,Using Other File Names}), changing through a configuration pragmas
+(@ref{1c,,Using Other File Names}), changing through a configuration pragmas
file the version of a source and invoking @code{gnatmake} to recompile may
have no effect, if the previous version of the source is still accessible
by @code{gnatmake}. It may be necessary to use the switch
-f.
@node Examples of gnatmake Usage,,How gnatmake Works,Building with gnatmake
-@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatmake-usage}@anchor{e5}@anchor{gnat_ugn/building_executable_programs_with_gnat id7}@anchor{e6}
+@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatmake-usage}@anchor{d6}@anchor{gnat_ugn/building_executable_programs_with_gnat id7}@anchor{d7}
@subsection Examples of @code{gnatmake} Usage
@@ -8388,7 +8172,7 @@ displaying commands it is executing.
@end table
@node Compiling with gcc,Compiler Switches,Building with gnatmake,Building Executable Programs with GNAT
-@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-with-gcc}@anchor{1c}@anchor{gnat_ugn/building_executable_programs_with_gnat id8}@anchor{e7}
+@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-with-gcc}@anchor{c7}@anchor{gnat_ugn/building_executable_programs_with_gnat id8}@anchor{d8}
@section Compiling with @code{gcc}
@@ -8405,7 +8189,7 @@ that can be used to control the behavior of the compiler.
@end menu
@node Compiling Programs,Search Paths and the Run-Time Library RTL,,Compiling with gcc
-@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-programs}@anchor{e8}@anchor{gnat_ugn/building_executable_programs_with_gnat id9}@anchor{e9}
+@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-programs}@anchor{d9}@anchor{gnat_ugn/building_executable_programs_with_gnat id9}@anchor{da}
@subsection Compiling Programs
@@ -8518,11 +8302,11 @@ calls @code{gnat1} (the Ada compiler) twice to compile @code{x.adb} and
The compiler generates two object files @code{x.o} and @code{y.o}
and the two ALI files @code{x.ali} and @code{y.ali}.
-Any switches apply to all the files listed, see @ref{ea,,Compiler Switches} for a
+Any switches apply to all the files listed, see @ref{db,,Compiler Switches} for a
list of available @code{gcc} switches.
@node Search Paths and the Run-Time Library RTL,Order of Compilation Issues,Compiling Programs,Compiling with gcc
-@anchor{gnat_ugn/building_executable_programs_with_gnat id10}@anchor{eb}@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-and-the-run-time-library-rtl}@anchor{89}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id10}@anchor{dc}@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-and-the-run-time-library-rtl}@anchor{73}
@subsection Search Paths and the Run-Time Library (RTL)
@@ -8579,7 +8363,7 @@ names separated by colons (semicolons when working with the NT version).
The content of the @code{ada_source_path} file which is part of the GNAT
installation tree and is used to store standard libraries such as the
GNAT Run Time Library (RTL) source files.
-@ref{87,,Installing a library}
+@ref{71,,Installing a library}
@end itemize
Specifying the switch @code{-I-}
@@ -8621,7 +8405,7 @@ in compiling sources from multiple directories. This can make
development environments much more flexible.
@node Order of Compilation Issues,Examples,Search Paths and the Run-Time Library RTL,Compiling with gcc
-@anchor{gnat_ugn/building_executable_programs_with_gnat id11}@anchor{ec}@anchor{gnat_ugn/building_executable_programs_with_gnat order-of-compilation-issues}@anchor{ed}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id11}@anchor{dd}@anchor{gnat_ugn/building_executable_programs_with_gnat order-of-compilation-issues}@anchor{de}
@subsection Order of Compilation Issues
@@ -8649,7 +8433,7 @@ source files on which it depends.
@item
There is no library as such, apart from the ALI files
-(@ref{42,,The Ada Library Information Files}, for information on the format
+(@ref{28,,The Ada Library Information Files}, for information on the format
of these files). For now we find it convenient to create separate ALI files,
but eventually the information therein may be incorporated into the object
file directly.
@@ -8662,7 +8446,7 @@ described above), or you will receive a fatal error message.
@end itemize
@node Examples,,Order of Compilation Issues,Compiling with gcc
-@anchor{gnat_ugn/building_executable_programs_with_gnat id12}@anchor{ee}@anchor{gnat_ugn/building_executable_programs_with_gnat examples}@anchor{ef}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id12}@anchor{df}@anchor{gnat_ugn/building_executable_programs_with_gnat examples}@anchor{e0}
@subsection Examples
@@ -8690,7 +8474,7 @@ Compile the subunit in file @code{abc-def.adb} in semantic-checking-only
mode.
@node Compiler Switches,Linker Switches,Compiling with gcc,Building Executable Programs with GNAT
-@anchor{gnat_ugn/building_executable_programs_with_gnat compiler-switches}@anchor{f0}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gcc}@anchor{ea}
+@anchor{gnat_ugn/building_executable_programs_with_gnat compiler-switches}@anchor{e1}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gcc}@anchor{db}
@section Compiler Switches
@@ -8729,7 +8513,7 @@ compilation units.
@end menu
@node Alphabetical List of All Switches,Output and Error Message Control,,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat id13}@anchor{f1}@anchor{gnat_ugn/building_executable_programs_with_gnat alphabetical-list-of-all-switches}@anchor{f2}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id13}@anchor{e2}@anchor{gnat_ugn/building_executable_programs_with_gnat alphabetical-list-of-all-switches}@anchor{e3}
@subsection Alphabetical List of All Switches
@@ -8914,7 +8698,7 @@ and thus producing inferior code.
Causes the compiler to avoid assumptions regarding non-aliasing
of objects of different types. See
-@ref{f3,,Optimization and Strict Aliasing} for details.
+@ref{e4,,Optimization and Strict Aliasing} for details.
@end table
@geindex -fno-strict-overflow (gcc)
@@ -8940,7 +8724,7 @@ for very peculiar cases of low-level programming.
@item @code{-fstack-check}
Activates stack checking.
-See @ref{f4,,Stack Overflow Checking} for details.
+See @ref{e5,,Stack Overflow Checking} for details.
@end table
@geindex -fstack-usage (gcc)
@@ -8951,7 +8735,7 @@ See @ref{f4,,Stack Overflow Checking} for details.
@item @code{-fstack-usage}
Makes the compiler output stack usage information for the program, on a
-per-subprogram basis. See @ref{f5,,Static Stack Usage Analysis} for details.
+per-subprogram basis. See @ref{e6,,Static Stack Usage Analysis} for details.
@end table
@geindex -g (gcc)
@@ -9081,7 +8865,7 @@ Generate brief messages to @code{stderr} even if verbose mode set.
@item @code{-gnatB}
Assume no invalid (bad) values except for 'Valid attribute use
-(@ref{f6,,Validity Checking}).
+(@ref{e7,,Validity Checking}).
@end table
@geindex -gnatc (gcc)
@@ -9194,7 +8978,7 @@ not share the memory location of @code{Obj}.
Specify a configuration pragma file
(the equal sign is optional)
-(@ref{79,,The Configuration Pragmas Files}).
+(@ref{62,,The Configuration Pragmas Files}).
@end table
@geindex -gnateC (gcc)
@@ -9227,7 +9011,7 @@ Disable atomic synchronization
@item @code{-gnateDsymbol[=@emph{value}]}
Defines a symbol, associated with @code{value}, for preprocessing.
-(@ref{18,,Integrated Preprocessing}).
+(@ref{90,,Integrated Preprocessing}).
@end table
@geindex -gnateE (gcc)
@@ -9276,7 +9060,7 @@ for unconstrained predefined types. See description of pragma
The @code{-gnatc} switch must always be specified before this switch, e.g.
@code{-gnatceg}. Generate a C header from the Ada input file. See
-@ref{ca,,Generating C Headers for Ada Specifications} for more
+@ref{b7,,Generating C Headers for Ada Specifications} for more
information.
@end quotation
@@ -9350,7 +9134,7 @@ This switch turns off the info messages about implicit elaboration pragmas.
Specify a mapping file
(the equal sign is optional)
-(@ref{f7,,Units to Sources Mapping Files}).
+(@ref{e8,,Units to Sources Mapping Files}).
@end table
@geindex -gnatep (gcc)
@@ -9362,7 +9146,7 @@ Specify a mapping file
Specify a preprocessing data file
(the equal sign is optional)
-(@ref{18,,Integrated Preprocessing}).
+(@ref{90,,Integrated Preprocessing}).
@end table
@geindex -gnateP (gcc)
@@ -9560,7 +9344,7 @@ support this switch.
@item @code{-gnateV}
Check that all actual parameters of a subprogram call are valid according to
-the rules of validity checking (@ref{f6,,Validity Checking}).
+the rules of validity checking (@ref{e7,,Validity Checking}).
@end table
@geindex -gnateY (gcc)
@@ -9664,7 +9448,7 @@ For further details see @ref{f,,Elaboration Order Handling in GNAT}.
Identifier character set (@code{c} = 1/2/3/4/8/9/p/f/n/w).
For details of the possible selections for @code{c},
-see @ref{48,,Character Set Control}.
+see @ref{31,,Character Set Control}.
@end table
@geindex -gnatI (gcc)
@@ -9686,10 +9470,6 @@ Object_Size, Scalar_Storage_Order, Size, Small, Stream_Size,
and Value_Size. Pragma Default_Scalar_Storage_Order is also ignored.
Note that this option should be used only for compiling -- the
code is likely to malfunction at run time.
-
-Note that when @code{-gnatct} is used to generate trees for input
-into ASIS tools, these representation clauses are removed
-from the tree and ignored. This means that the tool will not see them.
@end table
@geindex -gnatjnn (gcc)
@@ -9917,7 +9697,7 @@ overflow checking is enabled.
Note that division by zero is a separate check that is not
controlled by this switch (divide-by-zero checking is on by default).
-See also @ref{f8,,Specifying the Desired Mode}.
+See also @ref{e9,,Specifying the Desired Mode}.
@end table
@geindex -gnatp (gcc)
@@ -9927,7 +9707,7 @@ See also @ref{f8,,Specifying the Desired Mode}.
@item @code{-gnatp}
-Suppress all checks. See @ref{f9,,Run-Time Checks} for details. This switch
+Suppress all checks. See @ref{ea,,Run-Time Checks} for details. This switch
has no effect if cancelled by a subsequent @code{-gnat-p} switch.
@end table
@@ -10019,16 +9799,6 @@ Syntax check only.
Print package Standard.
@end table
-@geindex -gnatt (gcc)
-
-
-@table @asis
-
-@item @code{-gnatt}
-
-Generate tree output file.
-@end table
-
@geindex -gnatT (gcc)
@@ -10076,7 +9846,7 @@ Verbose mode. Full error output with source lines to @code{stdout}.
@item @code{-gnatV}
-Control level of validity checking (@ref{f6,,Validity Checking}).
+Control level of validity checking (@ref{e7,,Validity Checking}).
@end table
@geindex -gnatw (gcc)
@@ -10089,7 +9859,7 @@ Control level of validity checking (@ref{f6,,Validity Checking}).
Warning mode where
@code{xxx} is a string of option letters that denotes
the exact warnings that
-are enabled or disabled (@ref{fa,,Warning Message Control}).
+are enabled or disabled (@ref{eb,,Warning Message Control}).
@end table
@geindex -gnatW (gcc)
@@ -10130,7 +9900,7 @@ Enable GNAT implementation extensions and latest Ada version.
@item @code{-gnaty}
-Enable built-in style checks (@ref{fb,,Style Checking}).
+Enable built-in style checks (@ref{ec,,Style Checking}).
@end table
@geindex -gnatz (gcc)
@@ -10155,7 +9925,7 @@ Distribution stub generation and compilation
Direct GNAT to search the @code{dir} directory for source files needed by
the current compilation
-(see @ref{89,,Search Paths and the Run-Time Library (RTL)}).
+(see @ref{73,,Search Paths and the Run-Time Library (RTL)}).
@end table
@geindex -I- (gcc)
@@ -10169,7 +9939,7 @@ the current compilation
Except for the source file named in the command line, do not look for source
files in the directory containing the source file named in the command line
-(see @ref{89,,Search Paths and the Run-Time Library (RTL)}).
+(see @ref{73,,Search Paths and the Run-Time Library (RTL)}).
@end table
@geindex -o (gcc)
@@ -10273,7 +10043,7 @@ Optimize space usage
@end multitable
-See also @ref{fc,,Optimization Levels}.
+See also @ref{ed,,Optimization Levels}.
@end table
@geindex -pass-exit-codes (gcc)
@@ -10295,7 +10065,7 @@ exit status.
@item @code{--RTS=@emph{rts-path}}
Specifies the default location of the run-time library. Same meaning as the
-equivalent @code{gnatmake} flag (@ref{dc,,Switches for gnatmake}).
+equivalent @code{gnatmake} flag (@ref{cd,,Switches for gnatmake}).
@end table
@geindex -S (gcc)
@@ -10421,7 +10191,7 @@ as warning mode modifiers (see description of @code{-gnatw}).
@item
Once a 'V' appears in the string (that is a use of the @code{-gnatV}
switch), then all further characters in the switch are interpreted
-as validity checking options (@ref{f6,,Validity Checking}).
+as validity checking options (@ref{e7,,Validity Checking}).
@item
Option 'em', 'ec', 'ep', 'l=' and 'R' must be the last options in
@@ -10429,7 +10199,7 @@ a combined list of options.
@end itemize
@node Output and Error Message Control,Warning Message Control,Alphabetical List of All Switches,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat id14}@anchor{fd}@anchor{gnat_ugn/building_executable_programs_with_gnat output-and-error-message-control}@anchor{fe}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id14}@anchor{ee}@anchor{gnat_ugn/building_executable_programs_with_gnat output-and-error-message-control}@anchor{ef}
@subsection Output and Error Message Control
@@ -10715,14 +10485,6 @@ environments) that are driven from the @code{ALI} file. This switch
implies @code{-gnatq}, since the semantic phase must be run to get a
meaningful ALI file.
-In addition, if @code{-gnatt} is also specified, then the tree file is
-generated even if there are illegalities. It may be useful in this case
-to also specify @code{-gnatq} to ensure that full semantic processing
-occurs. The resulting tree file can be processed by ASIS, for the purpose
-of providing partial information about illegal units, but if the error
-causes the tree to be badly malformed, then ASIS may crash during the
-analysis.
-
When @code{-gnatQ} is used and the generated @code{ALI} file is marked as
being in error, @code{gnatmake} will attempt to recompile the source when it
finds such an @code{ALI} file, including with switch @code{-gnatc}.
@@ -10732,7 +10494,7 @@ since ALI files are never generated if @code{-gnats} is set.
@end table
@node Warning Message Control,Debugging and Assertion Control,Output and Error Message Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat warning-message-control}@anchor{fa}@anchor{gnat_ugn/building_executable_programs_with_gnat id15}@anchor{ff}
+@anchor{gnat_ugn/building_executable_programs_with_gnat warning-message-control}@anchor{eb}@anchor{gnat_ugn/building_executable_programs_with_gnat id15}@anchor{f0}
@subsection Warning Message Control
@@ -12837,7 +12599,7 @@ used in conjunction with an optimization level greater than zero.
@item @code{-Wstack-usage=@emph{len}}
Warn if the stack usage of a subprogram might be larger than @code{len} bytes.
-See @ref{f5,,Static Stack Usage Analysis} for details.
+See @ref{e6,,Static Stack Usage Analysis} for details.
@end table
@geindex -Wall (gcc)
@@ -13035,7 +12797,7 @@ When no switch @code{-gnatw} is used, this is equivalent to:
@end quotation
@node Debugging and Assertion Control,Validity Checking,Warning Message Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat debugging-and-assertion-control}@anchor{100}@anchor{gnat_ugn/building_executable_programs_with_gnat id16}@anchor{101}
+@anchor{gnat_ugn/building_executable_programs_with_gnat debugging-and-assertion-control}@anchor{f1}@anchor{gnat_ugn/building_executable_programs_with_gnat id16}@anchor{f2}
@subsection Debugging and Assertion Control
@@ -13124,7 +12886,7 @@ is @code{False}, the exception @code{Assert_Failure} is raised.
@end table
@node Validity Checking,Style Checking,Debugging and Assertion Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat validity-checking}@anchor{f6}@anchor{gnat_ugn/building_executable_programs_with_gnat id17}@anchor{102}
+@anchor{gnat_ugn/building_executable_programs_with_gnat validity-checking}@anchor{e7}@anchor{gnat_ugn/building_executable_programs_with_gnat id17}@anchor{f3}
@subsection Validity Checking
@@ -13186,7 +12948,7 @@ to the default checks required by Ada as described above.
All validity checks are turned on.
That is, @code{-gnatVa} is
-equivalent to @code{gnatVcdfimorst}.
+equivalent to @code{gnatVcdfimoprst}.
@end table
@geindex -gnatVc (gcc)
@@ -13413,7 +13175,7 @@ the validity checking mode at the program source level, and also allows for
temporary disabling of validity checks.
@node Style Checking,Run-Time Checks,Validity Checking,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat id18}@anchor{103}@anchor{gnat_ugn/building_executable_programs_with_gnat style-checking}@anchor{fb}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id18}@anchor{f4}@anchor{gnat_ugn/building_executable_programs_with_gnat style-checking}@anchor{ec}
@subsection Style Checking
@@ -14135,7 +13897,7 @@ built-in standard style check options are enabled.
The switch @code{-gnatyN} clears any previously set style checks.
@node Run-Time Checks,Using gcc for Syntax Checking,Style Checking,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat run-time-checks}@anchor{f9}@anchor{gnat_ugn/building_executable_programs_with_gnat id19}@anchor{104}
+@anchor{gnat_ugn/building_executable_programs_with_gnat run-time-checks}@anchor{ea}@anchor{gnat_ugn/building_executable_programs_with_gnat id19}@anchor{f5}
@subsection Run-Time Checks
@@ -14329,7 +14091,7 @@ on subprogram calls and generic instantiations.
Note that @code{-gnatE} is not necessary for safety, because in the
default mode, GNAT ensures statically that the checks would not fail.
For full details of the effect and use of this switch,
-@ref{1c,,Compiling with gcc}.
+@ref{c7,,Compiling with gcc}.
@end table
@geindex -fstack-check (gcc)
@@ -14345,7 +14107,7 @@ For full details of the effect and use of this switch,
@item @code{-fstack-check}
Activates stack overflow checking. For full details of the effect and use of
-this switch see @ref{f4,,Stack Overflow Checking}.
+this switch see @ref{e5,,Stack Overflow Checking}.
@end table
@geindex Unsuppress
@@ -14356,7 +14118,7 @@ checks) or @code{Unsuppress} (to add back suppressed checks) pragmas in
the program source.
@node Using gcc for Syntax Checking,Using gcc for Semantic Checking,Run-Time Checks,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat id20}@anchor{105}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gcc-for-syntax-checking}@anchor{106}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id20}@anchor{f6}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gcc-for-syntax-checking}@anchor{f7}
@subsection Using @code{gcc} for Syntax Checking
@@ -14409,11 +14171,11 @@ Normally, GNAT allows only a single unit in a source file. However, this
restriction does not apply in syntax-check-only mode, and it is possible
to check a file containing multiple compilation units concatenated
together. This is primarily used by the @code{gnatchop} utility
-(@ref{36,,Renaming Files with gnatchop}).
+(@ref{1d,,Renaming Files with gnatchop}).
@end table
@node Using gcc for Semantic Checking,Compiling Different Versions of Ada,Using gcc for Syntax Checking,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat id21}@anchor{107}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gcc-for-semantic-checking}@anchor{108}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id21}@anchor{f8}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gcc-for-semantic-checking}@anchor{f9}
@subsection Using @code{gcc} for Semantic Checking
@@ -14438,13 +14200,13 @@ semantic restrictions on file structuring to operate in this mode:
@item
The needed source files must be accessible
-(see @ref{89,,Search Paths and the Run-Time Library (RTL)}).
+(see @ref{73,,Search Paths and the Run-Time Library (RTL)}).
@item
Each file must contain only one compilation unit.
@item
-The file name and unit name must match (@ref{52,,File Naming Rules}).
+The file name and unit name must match (@ref{3b,,File Naming Rules}).
@end itemize
The output consists of error messages as appropriate. No object file is
@@ -14460,7 +14222,7 @@ and specifications where a separate body is present).
@end table
@node Compiling Different Versions of Ada,Character Set Control,Using gcc for Semantic Checking,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-different-versions-of-ada}@anchor{6}@anchor{gnat_ugn/building_executable_programs_with_gnat id22}@anchor{109}
+@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-different-versions-of-ada}@anchor{6}@anchor{gnat_ugn/building_executable_programs_with_gnat id22}@anchor{fa}
@subsection Compiling Different Versions of Ada
@@ -14594,7 +14356,7 @@ extensions, see the GNAT reference manual.
@end table
@node Character Set Control,File Naming Control,Compiling Different Versions of Ada,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat id23}@anchor{10a}@anchor{gnat_ugn/building_executable_programs_with_gnat character-set-control}@anchor{48}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id23}@anchor{fb}@anchor{gnat_ugn/building_executable_programs_with_gnat character-set-control}@anchor{31}
@subsection Character Set Control
@@ -14705,7 +14467,7 @@ allowed in identifiers
@end multitable
-See @ref{3e,,Foreign Language Representation} for full details on the
+See @ref{23,,Foreign Language Representation} for full details on the
implementation of these character sets.
@end table
@@ -14773,7 +14535,7 @@ Brackets encoding only (default value)
For full details on these encoding
-methods see @ref{4e,,Wide_Character Encodings}.
+methods see @ref{37,,Wide_Character Encodings}.
Note that brackets coding is always accepted, even if one of the other
options is specified, so for example @code{-gnatW8} specifies that both
brackets and UTF-8 encodings will be recognized. The units that are
@@ -14821,7 +14583,7 @@ comments are ended by an appropriate (CR, or CR/LF, or LF) line terminator.
This is a common mode for many programs with foreign language comments.
@node File Naming Control,Subprogram Inlining Control,Character Set Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat file-naming-control}@anchor{10b}@anchor{gnat_ugn/building_executable_programs_with_gnat id24}@anchor{10c}
+@anchor{gnat_ugn/building_executable_programs_with_gnat file-naming-control}@anchor{fc}@anchor{gnat_ugn/building_executable_programs_with_gnat id24}@anchor{fd}
@subsection File Naming Control
@@ -14837,11 +14599,11 @@ Activates file name 'krunching'. @code{n}, a decimal integer in the range
including the @code{.ads} or @code{.adb} extension). The default is not
to enable file name krunching.
-For the source file naming rules, @ref{52,,File Naming Rules}.
+For the source file naming rules, @ref{3b,,File Naming Rules}.
@end table
@node Subprogram Inlining Control,Auxiliary Output Control,File Naming Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat subprogram-inlining-control}@anchor{10d}@anchor{gnat_ugn/building_executable_programs_with_gnat id25}@anchor{10e}
+@anchor{gnat_ugn/building_executable_programs_with_gnat subprogram-inlining-control}@anchor{fe}@anchor{gnat_ugn/building_executable_programs_with_gnat id25}@anchor{ff}
@subsection Subprogram Inlining Control
@@ -14874,7 +14636,7 @@ If you specify this switch the compiler will access these bodies,
creating an extra source dependency for the resulting object file, and
where possible, the call will be inlined.
For further details on when inlining is possible
-see @ref{10f,,Inlining of Subprograms}.
+see @ref{100,,Inlining of Subprograms}.
@end table
@geindex -gnatN (gcc)
@@ -14895,32 +14657,10 @@ inlining, but that is no longer the case.
@end table
@node Auxiliary Output Control,Debugging Control,Subprogram Inlining Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat auxiliary-output-control}@anchor{110}@anchor{gnat_ugn/building_executable_programs_with_gnat id26}@anchor{111}
+@anchor{gnat_ugn/building_executable_programs_with_gnat auxiliary-output-control}@anchor{101}@anchor{gnat_ugn/building_executable_programs_with_gnat id26}@anchor{102}
@subsection Auxiliary Output Control
-@geindex -gnatt (gcc)
-
-@geindex Writing internal trees
-
-@geindex Internal trees
-@geindex writing to file
-
-
-@table @asis
-
-@item @code{-gnatt}
-
-Causes GNAT to write the internal tree for a unit to a file (with the
-extension @code{.adt}.
-This not normally required, but is used by separate analysis tools.
-Typically
-these tools do the necessary compilations automatically, so you should
-not have to specify this switch in normal operation.
-Note that the combination of switches @code{-gnatct}
-generates a tree in the form required by ASIS applications.
-@end table
-
@geindex -gnatu (gcc)
@@ -14987,7 +14727,7 @@ An object file has been generated for every source file.
@end table
@node Debugging Control,Exception Handling Control,Auxiliary Output Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat debugging-control}@anchor{112}@anchor{gnat_ugn/building_executable_programs_with_gnat id27}@anchor{113}
+@anchor{gnat_ugn/building_executable_programs_with_gnat debugging-control}@anchor{103}@anchor{gnat_ugn/building_executable_programs_with_gnat id27}@anchor{104}
@subsection Debugging Control
@@ -15336,7 +15076,7 @@ encodings for the rest.
@end table
@node Exception Handling Control,Units to Sources Mapping Files,Debugging Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat id28}@anchor{114}@anchor{gnat_ugn/building_executable_programs_with_gnat exception-handling-control}@anchor{115}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id28}@anchor{105}@anchor{gnat_ugn/building_executable_programs_with_gnat exception-handling-control}@anchor{106}
@subsection Exception Handling Control
@@ -15404,11 +15144,11 @@ is available for the target in use, otherwise it will generate an error.
The same option @code{--RTS} must be used both for @code{gcc}
and @code{gnatbind}. Passing this option to @code{gnatmake}
-(@ref{dc,,Switches for gnatmake}) will ensure the required consistency
+(@ref{cd,,Switches for gnatmake}) will ensure the required consistency
through the compilation and binding steps.
@node Units to Sources Mapping Files,Code Generation Control,Exception Handling Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat id29}@anchor{116}@anchor{gnat_ugn/building_executable_programs_with_gnat units-to-sources-mapping-files}@anchor{f7}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id29}@anchor{107}@anchor{gnat_ugn/building_executable_programs_with_gnat units-to-sources-mapping-files}@anchor{e8}
@subsection Units to Sources Mapping Files
@@ -15460,7 +15200,7 @@ mapping file and communicates it to the compiler using this switch.
@end table
@node Code Generation Control,,Units to Sources Mapping Files,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat code-generation-control}@anchor{117}@anchor{gnat_ugn/building_executable_programs_with_gnat id30}@anchor{118}
+@anchor{gnat_ugn/building_executable_programs_with_gnat code-generation-control}@anchor{108}@anchor{gnat_ugn/building_executable_programs_with_gnat id30}@anchor{109}
@subsection Code Generation Control
@@ -15489,7 +15229,7 @@ there is no point in using @code{-m} switches to improve performance
unless you actually see a performance improvement.
@node Linker Switches,Binding with gnatbind,Compiler Switches,Building Executable Programs with GNAT
-@anchor{gnat_ugn/building_executable_programs_with_gnat linker-switches}@anchor{119}@anchor{gnat_ugn/building_executable_programs_with_gnat id31}@anchor{11a}
+@anchor{gnat_ugn/building_executable_programs_with_gnat linker-switches}@anchor{10a}@anchor{gnat_ugn/building_executable_programs_with_gnat id31}@anchor{10b}
@section Linker Switches
@@ -15509,7 +15249,7 @@ platforms.
@end table
@node Binding with gnatbind,Linking with gnatlink,Linker Switches,Building Executable Programs with GNAT
-@anchor{gnat_ugn/building_executable_programs_with_gnat binding-with-gnatbind}@anchor{1d}@anchor{gnat_ugn/building_executable_programs_with_gnat id32}@anchor{11b}
+@anchor{gnat_ugn/building_executable_programs_with_gnat binding-with-gnatbind}@anchor{c8}@anchor{gnat_ugn/building_executable_programs_with_gnat id32}@anchor{10c}
@section Binding with @code{gnatbind}
@@ -15560,7 +15300,7 @@ to be read by the @code{gnatlink} utility used to link the Ada application.
@end menu
@node Running gnatbind,Switches for gnatbind,,Binding with gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatbind}@anchor{11c}@anchor{gnat_ugn/building_executable_programs_with_gnat id33}@anchor{11d}
+@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatbind}@anchor{10d}@anchor{gnat_ugn/building_executable_programs_with_gnat id33}@anchor{10e}
@subsection Running @code{gnatbind}
@@ -15645,7 +15385,7 @@ Ada code provided the @code{-g} switch is used for
@code{gnatbind} and @code{gnatlink}.
@node Switches for gnatbind,Command-Line Access,Running gnatbind,Binding with gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat id34}@anchor{11e}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatbind}@anchor{11f}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id34}@anchor{10f}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatbind}@anchor{110}
@subsection Switches for @code{gnatbind}
@@ -15840,7 +15580,7 @@ Currently the same as @code{-Ea}.
@item @code{-f@emph{elab-order}}
-Force elaboration order. For further details see @ref{120,,Elaboration Control}
+Force elaboration order. For further details see @ref{111,,Elaboration Control}
and @ref{f,,Elaboration Order Handling in GNAT}.
@end table
@@ -15889,7 +15629,7 @@ Legacy elaboration order model enabled. For further details see
@item @code{-H32}
Use 32-bit allocations for @code{__gnat_malloc} (and thus for access types).
-For further details see @ref{121,,Dynamic Allocation Control}.
+For further details see @ref{112,,Dynamic Allocation Control}.
@end table
@geindex -H64 (gnatbind)
@@ -15902,7 +15642,7 @@ For further details see @ref{121,,Dynamic Allocation Control}.
@item @code{-H64}
Use 64-bit allocations for @code{__gnat_malloc} (and thus for access types).
-For further details see @ref{121,,Dynamic Allocation Control}.
+For further details see @ref{112,,Dynamic Allocation Control}.
@geindex -I (gnatbind)
@@ -15929,11 +15669,11 @@ Output chosen elaboration order.
@item @code{-L@emph{xxx}}
Bind the units for library building. In this case the @code{adainit} and
-@code{adafinal} procedures (@ref{b4,,Binding with Non-Ada Main Programs})
+@code{adafinal} procedures (@ref{a0,,Binding with Non-Ada Main Programs})
are renamed to @code{@emph{xxx}init} and
@code{@emph{xxx}final}.
Implies -n.
-(@ref{15,,GNAT and Libraries}, for more details.)
+(@ref{2a,,GNAT and Libraries}, for more details.)
@geindex -M (gnatbind)
@@ -16000,7 +15740,7 @@ Do not look for library files in the system default directory.
@item @code{--RTS=@emph{rts-path}}
Specifies the default location of the run-time library. Same meaning as the
-equivalent @code{gnatmake} flag (@ref{dc,,Switches for gnatmake}).
+equivalent @code{gnatmake} flag (@ref{cd,,Switches for gnatmake}).
@geindex -o (gnatbind)
@@ -16154,7 +15894,7 @@ Enable dynamic stack usage, with @code{n} results stored and displayed
at program termination. A result is generated when a task
terminates. Results that can't be stored are displayed on the fly, at
task termination. This option is currently not supported on Itanium
-platforms. (See @ref{122,,Dynamic Stack Usage Analysis} for details.)
+platforms. (See @ref{113,,Dynamic Stack Usage Analysis} for details.)
@geindex -v (gnatbind)
@@ -16189,6 +15929,14 @@ Override default wide character encoding for standard Text_IO files.
Exclude source files (check object consistency only).
+@geindex -xdr (gnatbind)
+
+@item @code{-xdr}
+
+Use the target-independent XDR protocol for stream oriented attributes
+instead of the default implementation which is based on direct binary
+representations and is therefore target-and endianness-dependent.
+
@geindex -Xnnn (gnatbind)
@item @code{-X@emph{nnn}}
@@ -16223,7 +15971,7 @@ no arguments.
@end menu
@node Consistency-Checking Modes,Binder Error Message Control,,Switches for gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat consistency-checking-modes}@anchor{123}@anchor{gnat_ugn/building_executable_programs_with_gnat id35}@anchor{124}
+@anchor{gnat_ugn/building_executable_programs_with_gnat consistency-checking-modes}@anchor{114}@anchor{gnat_ugn/building_executable_programs_with_gnat id35}@anchor{115}
@subsubsection Consistency-Checking Modes
@@ -16277,7 +16025,7 @@ case the checking against sources has already been performed by
@end table
@node Binder Error Message Control,Elaboration Control,Consistency-Checking Modes,Switches for gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat id36}@anchor{125}@anchor{gnat_ugn/building_executable_programs_with_gnat binder-error-message-control}@anchor{126}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id36}@anchor{116}@anchor{gnat_ugn/building_executable_programs_with_gnat binder-error-message-control}@anchor{117}
@subsubsection Binder Error Message Control
@@ -16387,7 +16135,7 @@ with extreme care.
@end table
@node Elaboration Control,Output Control,Binder Error Message Control,Switches for gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat id37}@anchor{127}@anchor{gnat_ugn/building_executable_programs_with_gnat elaboration-control}@anchor{120}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id37}@anchor{118}@anchor{gnat_ugn/building_executable_programs_with_gnat elaboration-control}@anchor{111}
@subsubsection Elaboration Control
@@ -16472,7 +16220,7 @@ debugging/experimental use.
@end table
@node Output Control,Dynamic Allocation Control,Elaboration Control,Switches for gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat output-control}@anchor{128}@anchor{gnat_ugn/building_executable_programs_with_gnat id38}@anchor{129}
+@anchor{gnat_ugn/building_executable_programs_with_gnat output-control}@anchor{119}@anchor{gnat_ugn/building_executable_programs_with_gnat id38}@anchor{11a}
@subsubsection Output Control
@@ -16553,7 +16301,7 @@ be used to improve code generation in some cases.
@end table
@node Dynamic Allocation Control,Binding with Non-Ada Main Programs,Output Control,Switches for gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat dynamic-allocation-control}@anchor{121}@anchor{gnat_ugn/building_executable_programs_with_gnat id39}@anchor{12a}
+@anchor{gnat_ugn/building_executable_programs_with_gnat dynamic-allocation-control}@anchor{112}@anchor{gnat_ugn/building_executable_programs_with_gnat id39}@anchor{11b}
@subsubsection Dynamic Allocation Control
@@ -16579,7 +16327,7 @@ unless explicitly overridden by a @code{'Size} clause on the access type.
These switches are only effective on VMS platforms.
@node Binding with Non-Ada Main Programs,Binding Programs with No Main Subprogram,Dynamic Allocation Control,Switches for gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat binding-with-non-ada-main-programs}@anchor{b4}@anchor{gnat_ugn/building_executable_programs_with_gnat id40}@anchor{12b}
+@anchor{gnat_ugn/building_executable_programs_with_gnat binding-with-non-ada-main-programs}@anchor{a0}@anchor{gnat_ugn/building_executable_programs_with_gnat id40}@anchor{11c}
@subsubsection Binding with Non-Ada Main Programs
@@ -16588,7 +16336,7 @@ program is in Ada, and that the task of the binder is to generate a
corresponding function @code{main} that invokes this Ada main
program. GNAT also supports the building of executable programs where
the main program is not in Ada, but some of the called routines are
-written in Ada and compiled using GNAT (@ref{44,,Mixed Language Programming}).
+written in Ada and compiled using GNAT (@ref{2c,,Mixed Language Programming}).
The following switch is used in this situation:
@quotation
@@ -16675,7 +16423,7 @@ side effect is that this could be the wrong mode for the foreign code
where floating point computation could be broken after this call.
@node Binding Programs with No Main Subprogram,,Binding with Non-Ada Main Programs,Switches for gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat binding-programs-with-no-main-subprogram}@anchor{12c}@anchor{gnat_ugn/building_executable_programs_with_gnat id41}@anchor{12d}
+@anchor{gnat_ugn/building_executable_programs_with_gnat binding-programs-with-no-main-subprogram}@anchor{11d}@anchor{gnat_ugn/building_executable_programs_with_gnat id41}@anchor{11e}
@subsubsection Binding Programs with No Main Subprogram
@@ -16706,7 +16454,7 @@ the binder switch
@end table
@node Command-Line Access,Search Paths for gnatbind,Switches for gnatbind,Binding with gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat id42}@anchor{12e}@anchor{gnat_ugn/building_executable_programs_with_gnat command-line-access}@anchor{12f}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id42}@anchor{11f}@anchor{gnat_ugn/building_executable_programs_with_gnat command-line-access}@anchor{120}
@subsection Command-Line Access
@@ -16736,7 +16484,7 @@ required, your main program must set @code{gnat_argc} and
it.
@node Search Paths for gnatbind,Examples of gnatbind Usage,Command-Line Access,Binding with gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-for-gnatbind}@anchor{8c}@anchor{gnat_ugn/building_executable_programs_with_gnat id43}@anchor{130}
+@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-for-gnatbind}@anchor{76}@anchor{gnat_ugn/building_executable_programs_with_gnat id43}@anchor{121}
@subsection Search Paths for @code{gnatbind}
@@ -16744,7 +16492,7 @@ The binder takes the name of an ALI file as its argument and needs to
locate source files as well as other ALI files to verify object consistency.
For source files, it follows exactly the same search rules as @code{gcc}
-(see @ref{89,,Search Paths and the Run-Time Library (RTL)}). For ALI files the
+(see @ref{73,,Search Paths and the Run-Time Library (RTL)}). For ALI files the
directories searched are:
@@ -16793,7 +16541,7 @@ of GNAT).
The content of the @code{ada_object_path} file which is part of the GNAT
installation tree and is used to store standard libraries such as the
GNAT Run-Time Library (RTL) unless the switch @code{-nostdlib} is
-specified. See @ref{87,,Installing a library}
+specified. See @ref{71,,Installing a library}
@end itemize
@geindex -I (gnatbind)
@@ -16840,7 +16588,7 @@ in compiling sources from multiple directories. This can make
development environments much more flexible.
@node Examples of gnatbind Usage,,Search Paths for gnatbind,Binding with gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat id44}@anchor{131}@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatbind-usage}@anchor{132}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id44}@anchor{122}@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatbind-usage}@anchor{123}
@subsection Examples of @code{gnatbind} Usage
@@ -16869,7 +16617,7 @@ since gnatlink will not be able to find the generated file.
@end quotation
@node Linking with gnatlink,Using the GNU make Utility,Binding with gnatbind,Building Executable Programs with GNAT
-@anchor{gnat_ugn/building_executable_programs_with_gnat id45}@anchor{133}@anchor{gnat_ugn/building_executable_programs_with_gnat linking-with-gnatlink}@anchor{1e}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id45}@anchor{124}@anchor{gnat_ugn/building_executable_programs_with_gnat linking-with-gnatlink}@anchor{c9}
@section Linking with @code{gnatlink}
@@ -16890,7 +16638,7 @@ generated by the @code{gnatbind} to determine this list.
@end menu
@node Running gnatlink,Switches for gnatlink,,Linking with gnatlink
-@anchor{gnat_ugn/building_executable_programs_with_gnat id46}@anchor{134}@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatlink}@anchor{135}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id46}@anchor{125}@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatlink}@anchor{126}
@subsection Running @code{gnatlink}
@@ -16949,8 +16697,8 @@ $ gnatlink my_prog -Wl,-Map,MAPFILE
Using @code{linker options} it is possible to set the program stack and
heap size.
-See @ref{136,,Setting Stack Size from gnatlink} and
-@ref{137,,Setting Heap Size from gnatlink}.
+See @ref{127,,Setting Stack Size from gnatlink} and
+@ref{128,,Setting Heap Size from gnatlink}.
@code{gnatlink} determines the list of objects required by the Ada
program and prepends them to the list of objects passed to the linker.
@@ -16959,7 +16707,7 @@ program and prepends them to the list of objects passed to the linker.
presented to the linker.
@node Switches for gnatlink,,Running gnatlink,Linking with gnatlink
-@anchor{gnat_ugn/building_executable_programs_with_gnat id47}@anchor{138}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatlink}@anchor{139}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id47}@anchor{129}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatlink}@anchor{12a}
@subsection Switches for @code{gnatlink}
@@ -17154,7 +16902,7 @@ switch.
@end table
@node Using the GNU make Utility,,Linking with gnatlink,Building Executable Programs with GNAT
-@anchor{gnat_ugn/building_executable_programs_with_gnat using-the-gnu-make-utility}@anchor{1f}@anchor{gnat_ugn/building_executable_programs_with_gnat id48}@anchor{13a}
+@anchor{gnat_ugn/building_executable_programs_with_gnat using-the-gnu-make-utility}@anchor{70}@anchor{gnat_ugn/building_executable_programs_with_gnat id48}@anchor{12b}
@section Using the GNU @code{make} Utility
@@ -17163,7 +16911,7 @@ switch.
This chapter offers some examples of makefiles that solve specific
problems. It does not explain how to write a makefile, nor does it try to replace the
-@code{gnatmake} utility (@ref{1b,,Building with gnatmake}).
+@code{gnatmake} utility (@ref{c6,,Building with gnatmake}).
All the examples in this section are specific to the GNU version of
make. Although @code{make} is a standard utility, and the basic language
@@ -17179,7 +16927,7 @@ is the same, these examples use some advanced features found only in
@end menu
@node Using gnatmake in a Makefile,Automatically Creating a List of Directories,,Using the GNU make Utility
-@anchor{gnat_ugn/building_executable_programs_with_gnat using-gnatmake-in-a-makefile}@anchor{13b}@anchor{gnat_ugn/building_executable_programs_with_gnat id49}@anchor{13c}
+@anchor{gnat_ugn/building_executable_programs_with_gnat using-gnatmake-in-a-makefile}@anchor{12c}@anchor{gnat_ugn/building_executable_programs_with_gnat id49}@anchor{12d}
@subsection Using gnatmake in a Makefile
@@ -17198,7 +16946,7 @@ the appropriate directories.
Note that you should also read the example on how to automatically
create the list of directories
-(@ref{13d,,Automatically Creating a List of Directories})
+(@ref{12e,,Automatically Creating a List of Directories})
which might help you in case your project has a lot of subdirectories.
@example
@@ -17278,7 +17026,7 @@ clean::
@end example
@node Automatically Creating a List of Directories,Generating the Command Line Switches,Using gnatmake in a Makefile,Using the GNU make Utility
-@anchor{gnat_ugn/building_executable_programs_with_gnat id50}@anchor{13e}@anchor{gnat_ugn/building_executable_programs_with_gnat automatically-creating-a-list-of-directories}@anchor{13d}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id50}@anchor{12f}@anchor{gnat_ugn/building_executable_programs_with_gnat automatically-creating-a-list-of-directories}@anchor{12e}
@subsection Automatically Creating a List of Directories
@@ -17351,12 +17099,12 @@ DIRS := $@{shell find $@{ROOT_DIRECTORY@} -type d -print@}
@end example
@node Generating the Command Line Switches,Overcoming Command Line Length Limits,Automatically Creating a List of Directories,Using the GNU make Utility
-@anchor{gnat_ugn/building_executable_programs_with_gnat id51}@anchor{13f}@anchor{gnat_ugn/building_executable_programs_with_gnat generating-the-command-line-switches}@anchor{140}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id51}@anchor{130}@anchor{gnat_ugn/building_executable_programs_with_gnat generating-the-command-line-switches}@anchor{131}
@subsection Generating the Command Line Switches
Once you have created the list of directories as explained in the
-previous section (@ref{13d,,Automatically Creating a List of Directories}),
+previous section (@ref{12e,,Automatically Creating a List of Directories}),
you can easily generate the command line arguments to pass to gnatmake.
For the sake of completeness, this example assumes that the source path
@@ -17377,7 +17125,7 @@ all:
@end example
@node Overcoming Command Line Length Limits,,Generating the Command Line Switches,Using the GNU make Utility
-@anchor{gnat_ugn/building_executable_programs_with_gnat overcoming-command-line-length-limits}@anchor{141}@anchor{gnat_ugn/building_executable_programs_with_gnat id52}@anchor{142}
+@anchor{gnat_ugn/building_executable_programs_with_gnat overcoming-command-line-length-limits}@anchor{132}@anchor{gnat_ugn/building_executable_programs_with_gnat id52}@anchor{133}
@subsection Overcoming Command Line Length Limits
@@ -17392,7 +17140,7 @@ even none on most systems).
It assumes that you have created a list of directories in your Makefile,
using one of the methods presented in
-@ref{13d,,Automatically Creating a List of Directories}.
+@ref{12e,,Automatically Creating a List of Directories}.
For the sake of completeness, we assume that the object
path (where the ALI files are found) is different from the sources patch.
@@ -17435,7 +17183,7 @@ all:
@end example
@node GNAT Utility Programs,GNAT and Program Execution,Building Executable Programs with GNAT,Top
-@anchor{gnat_ugn/gnat_utility_programs doc}@anchor{143}@anchor{gnat_ugn/gnat_utility_programs gnat-utility-programs}@anchor{b}@anchor{gnat_ugn/gnat_utility_programs id1}@anchor{144}
+@anchor{gnat_ugn/gnat_utility_programs doc}@anchor{134}@anchor{gnat_ugn/gnat_utility_programs gnat-utility-programs}@anchor{b}@anchor{gnat_ugn/gnat_utility_programs id1}@anchor{135}
@chapter GNAT Utility Programs
@@ -17446,16 +17194,10 @@ This chapter describes a number of utility programs:
@itemize *
@item
-@ref{20,,The File Cleanup Utility gnatclean}
+@ref{136,,The File Cleanup Utility gnatclean}
@item
-@ref{21,,The GNAT Library Browser gnatls}
-
-@item
-@ref{22,,The Cross-Referencing Tools gnatxref and gnatfind}
-
-@item
-@ref{23,,The Ada to HTML Converter gnathtml}
+@ref{137,,The GNAT Library Browser gnatls}
@end itemize
Other GNAT utilities are described elsewhere in this manual:
@@ -17464,28 +17206,26 @@ Other GNAT utilities are described elsewhere in this manual:
@itemize *
@item
-@ref{59,,Handling Arbitrary File Naming Conventions with gnatname}
+@ref{42,,Handling Arbitrary File Naming Conventions with gnatname}
@item
-@ref{63,,File Name Krunching with gnatkr}
+@ref{4c,,File Name Krunching with gnatkr}
@item
-@ref{36,,Renaming Files with gnatchop}
+@ref{1d,,Renaming Files with gnatchop}
@item
-@ref{17,,Preprocessing with gnatprep}
+@ref{8f,,Preprocessing with gnatprep}
@end itemize
@menu
* The File Cleanup Utility gnatclean::
* The GNAT Library Browser gnatls::
-* The Cross-Referencing Tools gnatxref and gnatfind::
-* The Ada to HTML Converter gnathtml::
@end menu
@node The File Cleanup Utility gnatclean,The GNAT Library Browser gnatls,,GNAT Utility Programs
-@anchor{gnat_ugn/gnat_utility_programs id2}@anchor{145}@anchor{gnat_ugn/gnat_utility_programs the-file-cleanup-utility-gnatclean}@anchor{20}
+@anchor{gnat_ugn/gnat_utility_programs id2}@anchor{138}@anchor{gnat_ugn/gnat_utility_programs the-file-cleanup-utility-gnatclean}@anchor{136}
@section The File Cleanup Utility @code{gnatclean}
@@ -17505,7 +17245,7 @@ generated files and executable files.
@end menu
@node Running gnatclean,Switches for gnatclean,,The File Cleanup Utility gnatclean
-@anchor{gnat_ugn/gnat_utility_programs running-gnatclean}@anchor{146}@anchor{gnat_ugn/gnat_utility_programs id3}@anchor{147}
+@anchor{gnat_ugn/gnat_utility_programs running-gnatclean}@anchor{139}@anchor{gnat_ugn/gnat_utility_programs id3}@anchor{13a}
@subsection Running @code{gnatclean}
@@ -17529,7 +17269,7 @@ the linker. In informative-only mode, specified by switch
normal mode is listed, but no file is actually deleted.
@node Switches for gnatclean,,Running gnatclean,The File Cleanup Utility gnatclean
-@anchor{gnat_ugn/gnat_utility_programs id4}@anchor{148}@anchor{gnat_ugn/gnat_utility_programs switches-for-gnatclean}@anchor{149}
+@anchor{gnat_ugn/gnat_utility_programs id4}@anchor{13b}@anchor{gnat_ugn/gnat_utility_programs switches-for-gnatclean}@anchor{13c}
@subsection Switches for @code{gnatclean}
@@ -17680,7 +17420,7 @@ Verbose mode.
@item @code{-vP@emph{x}}
Indicates the verbosity of the parsing of GNAT project files.
-@ref{de,,Switches Related to Project Files}.
+@ref{cf,,Switches Related to Project Files}.
@end table
@geindex -X (gnatclean)
@@ -17693,7 +17433,7 @@ Indicates the verbosity of the parsing of GNAT project files.
Indicates that external variable @code{name} has the value @code{value}.
The Project Manager will use this value for occurrences of
@code{external(name)} when parsing the project file.
-See @ref{de,,Switches Related to Project Files}.
+See @ref{cf,,Switches Related to Project Files}.
@end table
@geindex -aO (gnatclean)
@@ -17730,8 +17470,8 @@ Do not look for ALI or object files in the directory
where @code{gnatclean} was invoked.
@end table
-@node The GNAT Library Browser gnatls,The Cross-Referencing Tools gnatxref and gnatfind,The File Cleanup Utility gnatclean,GNAT Utility Programs
-@anchor{gnat_ugn/gnat_utility_programs the-gnat-library-browser-gnatls}@anchor{21}@anchor{gnat_ugn/gnat_utility_programs id5}@anchor{14a}
+@node The GNAT Library Browser gnatls,,The File Cleanup Utility gnatclean,GNAT Utility Programs
+@anchor{gnat_ugn/gnat_utility_programs the-gnat-library-browser-gnatls}@anchor{137}@anchor{gnat_ugn/gnat_utility_programs id5}@anchor{13d}
@section The GNAT Library Browser @code{gnatls}
@@ -17752,7 +17492,7 @@ as well as various characteristics.
@end menu
@node Running gnatls,Switches for gnatls,,The GNAT Library Browser gnatls
-@anchor{gnat_ugn/gnat_utility_programs id6}@anchor{14b}@anchor{gnat_ugn/gnat_utility_programs running-gnatls}@anchor{14c}
+@anchor{gnat_ugn/gnat_utility_programs id6}@anchor{13e}@anchor{gnat_ugn/gnat_utility_programs running-gnatls}@anchor{13f}
@subsection Running @code{gnatls}
@@ -17766,7 +17506,7 @@ $ gnatls switches object_or_ali_file
@end quotation
The main argument is the list of object or @code{ali} files
-(see @ref{42,,The Ada Library Information Files})
+(see @ref{28,,The Ada Library Information Files})
for which information is requested.
In normal mode, without additional option, @code{gnatls} produces a
@@ -17832,7 +17572,7 @@ version of the same source that has been modified.
@end table
@node Switches for gnatls,Example of gnatls Usage,Running gnatls,The GNAT Library Browser gnatls
-@anchor{gnat_ugn/gnat_utility_programs id7}@anchor{14d}@anchor{gnat_ugn/gnat_utility_programs switches-for-gnatls}@anchor{14e}
+@anchor{gnat_ugn/gnat_utility_programs id7}@anchor{140}@anchor{gnat_ugn/gnat_utility_programs switches-for-gnatls}@anchor{141}
@subsection Switches for @code{gnatls}
@@ -17947,7 +17687,7 @@ Several such switches may be specified simultaneously.
@item @code{-aO@emph{dir}}, @code{-aI@emph{dir}}, @code{-I@emph{dir}}, @code{-I-}, @code{-nostdinc}
Source path manipulation. Same meaning as the equivalent @code{gnatmake}
-flags (@ref{dc,,Switches for gnatmake}).
+flags (@ref{cd,,Switches for gnatmake}).
@end table
@geindex -aP (gnatls)
@@ -17968,7 +17708,7 @@ Add @code{dir} at the beginning of the project search dir.
@item @code{--RTS=@emph{rts-path}}
Specifies the default location of the runtime library. Same meaning as the
-equivalent @code{gnatmake} flag (@ref{dc,,Switches for gnatmake}).
+equivalent @code{gnatmake} flag (@ref{cd,,Switches for gnatmake}).
@end table
@geindex -v (gnatls)
@@ -18014,7 +17754,7 @@ by the user.
@end table
@node Example of gnatls Usage,,Switches for gnatls,The GNAT Library Browser gnatls
-@anchor{gnat_ugn/gnat_utility_programs id8}@anchor{14f}@anchor{gnat_ugn/gnat_utility_programs example-of-gnatls-usage}@anchor{150}
+@anchor{gnat_ugn/gnat_utility_programs id8}@anchor{142}@anchor{gnat_ugn/gnat_utility_programs example-of-gnatls-usage}@anchor{143}
@subsection Example of @code{gnatls} Usage
@@ -18093,1140 +17833,6 @@ instr.ads
@end example
@end quotation
-@node The Cross-Referencing Tools gnatxref and gnatfind,The Ada to HTML Converter gnathtml,The GNAT Library Browser gnatls,GNAT Utility Programs
-@anchor{gnat_ugn/gnat_utility_programs the-cross-referencing-tools-gnatxref-and-gnatfind}@anchor{22}@anchor{gnat_ugn/gnat_utility_programs id9}@anchor{151}
-@section The Cross-Referencing Tools @code{gnatxref} and @code{gnatfind}
-
-
-@geindex gnatxref
-
-@geindex gnatfind
-
-The compiler generates cross-referencing information (unless
-you set the @code{-gnatx} switch), which are saved in the @code{.ali} files.
-This information indicates where in the source each entity is declared and
-referenced. Note that entities in package Standard are not included, but
-entities in all other predefined units are included in the output.
-
-Before using any of these two tools, you need to compile successfully your
-application, so that GNAT gets a chance to generate the cross-referencing
-information.
-
-The two tools @code{gnatxref} and @code{gnatfind} take advantage of this
-information to provide the user with the capability to easily locate the
-declaration and references to an entity. These tools are quite similar,
-the difference being that @code{gnatfind} is intended for locating
-definitions and/or references to a specified entity or entities, whereas
-@code{gnatxref} is oriented to generating a full report of all
-cross-references.
-
-To use these tools, you must not compile your application using the
-@code{-gnatx} switch on the @code{gnatmake} command line
-(see @ref{1b,,Building with gnatmake}). Otherwise, cross-referencing
-information will not be generated.
-
-@menu
-* gnatxref Switches::
-* gnatfind Switches::
-* Configuration Files for gnatxref and gnatfind::
-* Regular Expressions in gnatfind and gnatxref::
-* Examples of gnatxref Usage::
-* Examples of gnatfind Usage::
-
-@end menu
-
-@node gnatxref Switches,gnatfind Switches,,The Cross-Referencing Tools gnatxref and gnatfind
-@anchor{gnat_ugn/gnat_utility_programs id10}@anchor{152}@anchor{gnat_ugn/gnat_utility_programs gnatxref-switches}@anchor{153}
-@subsection @code{gnatxref} Switches
-
-
-The command invocation for @code{gnatxref} is:
-
-@quotation
-
-@example
-$ gnatxref [ switches ] sourcefile1 [ sourcefile2 ... ]
-@end example
-@end quotation
-
-where
-
-
-@table @asis
-
-@item @code{sourcefile1} [, @code{sourcefile2} ...]
-
-identify the source files for which a report is to be generated. The
-@code{with}ed units will be processed too. You must provide at least one file.
-
-These file names are considered to be regular expressions, so for instance
-specifying @code{source*.adb} is the same as giving every file in the current
-directory whose name starts with @code{source} and whose extension is
-@code{adb}.
-
-You shouldn't specify any directory name, just base names. @code{gnatxref}
-and @code{gnatfind} will be able to locate these files by themselves using
-the source path. If you specify directories, no result is produced.
-@end table
-
-The following switches are available for @code{gnatxref}:
-
-@geindex --version (gnatxref)
-
-
-@table @asis
-
-@item @code{--version}
-
-Display copyright and version, then exit disregarding all other options.
-@end table
-
-@geindex --help (gnatxref)
-
-
-@table @asis
-
-@item @code{--help}
-
-If @code{--version} was not used, display usage, then exit disregarding
-all other options.
-@end table
-
-@geindex -a (gnatxref)
-
-
-@table @asis
-
-@item @code{-a}
-
-If this switch is present, @code{gnatfind} and @code{gnatxref} will parse
-the read-only files found in the library search path. Otherwise, these files
-will be ignored. This option can be used to protect Gnat sources or your own
-libraries from being parsed, thus making @code{gnatfind} and @code{gnatxref}
-much faster, and their output much smaller. Read-only here refers to access
-or permissions status in the file system for the current user.
-@end table
-
-@geindex -aIDIR (gnatxref)
-
-
-@table @asis
-
-@item @code{-aI@emph{DIR}}
-
-When looking for source files also look in directory DIR. The order in which
-source file search is undertaken is the same as for @code{gnatmake}.
-@end table
-
-@geindex -aODIR (gnatxref)
-
-
-@table @asis
-
-@item @code{aO@emph{DIR}}
-
-When -searching for library and object files, look in directory
-DIR. The order in which library files are searched is the same as for
-@code{gnatmake}.
-@end table
-
-@geindex -nostdinc (gnatxref)
-
-
-@table @asis
-
-@item @code{-nostdinc}
-
-Do not look for sources in the system default directory.
-@end table
-
-@geindex -nostdlib (gnatxref)
-
-
-@table @asis
-
-@item @code{-nostdlib}
-
-Do not look for library files in the system default directory.
-@end table
-
-@geindex --ext (gnatxref)
-
-
-@table @asis
-
-@item @code{--ext=@emph{extension}}
-
-Specify an alternate ali file extension. The default is @code{ali} and other
-extensions (e.g. @code{gli} for C/C++ sources) may be specified via this switch.
-Note that if this switch overrides the default, only the new extension will
-be considered.
-@end table
-
-@geindex --RTS (gnatxref)
-
-
-@table @asis
-
-@item @code{--RTS=@emph{rts-path}}
-
-Specifies the default location of the runtime library. Same meaning as the
-equivalent @code{gnatmake} flag (@ref{dc,,Switches for gnatmake}).
-@end table
-
-@geindex -d (gnatxref)
-
-
-@table @asis
-
-@item @code{-d}
-
-If this switch is set @code{gnatxref} will output the parent type
-reference for each matching derived types.
-@end table
-
-@geindex -f (gnatxref)
-
-
-@table @asis
-
-@item @code{-f}
-
-If this switch is set, the output file names will be preceded by their
-directory (if the file was found in the search path). If this switch is
-not set, the directory will not be printed.
-@end table
-
-@geindex -g (gnatxref)
-
-
-@table @asis
-
-@item @code{-g}
-
-If this switch is set, information is output only for library-level
-entities, ignoring local entities. The use of this switch may accelerate
-@code{gnatfind} and @code{gnatxref}.
-@end table
-
-@geindex -IDIR (gnatxref)
-
-
-@table @asis
-
-@item @code{-I@emph{DIR}}
-
-Equivalent to @code{-aODIR -aIDIR}.
-@end table
-
-@geindex -pFILE (gnatxref)
-
-
-@table @asis
-
-@item @code{-p@emph{FILE}}
-
-Specify a configuration file to use to list the source and object directories.
-
-If a file is specified, then the content of the source directory and object
-directory lines are added as if they had been specified respectively
-by @code{-aI} and @code{-aO}.
-
-See @ref{154,,Configuration Files for gnatxref and gnatfind} for the syntax
-of this configuration file.
-
-@item @code{-u}
-
-Output only unused symbols. This may be really useful if you give your
-main compilation unit on the command line, as @code{gnatxref} will then
-display every unused entity and 'with'ed package.
-
-@item @code{-v}
-
-Instead of producing the default output, @code{gnatxref} will generate a
-@code{tags} file that can be used by vi. For examples how to use this
-feature, see @ref{155,,Examples of gnatxref Usage}. The tags file is output
-to the standard output, thus you will have to redirect it to a file.
-@end table
-
-All these switches may be in any order on the command line, and may even
-appear after the file names. They need not be separated by spaces, thus
-you can say @code{gnatxref -ag} instead of @code{gnatxref -a -g}.
-
-@node gnatfind Switches,Configuration Files for gnatxref and gnatfind,gnatxref Switches,The Cross-Referencing Tools gnatxref and gnatfind
-@anchor{gnat_ugn/gnat_utility_programs id11}@anchor{156}@anchor{gnat_ugn/gnat_utility_programs gnatfind-switches}@anchor{157}
-@subsection @code{gnatfind} Switches
-
-
-The command invocation for @code{gnatfind} is:
-
-@quotation
-
-@example
-$ gnatfind [ switches ] pattern[:sourcefile[:line[:column]]]
- [file1 file2 ...]
-@end example
-@end quotation
-
-with the following iterpretation of the command arguments:
-
-
-@table @asis
-
-@item @emph{pattern}
-
-An entity will be output only if it matches the regular expression found
-in @emph{pattern}, see @ref{158,,Regular Expressions in gnatfind and gnatxref}.
-
-Omitting the pattern is equivalent to specifying @code{*}, which
-will match any entity. Note that if you do not provide a pattern, you
-have to provide both a sourcefile and a line.
-
-Entity names are given in Latin-1, with uppercase/lowercase equivalence
-for matching purposes. At the current time there is no support for
-8-bit codes other than Latin-1, or for wide characters in identifiers.
-
-@item @emph{sourcefile}
-
-@code{gnatfind} will look for references, bodies or declarations
-of symbols referenced in @code{sourcefile}, at line @code{line}
-and column @code{column}. See @ref{159,,Examples of gnatfind Usage}
-for syntax examples.
-
-@item @emph{line}
-
-A decimal integer identifying the line number containing
-the reference to the entity (or entities) to be located.
-
-@item @emph{column}
-
-A decimal integer identifying the exact location on the
-line of the first character of the identifier for the
-entity reference. Columns are numbered from 1.
-
-@item @emph{file1 file2 ...}
-
-The search will be restricted to these source files. If none are given, then
-the search will be conducted for every library file in the search path.
-These files must appear only after the pattern or sourcefile.
-
-These file names are considered to be regular expressions, so for instance
-specifying @code{source*.adb} is the same as giving every file in the current
-directory whose name starts with @code{source} and whose extension is
-@code{adb}.
-
-The location of the spec of the entity will always be displayed, even if it
-isn't in one of @code{file1}, @code{file2}, ... The
-occurrences of the entity in the separate units of the ones given on the
-command line will also be displayed.
-
-Note that if you specify at least one file in this part, @code{gnatfind} may
-sometimes not be able to find the body of the subprograms.
-@end table
-
-At least one of 'sourcefile' or 'pattern' has to be present on
-the command line.
-
-The following switches are available:
-
-@geindex --version (gnatfind)
-
-
-@table @asis
-
-@item @code{--version}
-
-Display copyright and version, then exit disregarding all other options.
-@end table
-
-@geindex --help (gnatfind)
-
-
-@table @asis
-
-@item @code{--help}
-
-If @code{--version} was not used, display usage, then exit disregarding
-all other options.
-@end table
-
-@geindex -a (gnatfind)
-
-
-@table @asis
-
-@item @code{-a}
-
-If this switch is present, @code{gnatfind} and @code{gnatxref} will parse
-the read-only files found in the library search path. Otherwise, these files
-will be ignored. This option can be used to protect Gnat sources or your own
-libraries from being parsed, thus making @code{gnatfind} and @code{gnatxref}
-much faster, and their output much smaller. Read-only here refers to access
-or permission status in the file system for the current user.
-@end table
-
-@geindex -aIDIR (gnatfind)
-
-
-@table @asis
-
-@item @code{-aI@emph{DIR}}
-
-When looking for source files also look in directory DIR. The order in which
-source file search is undertaken is the same as for @code{gnatmake}.
-@end table
-
-@geindex -aODIR (gnatfind)
-
-
-@table @asis
-
-@item @code{-aO@emph{DIR}}
-
-When searching for library and object files, look in directory
-DIR. The order in which library files are searched is the same as for
-@code{gnatmake}.
-@end table
-
-@geindex -nostdinc (gnatfind)
-
-
-@table @asis
-
-@item @code{-nostdinc}
-
-Do not look for sources in the system default directory.
-@end table
-
-@geindex -nostdlib (gnatfind)
-
-
-@table @asis
-
-@item @code{-nostdlib}
-
-Do not look for library files in the system default directory.
-@end table
-
-@geindex --ext (gnatfind)
-
-
-@table @asis
-
-@item @code{--ext=@emph{extension}}
-
-Specify an alternate ali file extension. The default is @code{ali} and other
-extensions may be specified via this switch. Note that if this switch
-overrides the default, only the new extension will be considered.
-@end table
-
-@geindex --RTS (gnatfind)
-
-
-@table @asis
-
-@item @code{--RTS=@emph{rts-path}}
-
-Specifies the default location of the runtime library. Same meaning as the
-equivalent @code{gnatmake} flag (@ref{dc,,Switches for gnatmake}).
-@end table
-
-@geindex -d (gnatfind)
-
-
-@table @asis
-
-@item @code{-d}
-
-If this switch is set, then @code{gnatfind} will output the parent type
-reference for each matching derived types.
-@end table
-
-@geindex -e (gnatfind)
-
-
-@table @asis
-
-@item @code{-e}
-
-By default, @code{gnatfind} accept the simple regular expression set for
-@code{pattern}. If this switch is set, then the pattern will be
-considered as full Unix-style regular expression.
-@end table
-
-@geindex -f (gnatfind)
-
-
-@table @asis
-
-@item @code{-f}
-
-If this switch is set, the output file names will be preceded by their
-directory (if the file was found in the search path). If this switch is
-not set, the directory will not be printed.
-@end table
-
-@geindex -g (gnatfind)
-
-
-@table @asis
-
-@item @code{-g}
-
-If this switch is set, information is output only for library-level
-entities, ignoring local entities. The use of this switch may accelerate
-@code{gnatfind} and @code{gnatxref}.
-@end table
-
-@geindex -IDIR (gnatfind)
-
-
-@table @asis
-
-@item @code{-I@emph{DIR}}
-
-Equivalent to @code{-aODIR -aIDIR}.
-@end table
-
-@geindex -pFILE (gnatfind)
-
-
-@table @asis
-
-@item @code{-p@emph{FILE}}
-
-Specify a configuration file to use to list the source and object directories.
-
-If a file is specified, then the content of the source directory and object
-directory lines are added as if they had been specified respectively
-by @code{-aI} and @code{-aO}.
-
-See @ref{154,,Configuration Files for gnatxref and gnatfind} for the syntax
-of this configuration file.
-@end table
-
-@geindex -r (gnatfind)
-
-
-@table @asis
-
-@item @code{-r}
-
-By default, @code{gnatfind} will output only the information about the
-declaration, body or type completion of the entities. If this switch is
-set, the @code{gnatfind} will locate every reference to the entities in
-the files specified on the command line (or in every file in the search
-path if no file is given on the command line).
-@end table
-
-@geindex -s (gnatfind)
-
-
-@table @asis
-
-@item @code{-s}
-
-If this switch is set, then @code{gnatfind} will output the content
-of the Ada source file lines were the entity was found.
-@end table
-
-@geindex -t (gnatfind)
-
-
-@table @asis
-
-@item @code{-t}
-
-If this switch is set, then @code{gnatfind} will output the type hierarchy for
-the specified type. It act like -d option but recursively from parent
-type to parent type. When this switch is set it is not possible to
-specify more than one file.
-@end table
-
-All these switches may be in any order on the command line, and may even
-appear after the file names. They need not be separated by spaces, thus
-you can say @code{gnatxref -ag} instead of
-@code{gnatxref -a -g}.
-
-As stated previously, @code{gnatfind} will search in every directory in the
-search path. You can force it to look only in the current directory if
-you specify @code{*} at the end of the command line.
-
-@node Configuration Files for gnatxref and gnatfind,Regular Expressions in gnatfind and gnatxref,gnatfind Switches,The Cross-Referencing Tools gnatxref and gnatfind
-@anchor{gnat_ugn/gnat_utility_programs configuration-files-for-gnatxref-and-gnatfind}@anchor{154}@anchor{gnat_ugn/gnat_utility_programs id12}@anchor{15a}
-@subsection Configuration Files for @code{gnatxref} and @code{gnatfind}
-
-
-Configuration files are used by @code{gnatxref} and @code{gnatfind} to specify
-the list of source and object directories to consider. They can be
-specified via the @code{-p} switch.
-
-The following lines can be included, in any order in the file:
-
-
-@itemize *
-
-@item
-
-@table @asis
-
-@item @emph{src_dir=DIR}
-
-[default: @code{"./"}].
-Specifies a directory where to look for source files. Multiple @code{src_dir}
-lines can be specified and they will be searched in the order they
-are specified.
-@end table
-
-@item
-
-@table @asis
-
-@item @emph{obj_dir=DIR}
-
-[default: @code{"./"}].
-Specifies a directory where to look for object and library files. Multiple
-@code{obj_dir} lines can be specified, and they will be searched in the order
-they are specified
-@end table
-@end itemize
-
-Any other line will be silently ignored.
-
-@node Regular Expressions in gnatfind and gnatxref,Examples of gnatxref Usage,Configuration Files for gnatxref and gnatfind,The Cross-Referencing Tools gnatxref and gnatfind
-@anchor{gnat_ugn/gnat_utility_programs id13}@anchor{15b}@anchor{gnat_ugn/gnat_utility_programs regular-expressions-in-gnatfind-and-gnatxref}@anchor{158}
-@subsection Regular Expressions in @code{gnatfind} and @code{gnatxref}
-
-
-As specified in the section about @code{gnatfind}, the pattern can be a
-regular expression. Two kinds of regular expressions
-are recognized:
-
-
-@itemize *
-
-@item
-
-@table @asis
-
-@item @emph{Globbing pattern}
-
-These are the most common regular expression. They are the same as are
-generally used in a Unix shell command line, or in a DOS session.
-
-Here is a more formal grammar:
-
-@example
-regexp ::= term
-term ::= elmt -- matches elmt
-term ::= elmt elmt -- concatenation (elmt then elmt)
-term ::= * -- any string of 0 or more characters
-term ::= ? -- matches any character
-term ::= [char @{char@}] -- matches any character listed
-term ::= [char - char] -- matches any character in range
-@end example
-@end table
-
-@item
-
-@table @asis
-
-@item @emph{Full regular expression}
-
-The second set of regular expressions is much more powerful. This is the
-type of regular expressions recognized by utilities such as @code{grep}.
-
-The following is the form of a regular expression, expressed in same BNF
-style as is found in the Ada Reference Manual:
-
-@example
-regexp ::= term @{| term@} -- alternation (term or term ...)
-
-term ::= item @{item@} -- concatenation (item then item)
-
-item ::= elmt -- match elmt
-item ::= elmt * -- zero or more elmt's
-item ::= elmt + -- one or more elmt's
-item ::= elmt ? -- matches elmt or nothing
-
-elmt ::= nschar -- matches given character
-elmt ::= [nschar @{nschar@}] -- matches any character listed
-elmt ::= [^ nschar @{nschar@}] -- matches any character not listed
-elmt ::= [char - char] -- matches chars in given range
-elmt ::= \\ char -- matches given character
-elmt ::= . -- matches any single character
-elmt ::= ( regexp ) -- parens used for grouping
-
-char ::= any character, including special characters
-nschar ::= any character except ()[].*+?^
-@end example
-
-Here are a few examples:
-
-@quotation
-
-
-@table @asis
-
-@item @code{abcde|fghi}
-
-will match any of the two strings @code{abcde} and @code{fghi},
-
-@item @code{abc*d}
-
-will match any string like @code{abd}, @code{abcd}, @code{abccd},
-@code{abcccd}, and so on,
-
-@item @code{[a-z]+}
-
-will match any string which has only lowercase characters in it (and at
-least one character.
-@end table
-@end quotation
-@end table
-@end itemize
-
-@node Examples of gnatxref Usage,Examples of gnatfind Usage,Regular Expressions in gnatfind and gnatxref,The Cross-Referencing Tools gnatxref and gnatfind
-@anchor{gnat_ugn/gnat_utility_programs examples-of-gnatxref-usage}@anchor{155}@anchor{gnat_ugn/gnat_utility_programs id14}@anchor{15c}
-@subsection Examples of @code{gnatxref} Usage
-
-
-@menu
-* General Usage::
-* Using gnatxref with vi::
-
-@end menu
-
-@node General Usage,Using gnatxref with vi,,Examples of gnatxref Usage
-@anchor{gnat_ugn/gnat_utility_programs general-usage}@anchor{15d}
-@subsubsection General Usage
-
-
-For the following examples, we will consider the following units:
-
-@quotation
-
-@example
-main.ads:
-1: with Bar;
-2: package Main is
-3: procedure Foo (B : in Integer);
-4: C : Integer;
-5: private
-6: D : Integer;
-7: end Main;
-
-main.adb:
-1: package body Main is
-2: procedure Foo (B : in Integer) is
-3: begin
-4: C := B;
-5: D := B;
-6: Bar.Print (B);
-7: Bar.Print (C);
-8: end Foo;
-9: end Main;
-
-bar.ads:
-1: package Bar is
-2: procedure Print (B : Integer);
-3: end bar;
-@end example
-@end quotation
-
-The first thing to do is to recompile your application (for instance, in
-that case just by doing a @code{gnatmake main}, so that GNAT generates
-the cross-referencing information.
-You can then issue any of the following commands:
-
-@quotation
-
-
-@itemize *
-
-@item
-@code{gnatxref main.adb}
-@code{gnatxref} generates cross-reference information for main.adb
-and every unit 'with'ed by main.adb.
-
-The output would be:
-
-@quotation
-
-@example
-B Type: Integer
- Decl: bar.ads 2:22
-B Type: Integer
- Decl: main.ads 3:20
- Body: main.adb 2:20
- Ref: main.adb 4:13 5:13 6:19
-Bar Type: Unit
- Decl: bar.ads 1:9
- Ref: main.adb 6:8 7:8
- main.ads 1:6
-C Type: Integer
- Decl: main.ads 4:5
- Modi: main.adb 4:8
- Ref: main.adb 7:19
-D Type: Integer
- Decl: main.ads 6:5
- Modi: main.adb 5:8
-Foo Type: Unit
- Decl: main.ads 3:15
- Body: main.adb 2:15
-Main Type: Unit
- Decl: main.ads 2:9
- Body: main.adb 1:14
-Print Type: Unit
- Decl: bar.ads 2:15
- Ref: main.adb 6:12 7:12
-@end example
-@end quotation
-
-This shows that the entity @code{Main} is declared in main.ads, line 2, column 9,
-its body is in main.adb, line 1, column 14 and is not referenced any where.
-
-The entity @code{Print} is declared in @code{bar.ads}, line 2, column 15 and it
-is referenced in @code{main.adb}, line 6 column 12 and line 7 column 12.
-
-@item
-@code{gnatxref package1.adb package2.ads}
-@code{gnatxref} will generates cross-reference information for
-@code{package1.adb}, @code{package2.ads} and any other package @code{with}ed by any
-of these.
-@end itemize
-@end quotation
-
-@node Using gnatxref with vi,,General Usage,Examples of gnatxref Usage
-@anchor{gnat_ugn/gnat_utility_programs using-gnatxref-with-vi}@anchor{15e}
-@subsubsection Using @code{gnatxref} with @code{vi}
-
-
-@code{gnatxref} can generate a tags file output, which can be used
-directly from @code{vi}. Note that the standard version of @code{vi}
-will not work properly with overloaded symbols. Consider using another
-free implementation of @code{vi}, such as @code{vim}.
-
-@quotation
-
-@example
-$ gnatxref -v gnatfind.adb > tags
-@end example
-@end quotation
-
-The following command will generate the tags file for @code{gnatfind} itself
-(if the sources are in the search path!):
-
-@quotation
-
-@example
-$ gnatxref -v gnatfind.adb > tags
-@end example
-@end quotation
-
-From @code{vi}, you can then use the command @code{:tag @emph{entity}}
-(replacing @code{entity} by whatever you are looking for), and vi will
-display a new file with the corresponding declaration of entity.
-
-@node Examples of gnatfind Usage,,Examples of gnatxref Usage,The Cross-Referencing Tools gnatxref and gnatfind
-@anchor{gnat_ugn/gnat_utility_programs id15}@anchor{15f}@anchor{gnat_ugn/gnat_utility_programs examples-of-gnatfind-usage}@anchor{159}
-@subsection Examples of @code{gnatfind} Usage
-
-
-
-@itemize *
-
-@item
-@code{gnatfind -f xyz:main.adb}
-Find declarations for all entities xyz referenced at least once in
-main.adb. The references are search in every library file in the search
-path.
-
-The directories will be printed as well (as the @code{-f}
-switch is set)
-
-The output will look like:
-
-@quotation
-
-@example
-directory/main.ads:106:14: xyz <= declaration
-directory/main.adb:24:10: xyz <= body
-directory/foo.ads:45:23: xyz <= declaration
-@end example
-@end quotation
-
-I.e., one of the entities xyz found in main.adb is declared at
-line 12 of main.ads (and its body is in main.adb), and another one is
-declared at line 45 of foo.ads
-
-@item
-@code{gnatfind -fs xyz:main.adb}
-This is the same command as the previous one, but @code{gnatfind} will
-display the content of the Ada source file lines.
-
-The output will look like:
-
-@example
-directory/main.ads:106:14: xyz <= declaration
- procedure xyz;
-directory/main.adb:24:10: xyz <= body
- procedure xyz is
-directory/foo.ads:45:23: xyz <= declaration
- xyz : Integer;
-@end example
-
-This can make it easier to find exactly the location your are looking
-for.
-
-@item
-@code{gnatfind -r "*x*":main.ads:123 foo.adb}
-Find references to all entities containing an x that are
-referenced on line 123 of main.ads.
-The references will be searched only in main.ads and foo.adb.
-
-@item
-@code{gnatfind main.ads:123}
-Find declarations and bodies for all entities that are referenced on
-line 123 of main.ads.
-
-This is the same as @code{gnatfind "*":main.adb:123`}
-
-@item
-@code{gnatfind mydir/main.adb:123:45}
-Find the declaration for the entity referenced at column 45 in
-line 123 of file main.adb in directory mydir. Note that it
-is usual to omit the identifier name when the column is given,
-since the column position identifies a unique reference.
-
-The column has to be the beginning of the identifier, and should not
-point to any character in the middle of the identifier.
-@end itemize
-
-@node The Ada to HTML Converter gnathtml,,The Cross-Referencing Tools gnatxref and gnatfind,GNAT Utility Programs
-@anchor{gnat_ugn/gnat_utility_programs the-ada-to-html-converter-gnathtml}@anchor{23}@anchor{gnat_ugn/gnat_utility_programs id16}@anchor{160}
-@section The Ada to HTML Converter @code{gnathtml}
-
-
-@geindex gnathtml
-
-@code{gnathtml} is a Perl script that allows Ada source files to be browsed using
-standard Web browsers. For installation information, see @ref{161,,Installing gnathtml}.
-
-Ada reserved keywords are highlighted in a bold font and Ada comments in
-a blue font. Unless your program was compiled with the gcc @code{-gnatx}
-switch to suppress the generation of cross-referencing information, user
-defined variables and types will appear in a different color; you will
-be able to click on any identifier and go to its declaration.
-
-@menu
-* Invoking gnathtml::
-* Installing gnathtml::
-
-@end menu
-
-@node Invoking gnathtml,Installing gnathtml,,The Ada to HTML Converter gnathtml
-@anchor{gnat_ugn/gnat_utility_programs invoking-gnathtml}@anchor{162}@anchor{gnat_ugn/gnat_utility_programs id17}@anchor{163}
-@subsection Invoking @code{gnathtml}
-
-
-The command line is as follows:
-
-@quotation
-
-@example
-$ perl gnathtml.pl [ switches ] ada-files
-@end example
-@end quotation
-
-You can specify as many Ada files as you want. @code{gnathtml} will generate
-an html file for every ada file, and a global file called @code{index.htm}.
-This file is an index of every identifier defined in the files.
-
-The following switches are available:
-
-@geindex -83 (gnathtml)
-
-
-@table @asis
-
-@item @code{83}
-
-Only the Ada 83 subset of keywords will be highlighted.
-@end table
-
-@geindex -cc (gnathtml)
-
-
-@table @asis
-
-@item @code{cc @emph{color}}
-
-This option allows you to change the color used for comments. The default
-value is green. The color argument can be any name accepted by html.
-@end table
-
-@geindex -d (gnathtml)
-
-
-@table @asis
-
-@item @code{d}
-
-If the Ada files depend on some other files (for instance through
-@code{with} clauses, the latter files will also be converted to html.
-Only the files in the user project will be converted to html, not the files
-in the run-time library itself.
-@end table
-
-@geindex -D (gnathtml)
-
-
-@table @asis
-
-@item @code{D}
-
-This command is the same as @code{-d} above, but @code{gnathtml} will
-also look for files in the run-time library, and generate html files for them.
-@end table
-
-@geindex -ext (gnathtml)
-
-
-@table @asis
-
-@item @code{ext @emph{extension}}
-
-This option allows you to change the extension of the generated HTML files.
-If you do not specify an extension, it will default to @code{htm}.
-@end table
-
-@geindex -f (gnathtml)
-
-
-@table @asis
-
-@item @code{f}
-
-By default, gnathtml will generate html links only for global entities
-('with'ed units, global variables and types,...). If you specify
-@code{-f} on the command line, then links will be generated for local
-entities too.
-@end table
-
-@geindex -l (gnathtml)
-
-
-@table @asis
-
-@item @code{l @emph{number}}
-
-If this switch is provided and @code{number} is not 0, then
-@code{gnathtml} will number the html files every @code{number} line.
-@end table
-
-@geindex -I (gnathtml)
-
-
-@table @asis
-
-@item @code{I @emph{dir}}
-
-Specify a directory to search for library files (@code{.ALI} files) and
-source files. You can provide several -I switches on the command line,
-and the directories will be parsed in the order of the command line.
-@end table
-
-@geindex -o (gnathtml)
-
-
-@table @asis
-
-@item @code{o @emph{dir}}
-
-Specify the output directory for html files. By default, gnathtml will
-saved the generated html files in a subdirectory named @code{html/}.
-@end table
-
-@geindex -p (gnathtml)
-
-
-@table @asis
-
-@item @code{p @emph{file}}
-
-If you are using Emacs and the most recent Emacs Ada mode, which provides
-a full Integrated Development Environment for compiling, checking,
-running and debugging applications, you may use @code{.gpr} files
-to give the directories where Emacs can find sources and object files.
-
-Using this switch, you can tell gnathtml to use these files.
-This allows you to get an html version of your application, even if it
-is spread over multiple directories.
-@end table
-
-@geindex -sc (gnathtml)
-
-
-@table @asis
-
-@item @code{sc @emph{color}}
-
-This switch allows you to change the color used for symbol
-definitions.
-The default value is red. The color argument can be any name accepted by html.
-@end table
-
-@geindex -t (gnathtml)
-
-
-@table @asis
-
-@item @code{t @emph{file}}
-
-This switch provides the name of a file. This file contains a list of
-file names to be converted, and the effect is exactly as though they had
-appeared explicitly on the command line. This
-is the recommended way to work around the command line length limit on some
-systems.
-@end table
-
-@node Installing gnathtml,,Invoking gnathtml,The Ada to HTML Converter gnathtml
-@anchor{gnat_ugn/gnat_utility_programs installing-gnathtml}@anchor{161}@anchor{gnat_ugn/gnat_utility_programs id18}@anchor{164}
-@subsection Installing @code{gnathtml}
-
-
-@code{Perl} needs to be installed on your machine to run this script.
-@code{Perl} is freely available for almost every architecture and
-operating system via the Internet.
-
-On Unix systems, you may want to modify the first line of the script
-@code{gnathtml}, to explicitly specify where Perl
-is located. The syntax of this line is:
-
-@quotation
-
-@example
-#!full_path_name_to_perl
-@end example
-@end quotation
-
-Alternatively, you may run the script using the following command line:
-
-@quotation
-
-@example
-$ perl gnathtml.pl [ switches ] files
-@end example
-@end quotation
-
-@c -- +---------------------------------------------------------------------+
-
-@c -- | The following sections are present only in the PRO and GPL editions |
-
-@c -- +---------------------------------------------------------------------+
-
-
@@ -19237,7 +17843,7 @@ $ perl gnathtml.pl [ switches ] files
@c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit
@node GNAT and Program Execution,Platform-Specific Information,GNAT Utility Programs,Top
-@anchor{gnat_ugn/gnat_and_program_execution gnat-and-program-execution}@anchor{c}@anchor{gnat_ugn/gnat_and_program_execution doc}@anchor{165}@anchor{gnat_ugn/gnat_and_program_execution id1}@anchor{166}
+@anchor{gnat_ugn/gnat_and_program_execution gnat-and-program-execution}@anchor{c}@anchor{gnat_ugn/gnat_and_program_execution doc}@anchor{144}@anchor{gnat_ugn/gnat_and_program_execution id1}@anchor{145}
@chapter GNAT and Program Execution
@@ -19247,25 +17853,25 @@ This chapter covers several topics:
@itemize *
@item
-@ref{167,,Running and Debugging Ada Programs}
+@ref{146,,Running and Debugging Ada Programs}
@item
-@ref{25,,Profiling}
+@ref{147,,Profiling}
@item
-@ref{168,,Improving Performance}
+@ref{148,,Improving Performance}
@item
-@ref{169,,Overflow Check Handling in GNAT}
+@ref{149,,Overflow Check Handling in GNAT}
@item
-@ref{16a,,Performing Dimensionality Analysis in GNAT}
+@ref{14a,,Performing Dimensionality Analysis in GNAT}
@item
-@ref{16b,,Stack Related Facilities}
+@ref{14b,,Stack Related Facilities}
@item
-@ref{16c,,Memory Management Issues}
+@ref{14c,,Memory Management Issues}
@end itemize
@menu
@@ -19280,7 +17886,7 @@ This chapter covers several topics:
@end menu
@node Running and Debugging Ada Programs,Profiling,,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution id2}@anchor{167}@anchor{gnat_ugn/gnat_and_program_execution running-and-debugging-ada-programs}@anchor{24}
+@anchor{gnat_ugn/gnat_and_program_execution id2}@anchor{146}@anchor{gnat_ugn/gnat_and_program_execution running-and-debugging-ada-programs}@anchor{14d}
@section Running and Debugging Ada Programs
@@ -19334,7 +17940,7 @@ the incorrect user program.
@end menu
@node The GNAT Debugger GDB,Running GDB,,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debugger-gdb}@anchor{16d}@anchor{gnat_ugn/gnat_and_program_execution id3}@anchor{16e}
+@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debugger-gdb}@anchor{14e}@anchor{gnat_ugn/gnat_and_program_execution id3}@anchor{14f}
@subsection The GNAT Debugger GDB
@@ -19391,7 +17997,7 @@ the debugging information and can respond to user commands to inspect
variables, and more generally to report on the state of execution.
@node Running GDB,Introduction to GDB Commands,The GNAT Debugger GDB,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id4}@anchor{16f}@anchor{gnat_ugn/gnat_and_program_execution running-gdb}@anchor{170}
+@anchor{gnat_ugn/gnat_and_program_execution id4}@anchor{150}@anchor{gnat_ugn/gnat_and_program_execution running-gdb}@anchor{151}
@subsection Running GDB
@@ -19418,7 +18024,7 @@ exactly as if the debugger were not present. The following section
describes some of the additional commands that can be given to @code{GDB}.
@node Introduction to GDB Commands,Using Ada Expressions,Running GDB,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution introduction-to-gdb-commands}@anchor{171}@anchor{gnat_ugn/gnat_and_program_execution id5}@anchor{172}
+@anchor{gnat_ugn/gnat_and_program_execution introduction-to-gdb-commands}@anchor{152}@anchor{gnat_ugn/gnat_and_program_execution id5}@anchor{153}
@subsection Introduction to GDB Commands
@@ -19626,7 +18232,7 @@ Note that most commands can be abbreviated
(for example, c for continue, bt for backtrace).
@node Using Ada Expressions,Calling User-Defined Subprograms,Introduction to GDB Commands,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id6}@anchor{173}@anchor{gnat_ugn/gnat_and_program_execution using-ada-expressions}@anchor{174}
+@anchor{gnat_ugn/gnat_and_program_execution id6}@anchor{154}@anchor{gnat_ugn/gnat_and_program_execution using-ada-expressions}@anchor{155}
@subsection Using Ada Expressions
@@ -19664,7 +18270,7 @@ their packages, regardless of context. Where this causes ambiguity,
For details on the supported Ada syntax, see @cite{Debugging with GDB}.
@node Calling User-Defined Subprograms,Using the next Command in a Function,Using Ada Expressions,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id7}@anchor{175}@anchor{gnat_ugn/gnat_and_program_execution calling-user-defined-subprograms}@anchor{176}
+@anchor{gnat_ugn/gnat_and_program_execution id7}@anchor{156}@anchor{gnat_ugn/gnat_and_program_execution calling-user-defined-subprograms}@anchor{157}
@subsection Calling User-Defined Subprograms
@@ -19723,7 +18329,7 @@ elements directly from GDB, you can write a callable procedure that prints
the elements in the desired format.
@node Using the next Command in a Function,Stopping When Ada Exceptions Are Raised,Calling User-Defined Subprograms,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution using-the-next-command-in-a-function}@anchor{177}@anchor{gnat_ugn/gnat_and_program_execution id8}@anchor{178}
+@anchor{gnat_ugn/gnat_and_program_execution using-the-next-command-in-a-function}@anchor{158}@anchor{gnat_ugn/gnat_and_program_execution id8}@anchor{159}
@subsection Using the @emph{next} Command in a Function
@@ -19746,7 +18352,7 @@ The value returned is always that from the first return statement
that was stepped through.
@node Stopping When Ada Exceptions Are Raised,Ada Tasks,Using the next Command in a Function,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution stopping-when-ada-exceptions-are-raised}@anchor{179}@anchor{gnat_ugn/gnat_and_program_execution id9}@anchor{17a}
+@anchor{gnat_ugn/gnat_and_program_execution stopping-when-ada-exceptions-are-raised}@anchor{15a}@anchor{gnat_ugn/gnat_and_program_execution id9}@anchor{15b}
@subsection Stopping When Ada Exceptions Are Raised
@@ -19803,7 +18409,7 @@ argument, prints out only those exceptions whose name matches @emph{regexp}.
@geindex Tasks (in gdb)
@node Ada Tasks,Debugging Generic Units,Stopping When Ada Exceptions Are Raised,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution ada-tasks}@anchor{17b}@anchor{gnat_ugn/gnat_and_program_execution id10}@anchor{17c}
+@anchor{gnat_ugn/gnat_and_program_execution ada-tasks}@anchor{15c}@anchor{gnat_ugn/gnat_and_program_execution id10}@anchor{15d}
@subsection Ada Tasks
@@ -19890,7 +18496,7 @@ see @cite{Debugging with GDB}.
@geindex Generics
@node Debugging Generic Units,Remote Debugging with gdbserver,Ada Tasks,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution debugging-generic-units}@anchor{17d}@anchor{gnat_ugn/gnat_and_program_execution id11}@anchor{17e}
+@anchor{gnat_ugn/gnat_and_program_execution debugging-generic-units}@anchor{15e}@anchor{gnat_ugn/gnat_and_program_execution id11}@anchor{15f}
@subsection Debugging Generic Units
@@ -19949,7 +18555,7 @@ other units.
@geindex Remote Debugging with gdbserver
@node Remote Debugging with gdbserver,GNAT Abnormal Termination or Failure to Terminate,Debugging Generic Units,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution remote-debugging-with-gdbserver}@anchor{17f}@anchor{gnat_ugn/gnat_and_program_execution id12}@anchor{180}
+@anchor{gnat_ugn/gnat_and_program_execution remote-debugging-with-gdbserver}@anchor{160}@anchor{gnat_ugn/gnat_and_program_execution id12}@anchor{161}
@subsection Remote Debugging with gdbserver
@@ -20007,7 +18613,7 @@ GNAT provides support for gdbserver on x86-linux, x86-windows and x86_64-linux.
@geindex Abnormal Termination or Failure to Terminate
@node GNAT Abnormal Termination or Failure to Terminate,Naming Conventions for GNAT Source Files,Remote Debugging with gdbserver,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution gnat-abnormal-termination-or-failure-to-terminate}@anchor{181}@anchor{gnat_ugn/gnat_and_program_execution id13}@anchor{182}
+@anchor{gnat_ugn/gnat_and_program_execution gnat-abnormal-termination-or-failure-to-terminate}@anchor{162}@anchor{gnat_ugn/gnat_and_program_execution id13}@anchor{163}
@subsection GNAT Abnormal Termination or Failure to Terminate
@@ -20062,7 +18668,7 @@ Finally, you can start
@code{gdb} directly on the @code{gnat1} executable. @code{gnat1} is the
front-end of GNAT, and can be run independently (normally it is just
called from @code{gcc}). You can use @code{gdb} on @code{gnat1} as you
-would on a C program (but @ref{16d,,The GNAT Debugger GDB} for caveats). The
+would on a C program (but @ref{14e,,The GNAT Debugger GDB} for caveats). The
@code{where} command is the first line of attack; the variable
@code{lineno} (seen by @code{print lineno}), used by the second phase of
@code{gnat1} and by the @code{gcc} backend, indicates the source line at
@@ -20071,7 +18677,7 @@ the source file.
@end itemize
@node Naming Conventions for GNAT Source Files,Getting Internal Debugging Information,GNAT Abnormal Termination or Failure to Terminate,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution naming-conventions-for-gnat-source-files}@anchor{183}@anchor{gnat_ugn/gnat_and_program_execution id14}@anchor{184}
+@anchor{gnat_ugn/gnat_and_program_execution naming-conventions-for-gnat-source-files}@anchor{164}@anchor{gnat_ugn/gnat_and_program_execution id14}@anchor{165}
@subsection Naming Conventions for GNAT Source Files
@@ -20152,7 +18758,7 @@ the other @code{.c} files are modifications of common @code{gcc} files.
@end itemize
@node Getting Internal Debugging Information,Stack Traceback,Naming Conventions for GNAT Source Files,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id15}@anchor{185}@anchor{gnat_ugn/gnat_and_program_execution getting-internal-debugging-information}@anchor{186}
+@anchor{gnat_ugn/gnat_and_program_execution id15}@anchor{166}@anchor{gnat_ugn/gnat_and_program_execution getting-internal-debugging-information}@anchor{167}
@subsection Getting Internal Debugging Information
@@ -20180,7 +18786,7 @@ are replaced with run-time calls.
@geindex stack unwinding
@node Stack Traceback,Pretty-Printers for the GNAT runtime,Getting Internal Debugging Information,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution stack-traceback}@anchor{187}@anchor{gnat_ugn/gnat_and_program_execution id16}@anchor{188}
+@anchor{gnat_ugn/gnat_and_program_execution stack-traceback}@anchor{168}@anchor{gnat_ugn/gnat_and_program_execution id16}@anchor{169}
@subsection Stack Traceback
@@ -20209,7 +18815,7 @@ is enabled, and no exception is raised during program execution.
@end menu
@node Non-Symbolic Traceback,Symbolic Traceback,,Stack Traceback
-@anchor{gnat_ugn/gnat_and_program_execution non-symbolic-traceback}@anchor{189}@anchor{gnat_ugn/gnat_and_program_execution id17}@anchor{18a}
+@anchor{gnat_ugn/gnat_and_program_execution non-symbolic-traceback}@anchor{16a}@anchor{gnat_ugn/gnat_and_program_execution id17}@anchor{16b}
@subsubsection Non-Symbolic Traceback
@@ -20336,7 +18942,7 @@ From this traceback we can see that the exception was raised in
@code{stb.adb} at line 5, which was reached from a procedure call in
@code{stb.adb} at line 10, and so on. The @code{b~std.adb} is the binder file,
which contains the call to the main program.
-@ref{11c,,Running gnatbind}. The remaining entries are assorted runtime routines,
+@ref{10d,,Running gnatbind}. The remaining entries are assorted runtime routines,
and the output will vary from platform to platform.
It is also possible to use @code{GDB} with these traceback addresses to debug
@@ -20494,7 +19100,7 @@ need to be specified in C format, with a leading '0x').
@geindex symbolic
@node Symbolic Traceback,,Non-Symbolic Traceback,Stack Traceback
-@anchor{gnat_ugn/gnat_and_program_execution id18}@anchor{18b}@anchor{gnat_ugn/gnat_and_program_execution symbolic-traceback}@anchor{18c}
+@anchor{gnat_ugn/gnat_and_program_execution id18}@anchor{16c}@anchor{gnat_ugn/gnat_and_program_execution symbolic-traceback}@anchor{16d}
@subsubsection Symbolic Traceback
@@ -20622,7 +19228,7 @@ which will also be printed if an unhandled exception terminates the
program.
@node Pretty-Printers for the GNAT runtime,,Stack Traceback,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id19}@anchor{18d}@anchor{gnat_ugn/gnat_and_program_execution pretty-printers-for-the-gnat-runtime}@anchor{18e}
+@anchor{gnat_ugn/gnat_and_program_execution id19}@anchor{16e}@anchor{gnat_ugn/gnat_and_program_execution pretty-printers-for-the-gnat-runtime}@anchor{16f}
@subsection Pretty-Printers for the GNAT runtime
@@ -20729,7 +19335,7 @@ for more information.
@geindex Profiling
@node Profiling,Improving Performance,Running and Debugging Ada Programs,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution profiling}@anchor{25}@anchor{gnat_ugn/gnat_and_program_execution id20}@anchor{18f}
+@anchor{gnat_ugn/gnat_and_program_execution profiling}@anchor{147}@anchor{gnat_ugn/gnat_and_program_execution id20}@anchor{170}
@section Profiling
@@ -20745,7 +19351,7 @@ This section describes how to use the @code{gprof} profiler tool on Ada programs
@end menu
@node Profiling an Ada Program with gprof,,,Profiling
-@anchor{gnat_ugn/gnat_and_program_execution id21}@anchor{190}@anchor{gnat_ugn/gnat_and_program_execution profiling-an-ada-program-with-gprof}@anchor{191}
+@anchor{gnat_ugn/gnat_and_program_execution id21}@anchor{171}@anchor{gnat_ugn/gnat_and_program_execution profiling-an-ada-program-with-gprof}@anchor{172}
@subsection Profiling an Ada Program with gprof
@@ -20799,7 +19405,7 @@ to interpret the results.
@end menu
@node Compilation for profiling,Program execution,,Profiling an Ada Program with gprof
-@anchor{gnat_ugn/gnat_and_program_execution id22}@anchor{192}@anchor{gnat_ugn/gnat_and_program_execution compilation-for-profiling}@anchor{193}
+@anchor{gnat_ugn/gnat_and_program_execution id22}@anchor{173}@anchor{gnat_ugn/gnat_and_program_execution compilation-for-profiling}@anchor{174}
@subsubsection Compilation for profiling
@@ -20827,7 +19433,7 @@ be profiled; if you need to profile your whole project, use the @code{-f}
gnatmake switch to force full recompilation.
@node Program execution,Running gprof,Compilation for profiling,Profiling an Ada Program with gprof
-@anchor{gnat_ugn/gnat_and_program_execution program-execution}@anchor{194}@anchor{gnat_ugn/gnat_and_program_execution id23}@anchor{195}
+@anchor{gnat_ugn/gnat_and_program_execution program-execution}@anchor{175}@anchor{gnat_ugn/gnat_and_program_execution id23}@anchor{176}
@subsubsection Program execution
@@ -20842,7 +19448,7 @@ generated in the directory where the program was launched from. If this file
already exists, it will be overwritten.
@node Running gprof,Interpretation of profiling results,Program execution,Profiling an Ada Program with gprof
-@anchor{gnat_ugn/gnat_and_program_execution running-gprof}@anchor{196}@anchor{gnat_ugn/gnat_and_program_execution id24}@anchor{197}
+@anchor{gnat_ugn/gnat_and_program_execution running-gprof}@anchor{177}@anchor{gnat_ugn/gnat_and_program_execution id24}@anchor{178}
@subsubsection Running gprof
@@ -20955,7 +19561,7 @@ may be given; only one @code{function_name} may be indicated with each
@end table
@node Interpretation of profiling results,,Running gprof,Profiling an Ada Program with gprof
-@anchor{gnat_ugn/gnat_and_program_execution id25}@anchor{198}@anchor{gnat_ugn/gnat_and_program_execution interpretation-of-profiling-results}@anchor{199}
+@anchor{gnat_ugn/gnat_and_program_execution id25}@anchor{179}@anchor{gnat_ugn/gnat_and_program_execution interpretation-of-profiling-results}@anchor{17a}
@subsubsection Interpretation of profiling results
@@ -20972,7 +19578,7 @@ and the subprograms that it calls. It also provides an estimate of the time
spent in each of those callers/called subprograms.
@node Improving Performance,Overflow Check Handling in GNAT,Profiling,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution improving-performance}@anchor{26}@anchor{gnat_ugn/gnat_and_program_execution id26}@anchor{168}
+@anchor{gnat_ugn/gnat_and_program_execution improving-performance}@anchor{17b}@anchor{gnat_ugn/gnat_and_program_execution id26}@anchor{148}
@section Improving Performance
@@ -20993,7 +19599,7 @@ which can reduce the size of program executables.
@end menu
@node Performance Considerations,Text_IO Suggestions,,Improving Performance
-@anchor{gnat_ugn/gnat_and_program_execution performance-considerations}@anchor{19a}@anchor{gnat_ugn/gnat_and_program_execution id27}@anchor{19b}
+@anchor{gnat_ugn/gnat_and_program_execution performance-considerations}@anchor{17c}@anchor{gnat_ugn/gnat_and_program_execution id27}@anchor{17d}
@subsection Performance Considerations
@@ -21054,7 +19660,7 @@ some guidelines on debugging optimized code.
@end menu
@node Controlling Run-Time Checks,Use of Restrictions,,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id28}@anchor{19c}@anchor{gnat_ugn/gnat_and_program_execution controlling-run-time-checks}@anchor{19d}
+@anchor{gnat_ugn/gnat_and_program_execution id28}@anchor{17e}@anchor{gnat_ugn/gnat_and_program_execution controlling-run-time-checks}@anchor{17f}
@subsubsection Controlling Run-Time Checks
@@ -21068,7 +19674,7 @@ necessary checking is done at compile time.
@geindex -gnato (gcc)
The gnat switch, @code{-gnatp} allows this default to be modified. See
-@ref{f9,,Run-Time Checks}.
+@ref{ea,,Run-Time Checks}.
Our experience is that the default is suitable for most development
purposes.
@@ -21106,7 +19712,7 @@ remove checks) or @code{pragma Unsuppress} (to add back suppressed
checks) in the program source.
@node Use of Restrictions,Optimization Levels,Controlling Run-Time Checks,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id29}@anchor{19e}@anchor{gnat_ugn/gnat_and_program_execution use-of-restrictions}@anchor{19f}
+@anchor{gnat_ugn/gnat_and_program_execution id29}@anchor{180}@anchor{gnat_ugn/gnat_and_program_execution use-of-restrictions}@anchor{181}
@subsubsection Use of Restrictions
@@ -21141,7 +19747,7 @@ that this also means that you can write code without worrying about the
possibility of an immediate abort at any point.
@node Optimization Levels,Debugging Optimized Code,Use of Restrictions,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id30}@anchor{1a0}@anchor{gnat_ugn/gnat_and_program_execution optimization-levels}@anchor{fc}
+@anchor{gnat_ugn/gnat_and_program_execution id30}@anchor{182}@anchor{gnat_ugn/gnat_and_program_execution optimization-levels}@anchor{ed}
@subsubsection Optimization Levels
@@ -21222,7 +19828,7 @@ the slowest compilation time.
Full optimization as in @code{-O2};
also uses more aggressive automatic inlining of subprograms within a unit
-(@ref{10f,,Inlining of Subprograms}) and attempts to vectorize loops.
+(@ref{100,,Inlining of Subprograms}) and attempts to vectorize loops.
@end table
@item
@@ -21262,10 +19868,10 @@ levels.
Note regarding the use of @code{-O3}: The use of this optimization level
ought not to be automatically preferred over that of level @code{-O2},
since it often results in larger executables which may run more slowly.
-See further discussion of this point in @ref{10f,,Inlining of Subprograms}.
+See further discussion of this point in @ref{100,,Inlining of Subprograms}.
@node Debugging Optimized Code,Inlining of Subprograms,Optimization Levels,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution debugging-optimized-code}@anchor{1a1}@anchor{gnat_ugn/gnat_and_program_execution id31}@anchor{1a2}
+@anchor{gnat_ugn/gnat_and_program_execution debugging-optimized-code}@anchor{183}@anchor{gnat_ugn/gnat_and_program_execution id31}@anchor{184}
@subsubsection Debugging Optimized Code
@@ -21393,7 +19999,7 @@ on the resulting executable,
which removes both debugging information and global symbols.
@node Inlining of Subprograms,Floating_Point_Operations,Debugging Optimized Code,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id32}@anchor{1a3}@anchor{gnat_ugn/gnat_and_program_execution inlining-of-subprograms}@anchor{10f}
+@anchor{gnat_ugn/gnat_and_program_execution id32}@anchor{185}@anchor{gnat_ugn/gnat_and_program_execution inlining-of-subprograms}@anchor{100}
@subsubsection Inlining of Subprograms
@@ -21532,7 +20138,7 @@ indeed you should use @code{-O3} only if tests show that it actually
improves performance for your program.
@node Floating_Point_Operations,Vectorization of loops,Inlining of Subprograms,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution floating-point-operations}@anchor{1a4}@anchor{gnat_ugn/gnat_and_program_execution id33}@anchor{1a5}
+@anchor{gnat_ugn/gnat_and_program_execution floating-point-operations}@anchor{186}@anchor{gnat_ugn/gnat_and_program_execution id33}@anchor{187}
@subsubsection Floating_Point_Operations
@@ -21580,7 +20186,7 @@ so it is permissible to mix units compiled with and without these
switches.
@node Vectorization of loops,Other Optimization Switches,Floating_Point_Operations,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id34}@anchor{1a6}@anchor{gnat_ugn/gnat_and_program_execution vectorization-of-loops}@anchor{1a7}
+@anchor{gnat_ugn/gnat_and_program_execution id34}@anchor{188}@anchor{gnat_ugn/gnat_and_program_execution vectorization-of-loops}@anchor{189}
@subsubsection Vectorization of loops
@@ -21731,7 +20337,7 @@ placed immediately within the loop will tell the compiler that it can safely
omit the non-vectorized version of the loop as well as the run-time test.
@node Other Optimization Switches,Optimization and Strict Aliasing,Vectorization of loops,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution other-optimization-switches}@anchor{1a8}@anchor{gnat_ugn/gnat_and_program_execution id35}@anchor{1a9}
+@anchor{gnat_ugn/gnat_and_program_execution other-optimization-switches}@anchor{18a}@anchor{gnat_ugn/gnat_and_program_execution id35}@anchor{18b}
@subsubsection Other Optimization Switches
@@ -21748,7 +20354,7 @@ the @emph{Submodel Options} section in the @emph{Hardware Models and Configurati
chapter of @cite{Using the GNU Compiler Collection (GCC)}.
@node Optimization and Strict Aliasing,Aliased Variables and Optimization,Other Optimization Switches,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution optimization-and-strict-aliasing}@anchor{f3}@anchor{gnat_ugn/gnat_and_program_execution id36}@anchor{1aa}
+@anchor{gnat_ugn/gnat_and_program_execution optimization-and-strict-aliasing}@anchor{e4}@anchor{gnat_ugn/gnat_and_program_execution id36}@anchor{18c}
@subsubsection Optimization and Strict Aliasing
@@ -21988,7 +20594,7 @@ review any uses of unchecked conversion of access types,
particularly if you are getting the warnings described above.
@node Aliased Variables and Optimization,Atomic Variables and Optimization,Optimization and Strict Aliasing,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id37}@anchor{1ab}@anchor{gnat_ugn/gnat_and_program_execution aliased-variables-and-optimization}@anchor{1ac}
+@anchor{gnat_ugn/gnat_and_program_execution id37}@anchor{18d}@anchor{gnat_ugn/gnat_and_program_execution aliased-variables-and-optimization}@anchor{18e}
@subsubsection Aliased Variables and Optimization
@@ -22046,7 +20652,7 @@ This means that the above example will in fact "work" reliably,
that is, it will produce the expected results.
@node Atomic Variables and Optimization,Passive Task Optimization,Aliased Variables and Optimization,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution atomic-variables-and-optimization}@anchor{1ad}@anchor{gnat_ugn/gnat_and_program_execution id38}@anchor{1ae}
+@anchor{gnat_ugn/gnat_and_program_execution atomic-variables-and-optimization}@anchor{18f}@anchor{gnat_ugn/gnat_and_program_execution id38}@anchor{190}
@subsubsection Atomic Variables and Optimization
@@ -22127,7 +20733,7 @@ such synchronization code is not required, it may be
useful to disable it.
@node Passive Task Optimization,,Atomic Variables and Optimization,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution passive-task-optimization}@anchor{1af}@anchor{gnat_ugn/gnat_and_program_execution id39}@anchor{1b0}
+@anchor{gnat_ugn/gnat_and_program_execution passive-task-optimization}@anchor{191}@anchor{gnat_ugn/gnat_and_program_execution id39}@anchor{192}
@subsubsection Passive Task Optimization
@@ -22172,7 +20778,7 @@ that typically clients of the tasks who call entries, will not have
to be modified, only the task definition itself.
@node Text_IO Suggestions,Reducing Size of Executables with Unused Subprogram/Data Elimination,Performance Considerations,Improving Performance
-@anchor{gnat_ugn/gnat_and_program_execution text-io-suggestions}@anchor{1b1}@anchor{gnat_ugn/gnat_and_program_execution id40}@anchor{1b2}
+@anchor{gnat_ugn/gnat_and_program_execution text-io-suggestions}@anchor{193}@anchor{gnat_ugn/gnat_and_program_execution id40}@anchor{194}
@subsection @code{Text_IO} Suggestions
@@ -22195,7 +20801,7 @@ of the standard output file, or change the standard output file to
be buffered using @code{Interfaces.C_Streams.setvbuf}.
@node Reducing Size of Executables with Unused Subprogram/Data Elimination,,Text_IO Suggestions,Improving Performance
-@anchor{gnat_ugn/gnat_and_program_execution id41}@anchor{1b3}@anchor{gnat_ugn/gnat_and_program_execution reducing-size-of-executables-with-unused-subprogram-data-elimination}@anchor{1b4}
+@anchor{gnat_ugn/gnat_and_program_execution id41}@anchor{195}@anchor{gnat_ugn/gnat_and_program_execution reducing-size-of-executables-with-unused-subprogram-data-elimination}@anchor{196}
@subsection Reducing Size of Executables with Unused Subprogram/Data Elimination
@@ -22212,7 +20818,7 @@ your executable just by setting options at compilation time.
@end menu
@node About unused subprogram/data elimination,Compilation options,,Reducing Size of Executables with Unused Subprogram/Data Elimination
-@anchor{gnat_ugn/gnat_and_program_execution id42}@anchor{1b5}@anchor{gnat_ugn/gnat_and_program_execution about-unused-subprogram-data-elimination}@anchor{1b6}
+@anchor{gnat_ugn/gnat_and_program_execution id42}@anchor{197}@anchor{gnat_ugn/gnat_and_program_execution about-unused-subprogram-data-elimination}@anchor{198}
@subsubsection About unused subprogram/data elimination
@@ -22228,7 +20834,7 @@ architecture and on all cross platforms using the ELF binary file format.
In both cases GNU binutils version 2.16 or later are required to enable it.
@node Compilation options,Example of unused subprogram/data elimination,About unused subprogram/data elimination,Reducing Size of Executables with Unused Subprogram/Data Elimination
-@anchor{gnat_ugn/gnat_and_program_execution id43}@anchor{1b7}@anchor{gnat_ugn/gnat_and_program_execution compilation-options}@anchor{1b8}
+@anchor{gnat_ugn/gnat_and_program_execution id43}@anchor{199}@anchor{gnat_ugn/gnat_and_program_execution compilation-options}@anchor{19a}
@subsubsection Compilation options
@@ -22267,7 +20873,7 @@ The GNAT static library is now compiled with -ffunction-sections and
and data of the GNAT library from your executable.
@node Example of unused subprogram/data elimination,,Compilation options,Reducing Size of Executables with Unused Subprogram/Data Elimination
-@anchor{gnat_ugn/gnat_and_program_execution example-of-unused-subprogram-data-elimination}@anchor{1b9}@anchor{gnat_ugn/gnat_and_program_execution id44}@anchor{1ba}
+@anchor{gnat_ugn/gnat_and_program_execution example-of-unused-subprogram-data-elimination}@anchor{19b}@anchor{gnat_ugn/gnat_and_program_execution id44}@anchor{19c}
@subsubsection Example of unused subprogram/data elimination
@@ -22337,7 +20943,7 @@ appropriate options.
@geindex Checks (overflow)
@node Overflow Check Handling in GNAT,Performing Dimensionality Analysis in GNAT,Improving Performance,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution id45}@anchor{169}@anchor{gnat_ugn/gnat_and_program_execution overflow-check-handling-in-gnat}@anchor{27}
+@anchor{gnat_ugn/gnat_and_program_execution id45}@anchor{149}@anchor{gnat_ugn/gnat_and_program_execution overflow-check-handling-in-gnat}@anchor{19d}
@section Overflow Check Handling in GNAT
@@ -22353,7 +20959,7 @@ This section explains how to control the handling of overflow checks.
@end menu
@node Background,Management of Overflows in GNAT,,Overflow Check Handling in GNAT
-@anchor{gnat_ugn/gnat_and_program_execution id46}@anchor{1bb}@anchor{gnat_ugn/gnat_and_program_execution background}@anchor{1bc}
+@anchor{gnat_ugn/gnat_and_program_execution id46}@anchor{19e}@anchor{gnat_ugn/gnat_and_program_execution background}@anchor{19f}
@subsection Background
@@ -22479,7 +21085,7 @@ exception raised because of the intermediate overflow (and we really
would prefer this precondition to be considered True at run time).
@node Management of Overflows in GNAT,Specifying the Desired Mode,Background,Overflow Check Handling in GNAT
-@anchor{gnat_ugn/gnat_and_program_execution id47}@anchor{1bd}@anchor{gnat_ugn/gnat_and_program_execution management-of-overflows-in-gnat}@anchor{1be}
+@anchor{gnat_ugn/gnat_and_program_execution id47}@anchor{1a0}@anchor{gnat_ugn/gnat_and_program_execution management-of-overflows-in-gnat}@anchor{1a1}
@subsection Management of Overflows in GNAT
@@ -22593,7 +21199,7 @@ out in the normal manner (with infinite values always failing all
range checks).
@node Specifying the Desired Mode,Default Settings,Management of Overflows in GNAT,Overflow Check Handling in GNAT
-@anchor{gnat_ugn/gnat_and_program_execution specifying-the-desired-mode}@anchor{f8}@anchor{gnat_ugn/gnat_and_program_execution id48}@anchor{1bf}
+@anchor{gnat_ugn/gnat_and_program_execution specifying-the-desired-mode}@anchor{e9}@anchor{gnat_ugn/gnat_and_program_execution id48}@anchor{1a2}
@subsection Specifying the Desired Mode
@@ -22717,7 +21323,7 @@ causing all intermediate operations to be computed using the base
type (@code{STRICT} mode).
@node Default Settings,Implementation Notes,Specifying the Desired Mode,Overflow Check Handling in GNAT
-@anchor{gnat_ugn/gnat_and_program_execution id49}@anchor{1c0}@anchor{gnat_ugn/gnat_and_program_execution default-settings}@anchor{1c1}
+@anchor{gnat_ugn/gnat_and_program_execution id49}@anchor{1a3}@anchor{gnat_ugn/gnat_and_program_execution default-settings}@anchor{1a4}
@subsection Default Settings
@@ -22764,7 +21370,7 @@ checking, but it has no effect on the method used for computing
intermediate results.
@node Implementation Notes,,Default Settings,Overflow Check Handling in GNAT
-@anchor{gnat_ugn/gnat_and_program_execution implementation-notes}@anchor{1c2}@anchor{gnat_ugn/gnat_and_program_execution id50}@anchor{1c3}
+@anchor{gnat_ugn/gnat_and_program_execution implementation-notes}@anchor{1a5}@anchor{gnat_ugn/gnat_and_program_execution id50}@anchor{1a6}
@subsection Implementation Notes
@@ -22812,7 +21418,7 @@ platforms for which @code{Long_Long_Integer} is 64-bits (nearly all GNAT
platforms).
@node Performing Dimensionality Analysis in GNAT,Stack Related Facilities,Overflow Check Handling in GNAT,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution performing-dimensionality-analysis-in-gnat}@anchor{28}@anchor{gnat_ugn/gnat_and_program_execution id51}@anchor{16a}
+@anchor{gnat_ugn/gnat_and_program_execution performing-dimensionality-analysis-in-gnat}@anchor{1a7}@anchor{gnat_ugn/gnat_and_program_execution id51}@anchor{14a}
@section Performing Dimensionality Analysis in GNAT
@@ -23199,7 +21805,7 @@ passing (the dimension vector for the actual parameter must be equal to the
dimension vector for the formal parameter).
@node Stack Related Facilities,Memory Management Issues,Performing Dimensionality Analysis in GNAT,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution stack-related-facilities}@anchor{29}@anchor{gnat_ugn/gnat_and_program_execution id52}@anchor{16b}
+@anchor{gnat_ugn/gnat_and_program_execution stack-related-facilities}@anchor{1a8}@anchor{gnat_ugn/gnat_and_program_execution id52}@anchor{14b}
@section Stack Related Facilities
@@ -23215,7 +21821,7 @@ particular, it deals with dynamic and static stack usage measurements.
@end menu
@node Stack Overflow Checking,Static Stack Usage Analysis,,Stack Related Facilities
-@anchor{gnat_ugn/gnat_and_program_execution id53}@anchor{1c4}@anchor{gnat_ugn/gnat_and_program_execution stack-overflow-checking}@anchor{f4}
+@anchor{gnat_ugn/gnat_and_program_execution id53}@anchor{1a9}@anchor{gnat_ugn/gnat_and_program_execution stack-overflow-checking}@anchor{e5}
@subsection Stack Overflow Checking
@@ -23252,7 +21858,7 @@ If the space is exceeded, then a @code{Storage_Error} exception is raised.
For declared tasks, the default stack size is defined by the GNAT runtime,
whose size may be modified at bind time through the @code{-d} bind switch
-(@ref{11f,,Switches for gnatbind}). Task specific stack sizes may be set using the
+(@ref{110,,Switches for gnatbind}). Task specific stack sizes may be set using the
@code{Storage_Size} pragma.
For the environment task, the stack size is determined by the operating system.
@@ -23260,7 +21866,7 @@ Consequently, to modify the size of the environment task please refer to your
operating system documentation.
@node Static Stack Usage Analysis,Dynamic Stack Usage Analysis,Stack Overflow Checking,Stack Related Facilities
-@anchor{gnat_ugn/gnat_and_program_execution id54}@anchor{1c5}@anchor{gnat_ugn/gnat_and_program_execution static-stack-usage-analysis}@anchor{f5}
+@anchor{gnat_ugn/gnat_and_program_execution id54}@anchor{1aa}@anchor{gnat_ugn/gnat_and_program_execution static-stack-usage-analysis}@anchor{e6}
@subsection Static Stack Usage Analysis
@@ -23309,7 +21915,7 @@ subprogram whose stack usage might be larger than the specified amount of
bytes. The wording is in keeping with the qualifier documented above.
@node Dynamic Stack Usage Analysis,,Static Stack Usage Analysis,Stack Related Facilities
-@anchor{gnat_ugn/gnat_and_program_execution id55}@anchor{1c6}@anchor{gnat_ugn/gnat_and_program_execution dynamic-stack-usage-analysis}@anchor{122}
+@anchor{gnat_ugn/gnat_and_program_execution id55}@anchor{1ab}@anchor{gnat_ugn/gnat_and_program_execution dynamic-stack-usage-analysis}@anchor{113}
@subsection Dynamic Stack Usage Analysis
@@ -23391,7 +21997,7 @@ The package @code{GNAT.Task_Stack_Usage} provides facilities to get
stack-usage reports at run time. See its body for the details.
@node Memory Management Issues,,Stack Related Facilities,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution id56}@anchor{16c}@anchor{gnat_ugn/gnat_and_program_execution memory-management-issues}@anchor{2a}
+@anchor{gnat_ugn/gnat_and_program_execution id56}@anchor{14c}@anchor{gnat_ugn/gnat_and_program_execution memory-management-issues}@anchor{1ac}
@section Memory Management Issues
@@ -23407,7 +22013,7 @@ incorrect uses of access values (including 'dangling references').
@end menu
@node Some Useful Memory Pools,The GNAT Debug Pool Facility,,Memory Management Issues
-@anchor{gnat_ugn/gnat_and_program_execution id57}@anchor{1c7}@anchor{gnat_ugn/gnat_and_program_execution some-useful-memory-pools}@anchor{1c8}
+@anchor{gnat_ugn/gnat_and_program_execution id57}@anchor{1ad}@anchor{gnat_ugn/gnat_and_program_execution some-useful-memory-pools}@anchor{1ae}
@subsection Some Useful Memory Pools
@@ -23488,7 +22094,7 @@ for T1'Storage_Size use 10_000;
@end quotation
@node The GNAT Debug Pool Facility,,Some Useful Memory Pools,Memory Management Issues
-@anchor{gnat_ugn/gnat_and_program_execution id58}@anchor{1c9}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debug-pool-facility}@anchor{1ca}
+@anchor{gnat_ugn/gnat_and_program_execution id58}@anchor{1af}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debug-pool-facility}@anchor{1b0}
@subsection The GNAT Debug Pool Facility
@@ -23651,7 +22257,7 @@ Debug Pool info:
@c -- E.g. Ada |nbsp| 95
@node Platform-Specific Information,Example of Binder Output File,GNAT and Program Execution,Top
-@anchor{gnat_ugn/platform_specific_information platform-specific-information}@anchor{d}@anchor{gnat_ugn/platform_specific_information doc}@anchor{1cb}@anchor{gnat_ugn/platform_specific_information id1}@anchor{1cc}
+@anchor{gnat_ugn/platform_specific_information platform-specific-information}@anchor{d}@anchor{gnat_ugn/platform_specific_information doc}@anchor{1b1}@anchor{gnat_ugn/platform_specific_information id1}@anchor{1b2}
@chapter Platform-Specific Information
@@ -23669,7 +22275,7 @@ topics related to the GNAT implementation on Windows and Mac OS.
@end menu
@node Run-Time Libraries,Specifying a Run-Time Library,,Platform-Specific Information
-@anchor{gnat_ugn/platform_specific_information id2}@anchor{1cd}@anchor{gnat_ugn/platform_specific_information run-time-libraries}@anchor{2b}
+@anchor{gnat_ugn/platform_specific_information id2}@anchor{1b3}@anchor{gnat_ugn/platform_specific_information run-time-libraries}@anchor{1b4}
@section Run-Time Libraries
@@ -23730,7 +22336,7 @@ are supplied on various GNAT platforms.
@end menu
@node Summary of Run-Time Configurations,,,Run-Time Libraries
-@anchor{gnat_ugn/platform_specific_information summary-of-run-time-configurations}@anchor{1ce}@anchor{gnat_ugn/platform_specific_information id3}@anchor{1cf}
+@anchor{gnat_ugn/platform_specific_information summary-of-run-time-configurations}@anchor{1b5}@anchor{gnat_ugn/platform_specific_information id3}@anchor{1b6}
@subsection Summary of Run-Time Configurations
@@ -23830,7 +22436,7 @@ ZCX
@node Specifying a Run-Time Library,GNU/Linux Topics,Run-Time Libraries,Platform-Specific Information
-@anchor{gnat_ugn/platform_specific_information specifying-a-run-time-library}@anchor{1d0}@anchor{gnat_ugn/platform_specific_information id4}@anchor{1d1}
+@anchor{gnat_ugn/platform_specific_information specifying-a-run-time-library}@anchor{1b7}@anchor{gnat_ugn/platform_specific_information id4}@anchor{1b8}
@section Specifying a Run-Time Library
@@ -23917,7 +22523,7 @@ Alternatively, you can specify @code{rts-sjlj/adainclude} in the file
Selecting another run-time library temporarily can be
achieved by using the @code{--RTS} switch, e.g., @code{--RTS=sjlj}
-@anchor{gnat_ugn/platform_specific_information choosing-the-scheduling-policy}@anchor{1d2}
+@anchor{gnat_ugn/platform_specific_information choosing-the-scheduling-policy}@anchor{1b9}
@geindex SCHED_FIFO scheduling policy
@geindex SCHED_RR scheduling policy
@@ -23930,7 +22536,7 @@ achieved by using the @code{--RTS} switch, e.g., @code{--RTS=sjlj}
@end menu
@node Choosing the Scheduling Policy,,,Specifying a Run-Time Library
-@anchor{gnat_ugn/platform_specific_information id5}@anchor{1d3}
+@anchor{gnat_ugn/platform_specific_information id5}@anchor{1ba}
@subsection Choosing the Scheduling Policy
@@ -23989,7 +22595,7 @@ Program_Error.
@geindex GNU/Linux
@node GNU/Linux Topics,Microsoft Windows Topics,Specifying a Run-Time Library,Platform-Specific Information
-@anchor{gnat_ugn/platform_specific_information id6}@anchor{1d4}@anchor{gnat_ugn/platform_specific_information gnu-linux-topics}@anchor{1d5}
+@anchor{gnat_ugn/platform_specific_information id6}@anchor{1bb}@anchor{gnat_ugn/platform_specific_information gnu-linux-topics}@anchor{1bc}
@section GNU/Linux Topics
@@ -24001,7 +22607,7 @@ This section describes topics that are specific to GNU/Linux platforms.
@end menu
@node Required Packages on GNU/Linux,,,GNU/Linux Topics
-@anchor{gnat_ugn/platform_specific_information id7}@anchor{1d6}@anchor{gnat_ugn/platform_specific_information required-packages-on-gnu-linux}@anchor{1d7}
+@anchor{gnat_ugn/platform_specific_information id7}@anchor{1bd}@anchor{gnat_ugn/platform_specific_information required-packages-on-gnu-linux}@anchor{1be}
@subsection Required Packages on GNU/Linux
@@ -24037,7 +22643,7 @@ for those packages.
@geindex Windows
@node Microsoft Windows Topics,Mac OS Topics,GNU/Linux Topics,Platform-Specific Information
-@anchor{gnat_ugn/platform_specific_information microsoft-windows-topics}@anchor{2c}@anchor{gnat_ugn/platform_specific_information id8}@anchor{1d8}
+@anchor{gnat_ugn/platform_specific_information microsoft-windows-topics}@anchor{1bf}@anchor{gnat_ugn/platform_specific_information id8}@anchor{1c0}
@section Microsoft Windows Topics
@@ -24058,7 +22664,7 @@ platforms.
@end menu
@node Using GNAT on Windows,Using a network installation of GNAT,,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information using-gnat-on-windows}@anchor{1d9}@anchor{gnat_ugn/platform_specific_information id9}@anchor{1da}
+@anchor{gnat_ugn/platform_specific_information using-gnat-on-windows}@anchor{1c1}@anchor{gnat_ugn/platform_specific_information id9}@anchor{1c2}
@subsection Using GNAT on Windows
@@ -24135,7 +22741,7 @@ uninstall or integrate different GNAT products.
@end itemize
@node Using a network installation of GNAT,CONSOLE and WINDOWS subsystems,Using GNAT on Windows,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information id10}@anchor{1db}@anchor{gnat_ugn/platform_specific_information using-a-network-installation-of-gnat}@anchor{1dc}
+@anchor{gnat_ugn/platform_specific_information id10}@anchor{1c3}@anchor{gnat_ugn/platform_specific_information using-a-network-installation-of-gnat}@anchor{1c4}
@subsection Using a network installation of GNAT
@@ -24162,7 +22768,7 @@ transfer of large amounts of data across the network and will likely cause
serious performance penalty.
@node CONSOLE and WINDOWS subsystems,Temporary Files,Using a network installation of GNAT,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information id11}@anchor{1dd}@anchor{gnat_ugn/platform_specific_information console-and-windows-subsystems}@anchor{1de}
+@anchor{gnat_ugn/platform_specific_information id11}@anchor{1c5}@anchor{gnat_ugn/platform_specific_information console-and-windows-subsystems}@anchor{1c6}
@subsection CONSOLE and WINDOWS subsystems
@@ -24187,7 +22793,7 @@ $ gnatmake winprog -largs -mwindows
@end quotation
@node Temporary Files,Disabling Command Line Argument Expansion,CONSOLE and WINDOWS subsystems,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information id12}@anchor{1df}@anchor{gnat_ugn/platform_specific_information temporary-files}@anchor{1e0}
+@anchor{gnat_ugn/platform_specific_information id12}@anchor{1c7}@anchor{gnat_ugn/platform_specific_information temporary-files}@anchor{1c8}
@subsection Temporary Files
@@ -24226,7 +22832,7 @@ environments where you may not have write access to some
directories.
@node Disabling Command Line Argument Expansion,Windows Socket Timeouts,Temporary Files,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information disabling-command-line-argument-expansion}@anchor{1e1}
+@anchor{gnat_ugn/platform_specific_information disabling-command-line-argument-expansion}@anchor{1c9}
@subsection Disabling Command Line Argument Expansion
@@ -24297,7 +22903,7 @@ Ada.Command_Line.Argument (1) -> "'*.txt'"
@end example
@node Windows Socket Timeouts,Mixed-Language Programming on Windows,Disabling Command Line Argument Expansion,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information windows-socket-timeouts}@anchor{1e2}
+@anchor{gnat_ugn/platform_specific_information windows-socket-timeouts}@anchor{1ca}
@subsection Windows Socket Timeouts
@@ -24343,7 +22949,7 @@ shorter than 500 ms is needed on these Windows versions, a call to
Check_Selector should be added before any socket read or write operations.
@node Mixed-Language Programming on Windows,Windows Specific Add-Ons,Windows Socket Timeouts,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information id13}@anchor{1e3}@anchor{gnat_ugn/platform_specific_information mixed-language-programming-on-windows}@anchor{1e4}
+@anchor{gnat_ugn/platform_specific_information id13}@anchor{1cb}@anchor{gnat_ugn/platform_specific_information mixed-language-programming-on-windows}@anchor{1cc}
@subsection Mixed-Language Programming on Windows
@@ -24365,17 +22971,17 @@ to use the Microsoft tools for your C++ code, you have two choices:
Encapsulate your C++ code in a DLL to be linked with your Ada
application. In this case, use the Microsoft or whatever environment to
build the DLL and use GNAT to build your executable
-(@ref{1e5,,Using DLLs with GNAT}).
+(@ref{1cd,,Using DLLs with GNAT}).
@item
Or you can encapsulate your Ada code in a DLL to be linked with the
other part of your application. In this case, use GNAT to build the DLL
-(@ref{1e6,,Building DLLs with GNAT Project files}) and use the Microsoft
+(@ref{1ce,,Building DLLs with GNAT Project files}) and use the Microsoft
or whatever environment to build your executable.
@end itemize
In addition to the description about C main in
-@ref{44,,Mixed Language Programming} section, if the C main uses a
+@ref{2c,,Mixed Language Programming} section, if the C main uses a
stand-alone library it is required on x86-windows to
setup the SEH context. For this the C main must looks like this:
@@ -24427,7 +23033,7 @@ native SEH support is used.
@end menu
@node Windows Calling Conventions,Introduction to Dynamic Link Libraries DLLs,,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information windows-calling-conventions}@anchor{1e7}@anchor{gnat_ugn/platform_specific_information id14}@anchor{1e8}
+@anchor{gnat_ugn/platform_specific_information windows-calling-conventions}@anchor{1cf}@anchor{gnat_ugn/platform_specific_information id14}@anchor{1d0}
@subsubsection Windows Calling Conventions
@@ -24472,7 +23078,7 @@ are available for Windows:
@end menu
@node C Calling Convention,Stdcall Calling Convention,,Windows Calling Conventions
-@anchor{gnat_ugn/platform_specific_information c-calling-convention}@anchor{1e9}@anchor{gnat_ugn/platform_specific_information id15}@anchor{1ea}
+@anchor{gnat_ugn/platform_specific_information c-calling-convention}@anchor{1d1}@anchor{gnat_ugn/platform_specific_information id15}@anchor{1d2}
@subsubsection @code{C} Calling Convention
@@ -24514,10 +23120,10 @@ is missing, as in the above example, this parameter is set to be the
When importing a variable defined in C, you should always use the @code{C}
calling convention unless the object containing the variable is part of a
DLL (in which case you should use the @code{Stdcall} calling
-convention, @ref{1eb,,Stdcall Calling Convention}).
+convention, @ref{1d3,,Stdcall Calling Convention}).
@node Stdcall Calling Convention,Win32 Calling Convention,C Calling Convention,Windows Calling Conventions
-@anchor{gnat_ugn/platform_specific_information stdcall-calling-convention}@anchor{1eb}@anchor{gnat_ugn/platform_specific_information id16}@anchor{1ec}
+@anchor{gnat_ugn/platform_specific_information stdcall-calling-convention}@anchor{1d3}@anchor{gnat_ugn/platform_specific_information id16}@anchor{1d4}
@subsubsection @code{Stdcall} Calling Convention
@@ -24614,7 +23220,7 @@ Note that to ease building cross-platform bindings this convention
will be handled as a @code{C} calling convention on non-Windows platforms.
@node Win32 Calling Convention,DLL Calling Convention,Stdcall Calling Convention,Windows Calling Conventions
-@anchor{gnat_ugn/platform_specific_information win32-calling-convention}@anchor{1ed}@anchor{gnat_ugn/platform_specific_information id17}@anchor{1ee}
+@anchor{gnat_ugn/platform_specific_information win32-calling-convention}@anchor{1d5}@anchor{gnat_ugn/platform_specific_information id17}@anchor{1d6}
@subsubsection @code{Win32} Calling Convention
@@ -24622,7 +23228,7 @@ This convention, which is GNAT-specific is fully equivalent to the
@code{Stdcall} calling convention described above.
@node DLL Calling Convention,,Win32 Calling Convention,Windows Calling Conventions
-@anchor{gnat_ugn/platform_specific_information id18}@anchor{1ef}@anchor{gnat_ugn/platform_specific_information dll-calling-convention}@anchor{1f0}
+@anchor{gnat_ugn/platform_specific_information id18}@anchor{1d7}@anchor{gnat_ugn/platform_specific_information dll-calling-convention}@anchor{1d8}
@subsubsection @code{DLL} Calling Convention
@@ -24630,7 +23236,7 @@ This convention, which is GNAT-specific is fully equivalent to the
@code{Stdcall} calling convention described above.
@node Introduction to Dynamic Link Libraries DLLs,Using DLLs with GNAT,Windows Calling Conventions,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id19}@anchor{1f1}@anchor{gnat_ugn/platform_specific_information introduction-to-dynamic-link-libraries-dlls}@anchor{1f2}
+@anchor{gnat_ugn/platform_specific_information id19}@anchor{1d9}@anchor{gnat_ugn/platform_specific_information introduction-to-dynamic-link-libraries-dlls}@anchor{1da}
@subsubsection Introduction to Dynamic Link Libraries (DLLs)
@@ -24714,10 +23320,10 @@ As a side note, an interesting difference between Microsoft DLLs and
Unix shared libraries, is the fact that on most Unix systems all public
routines are exported by default in a Unix shared library, while under
Windows it is possible (but not required) to list exported routines in
-a definition file (see @ref{1f3,,The Definition File}).
+a definition file (see @ref{1db,,The Definition File}).
@node Using DLLs with GNAT,Building DLLs with GNAT Project files,Introduction to Dynamic Link Libraries DLLs,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id20}@anchor{1f4}@anchor{gnat_ugn/platform_specific_information using-dlls-with-gnat}@anchor{1e5}
+@anchor{gnat_ugn/platform_specific_information id20}@anchor{1dc}@anchor{gnat_ugn/platform_specific_information using-dlls-with-gnat}@anchor{1cd}
@subsubsection Using DLLs with GNAT
@@ -24808,7 +23414,7 @@ example a fictitious DLL called @code{API.dll}.
@end menu
@node Creating an Ada Spec for the DLL Services,Creating an Import Library,,Using DLLs with GNAT
-@anchor{gnat_ugn/platform_specific_information id21}@anchor{1f5}@anchor{gnat_ugn/platform_specific_information creating-an-ada-spec-for-the-dll-services}@anchor{1f6}
+@anchor{gnat_ugn/platform_specific_information id21}@anchor{1dd}@anchor{gnat_ugn/platform_specific_information creating-an-ada-spec-for-the-dll-services}@anchor{1de}
@subsubsection Creating an Ada Spec for the DLL Services
@@ -24848,7 +23454,7 @@ end API;
@end quotation
@node Creating an Import Library,,Creating an Ada Spec for the DLL Services,Using DLLs with GNAT
-@anchor{gnat_ugn/platform_specific_information id22}@anchor{1f7}@anchor{gnat_ugn/platform_specific_information creating-an-import-library}@anchor{1f8}
+@anchor{gnat_ugn/platform_specific_information id22}@anchor{1df}@anchor{gnat_ugn/platform_specific_information creating-an-import-library}@anchor{1e0}
@subsubsection Creating an Import Library
@@ -24862,7 +23468,7 @@ as in this case it is possible to link directly against the
DLL. Otherwise read on.
@geindex Definition file
-@anchor{gnat_ugn/platform_specific_information the-definition-file}@anchor{1f3}
+@anchor{gnat_ugn/platform_specific_information the-definition-file}@anchor{1db}
@subsubheading The Definition File
@@ -24910,17 +23516,17 @@ EXPORTS
@end table
Note that you must specify the correct suffix (@code{@@@emph{nn}})
-(see @ref{1e7,,Windows Calling Conventions}) for a Stdcall
+(see @ref{1cf,,Windows Calling Conventions}) for a Stdcall
calling convention function in the exported symbols list.
There can actually be other sections in a definition file, but these
sections are not relevant to the discussion at hand.
-@anchor{gnat_ugn/platform_specific_information create-def-file-automatically}@anchor{1f9}
+@anchor{gnat_ugn/platform_specific_information create-def-file-automatically}@anchor{1e1}
@subsubheading Creating a Definition File Automatically
You can automatically create the definition file @code{API.def}
-(see @ref{1f3,,The Definition File}) from a DLL.
+(see @ref{1db,,The Definition File}) from a DLL.
For that use the @code{dlltool} program as follows:
@quotation
@@ -24930,7 +23536,7 @@ $ dlltool API.dll -z API.def --export-all-symbols
@end example
Note that if some routines in the DLL have the @code{Stdcall} convention
-(@ref{1e7,,Windows Calling Conventions}) with stripped @code{@@@emph{nn}}
+(@ref{1cf,,Windows Calling Conventions}) with stripped @code{@@@emph{nn}}
suffix then you'll have to edit @code{api.def} to add it, and specify
@code{-k} to @code{gnatdll} when creating the import library.
@@ -24954,13 +23560,13 @@ tells you what symbol is expected. You just have to go back to the
definition file and add the right suffix.
@end itemize
@end quotation
-@anchor{gnat_ugn/platform_specific_information gnat-style-import-library}@anchor{1fa}
+@anchor{gnat_ugn/platform_specific_information gnat-style-import-library}@anchor{1e2}
@subsubheading GNAT-Style Import Library
To create a static import library from @code{API.dll} with the GNAT tools
you should create the .def file, then use @code{gnatdll} tool
-(see @ref{1fb,,Using gnatdll}) as follows:
+(see @ref{1e3,,Using gnatdll}) as follows:
@quotation
@@ -24976,15 +23582,15 @@ definition file name is @code{xyz.def}, the import library name will
be @code{libxyz.a}. Note that in the previous example option
@code{-e} could have been removed because the name of the definition
file (before the @code{.def} suffix) is the same as the name of the
-DLL (@ref{1fb,,Using gnatdll} for more information about @code{gnatdll}).
+DLL (@ref{1e3,,Using gnatdll} for more information about @code{gnatdll}).
@end quotation
-@anchor{gnat_ugn/platform_specific_information msvs-style-import-library}@anchor{1fc}
+@anchor{gnat_ugn/platform_specific_information msvs-style-import-library}@anchor{1e4}
@subsubheading Microsoft-Style Import Library
A Microsoft import library is needed only if you plan to make an
Ada DLL available to applications developed with Microsoft
-tools (@ref{1e4,,Mixed-Language Programming on Windows}).
+tools (@ref{1cc,,Mixed-Language Programming on Windows}).
To create a Microsoft-style import library for @code{API.dll} you
should create the .def file, then build the actual import library using
@@ -25008,7 +23614,7 @@ See the Microsoft documentation for further details about the usage of
@end quotation
@node Building DLLs with GNAT Project files,Building DLLs with GNAT,Using DLLs with GNAT,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id23}@anchor{1fd}@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat-project-files}@anchor{1e6}
+@anchor{gnat_ugn/platform_specific_information id23}@anchor{1e5}@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat-project-files}@anchor{1ce}
@subsubsection Building DLLs with GNAT Project files
@@ -25024,7 +23630,7 @@ when inside the @code{DllMain} routine which is used for auto-initialization
of shared libraries, so it is not possible to have library level tasks in SALs.
@node Building DLLs with GNAT,Building DLLs with gnatdll,Building DLLs with GNAT Project files,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat}@anchor{1fe}@anchor{gnat_ugn/platform_specific_information id24}@anchor{1ff}
+@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat}@anchor{1e6}@anchor{gnat_ugn/platform_specific_information id24}@anchor{1e7}
@subsubsection Building DLLs with GNAT
@@ -25055,7 +23661,7 @@ $ gcc -shared -shared-libgcc -o api.dll obj1.o obj2.o ...
It is important to note that in this case all symbols found in the
object files are automatically exported. It is possible to restrict
the set of symbols to export by passing to @code{gcc} a definition
-file (see @ref{1f3,,The Definition File}).
+file (see @ref{1db,,The Definition File}).
For example:
@example
@@ -25093,7 +23699,7 @@ $ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI
@end quotation
@node Building DLLs with gnatdll,Ada DLLs and Finalization,Building DLLs with GNAT,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnatdll}@anchor{200}@anchor{gnat_ugn/platform_specific_information id25}@anchor{201}
+@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnatdll}@anchor{1e8}@anchor{gnat_ugn/platform_specific_information id25}@anchor{1e9}
@subsubsection Building DLLs with gnatdll
@@ -25101,8 +23707,8 @@ $ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI
@geindex building
Note that it is preferred to use GNAT Project files
-(@ref{1e6,,Building DLLs with GNAT Project files}) or the built-in GNAT
-DLL support (@ref{1fe,,Building DLLs with GNAT}) or to build DLLs.
+(@ref{1ce,,Building DLLs with GNAT Project files}) or the built-in GNAT
+DLL support (@ref{1e6,,Building DLLs with GNAT}) or to build DLLs.
This section explains how to build DLLs containing Ada code using
@code{gnatdll}. These DLLs will be referred to as Ada DLLs in the
@@ -25118,20 +23724,20 @@ non-Ada applications are as follows:
You need to mark each Ada entity exported by the DLL with a @code{C} or
@code{Stdcall} calling convention to avoid any Ada name mangling for the
entities exported by the DLL
-(see @ref{202,,Exporting Ada Entities}). You can
+(see @ref{1ea,,Exporting Ada Entities}). You can
skip this step if you plan to use the Ada DLL only from Ada applications.
@item
Your Ada code must export an initialization routine which calls the routine
@code{adainit} generated by @code{gnatbind} to perform the elaboration of
-the Ada code in the DLL (@ref{203,,Ada DLLs and Elaboration}). The initialization
+the Ada code in the DLL (@ref{1eb,,Ada DLLs and Elaboration}). The initialization
routine exported by the Ada DLL must be invoked by the clients of the DLL
to initialize the DLL.
@item
When useful, the DLL should also export a finalization routine which calls
routine @code{adafinal} generated by @code{gnatbind} to perform the
-finalization of the Ada code in the DLL (@ref{204,,Ada DLLs and Finalization}).
+finalization of the Ada code in the DLL (@ref{1ec,,Ada DLLs and Finalization}).
The finalization routine exported by the Ada DLL must be invoked by the
clients of the DLL when the DLL services are no further needed.
@@ -25141,11 +23747,11 @@ of the programming languages to which you plan to make the DLL available.
@item
You must provide a definition file listing the exported entities
-(@ref{1f3,,The Definition File}).
+(@ref{1db,,The Definition File}).
@item
Finally you must use @code{gnatdll} to produce the DLL and the import
-library (@ref{1fb,,Using gnatdll}).
+library (@ref{1e3,,Using gnatdll}).
@end itemize
Note that a relocatable DLL stripped using the @code{strip}
@@ -25165,7 +23771,7 @@ chapter of the @emph{GPRbuild User's Guide}.
@end menu
@node Limitations When Using Ada DLLs from Ada,Exporting Ada Entities,,Building DLLs with gnatdll
-@anchor{gnat_ugn/platform_specific_information limitations-when-using-ada-dlls-from-ada}@anchor{205}
+@anchor{gnat_ugn/platform_specific_information limitations-when-using-ada-dlls-from-ada}@anchor{1ed}
@subsubsection Limitations When Using Ada DLLs from Ada
@@ -25186,7 +23792,7 @@ It is completely safe to exchange plain elementary, array or record types,
Windows object handles, etc.
@node Exporting Ada Entities,Ada DLLs and Elaboration,Limitations When Using Ada DLLs from Ada,Building DLLs with gnatdll
-@anchor{gnat_ugn/platform_specific_information exporting-ada-entities}@anchor{202}@anchor{gnat_ugn/platform_specific_information id26}@anchor{206}
+@anchor{gnat_ugn/platform_specific_information exporting-ada-entities}@anchor{1ea}@anchor{gnat_ugn/platform_specific_information id26}@anchor{1ee}
@subsubsection Exporting Ada Entities
@@ -25286,10 +23892,10 @@ end API;
Note that if you do not export the Ada entities with a @code{C} or
@code{Stdcall} convention you will have to provide the mangled Ada names
in the definition file of the Ada DLL
-(@ref{207,,Creating the Definition File}).
+(@ref{1ef,,Creating the Definition File}).
@node Ada DLLs and Elaboration,,Exporting Ada Entities,Building DLLs with gnatdll
-@anchor{gnat_ugn/platform_specific_information ada-dlls-and-elaboration}@anchor{203}@anchor{gnat_ugn/platform_specific_information id27}@anchor{208}
+@anchor{gnat_ugn/platform_specific_information ada-dlls-and-elaboration}@anchor{1eb}@anchor{gnat_ugn/platform_specific_information id27}@anchor{1f0}
@subsubsection Ada DLLs and Elaboration
@@ -25304,10 +23910,10 @@ To achieve this you must export an initialization routine
(@code{Initialize_API} in the previous example), which must be invoked
before using any of the DLL services. This elaboration routine must call
the Ada elaboration routine @code{adainit} generated by the GNAT binder
-(@ref{b4,,Binding with Non-Ada Main Programs}). See the body of
+(@ref{a0,,Binding with Non-Ada Main Programs}). See the body of
@code{Initialize_Api} for an example. Note that the GNAT binder is
automatically invoked during the DLL build process by the @code{gnatdll}
-tool (@ref{1fb,,Using gnatdll}).
+tool (@ref{1e3,,Using gnatdll}).
When a DLL is loaded, Windows systematically invokes a routine called
@code{DllMain}. It would therefore be possible to call @code{adainit}
@@ -25320,7 +23926,7 @@ time), which means that the GNAT run-time will deadlock waiting for the
newly created task to complete its initialization.
@node Ada DLLs and Finalization,Creating a Spec for Ada DLLs,Building DLLs with gnatdll,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id28}@anchor{209}@anchor{gnat_ugn/platform_specific_information ada-dlls-and-finalization}@anchor{204}
+@anchor{gnat_ugn/platform_specific_information id28}@anchor{1f1}@anchor{gnat_ugn/platform_specific_information ada-dlls-and-finalization}@anchor{1ec}
@subsubsection Ada DLLs and Finalization
@@ -25331,14 +23937,14 @@ invoke the DLL finalization routine, if available. The DLL finalization
routine is in charge of releasing all resources acquired by the DLL. In the
case of the Ada code contained in the DLL, this is achieved by calling
routine @code{adafinal} generated by the GNAT binder
-(@ref{b4,,Binding with Non-Ada Main Programs}).
+(@ref{a0,,Binding with Non-Ada Main Programs}).
See the body of @code{Finalize_Api} for an
example. As already pointed out the GNAT binder is automatically invoked
during the DLL build process by the @code{gnatdll} tool
-(@ref{1fb,,Using gnatdll}).
+(@ref{1e3,,Using gnatdll}).
@node Creating a Spec for Ada DLLs,GNAT and Windows Resources,Ada DLLs and Finalization,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id29}@anchor{20a}@anchor{gnat_ugn/platform_specific_information creating-a-spec-for-ada-dlls}@anchor{20b}
+@anchor{gnat_ugn/platform_specific_information id29}@anchor{1f2}@anchor{gnat_ugn/platform_specific_information creating-a-spec-for-ada-dlls}@anchor{1f3}
@subsubsection Creating a Spec for Ada DLLs
@@ -25396,7 +24002,7 @@ end API;
@end menu
@node Creating the Definition File,Using gnatdll,,Creating a Spec for Ada DLLs
-@anchor{gnat_ugn/platform_specific_information creating-the-definition-file}@anchor{207}@anchor{gnat_ugn/platform_specific_information id30}@anchor{20c}
+@anchor{gnat_ugn/platform_specific_information creating-the-definition-file}@anchor{1ef}@anchor{gnat_ugn/platform_specific_information id30}@anchor{1f4}
@subsubsection Creating the Definition File
@@ -25432,7 +24038,7 @@ EXPORTS
@end quotation
@node Using gnatdll,,Creating the Definition File,Creating a Spec for Ada DLLs
-@anchor{gnat_ugn/platform_specific_information using-gnatdll}@anchor{1fb}@anchor{gnat_ugn/platform_specific_information id31}@anchor{20d}
+@anchor{gnat_ugn/platform_specific_information using-gnatdll}@anchor{1e3}@anchor{gnat_ugn/platform_specific_information id31}@anchor{1f5}
@subsubsection Using @code{gnatdll}
@@ -25530,7 +24136,7 @@ Help mode. Displays @code{gnatdll} switch usage information.
Direct @code{gnatdll} to search the @code{dir} directory for source and
object files needed to build the DLL.
-(@ref{89,,Search Paths and the Run-Time Library (RTL)}).
+(@ref{73,,Search Paths and the Run-Time Library (RTL)}).
@geindex -k (gnatdll)
@@ -25643,7 +24249,7 @@ asks @code{gnatlink} to generate the routines @code{DllMain} and
is loaded into memory.
@item
-@code{gnatdll} uses @code{dlltool} (see @ref{20e,,Using dlltool}) to build the
+@code{gnatdll} uses @code{dlltool} (see @ref{1f6,,Using dlltool}) to build the
export table (@code{api.exp}). The export table contains the relocation
information in a form which can be used during the final link to ensure
that the Windows loader is able to place the DLL anywhere in memory.
@@ -25682,7 +24288,7 @@ $ gnatbind -n api
$ gnatlink api api.exp -o api.dll -mdll
@end example
@end itemize
-@anchor{gnat_ugn/platform_specific_information using-dlltool}@anchor{20e}
+@anchor{gnat_ugn/platform_specific_information using-dlltool}@anchor{1f6}
@subsubheading Using @code{dlltool}
@@ -25741,7 +24347,7 @@ DLL in the static import library generated by @code{dlltool} with switch
@item @code{-k}
Kill @code{@@@emph{nn}} from exported names
-(@ref{1e7,,Windows Calling Conventions}
+(@ref{1cf,,Windows Calling Conventions}
for a discussion about @code{Stdcall}-style symbols.
@end table
@@ -25797,7 +24403,7 @@ Use @code{assembler-name} as the assembler. The default is @code{as}.
@end table
@node GNAT and Windows Resources,Using GNAT DLLs from Microsoft Visual Studio Applications,Creating a Spec for Ada DLLs,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information gnat-and-windows-resources}@anchor{20f}@anchor{gnat_ugn/platform_specific_information id32}@anchor{210}
+@anchor{gnat_ugn/platform_specific_information gnat-and-windows-resources}@anchor{1f7}@anchor{gnat_ugn/platform_specific_information id32}@anchor{1f8}
@subsubsection GNAT and Windows Resources
@@ -25892,7 +24498,7 @@ the corresponding Microsoft documentation.
@end menu
@node Building Resources,Compiling Resources,,GNAT and Windows Resources
-@anchor{gnat_ugn/platform_specific_information building-resources}@anchor{211}@anchor{gnat_ugn/platform_specific_information id33}@anchor{212}
+@anchor{gnat_ugn/platform_specific_information building-resources}@anchor{1f9}@anchor{gnat_ugn/platform_specific_information id33}@anchor{1fa}
@subsubsection Building Resources
@@ -25912,7 +24518,7 @@ complete description of the resource script language can be found in the
Microsoft documentation.
@node Compiling Resources,Using Resources,Building Resources,GNAT and Windows Resources
-@anchor{gnat_ugn/platform_specific_information compiling-resources}@anchor{213}@anchor{gnat_ugn/platform_specific_information id34}@anchor{214}
+@anchor{gnat_ugn/platform_specific_information compiling-resources}@anchor{1fb}@anchor{gnat_ugn/platform_specific_information id34}@anchor{1fc}
@subsubsection Compiling Resources
@@ -25954,7 +24560,7 @@ $ windres -i myres.res -o myres.o
@end quotation
@node Using Resources,,Compiling Resources,GNAT and Windows Resources
-@anchor{gnat_ugn/platform_specific_information using-resources}@anchor{215}@anchor{gnat_ugn/platform_specific_information id35}@anchor{216}
+@anchor{gnat_ugn/platform_specific_information using-resources}@anchor{1fd}@anchor{gnat_ugn/platform_specific_information id35}@anchor{1fe}
@subsubsection Using Resources
@@ -25974,7 +24580,7 @@ $ gnatmake myprog -largs myres.o
@end quotation
@node Using GNAT DLLs from Microsoft Visual Studio Applications,Debugging a DLL,GNAT and Windows Resources,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information using-gnat-dll-from-msvs}@anchor{217}@anchor{gnat_ugn/platform_specific_information using-gnat-dlls-from-microsoft-visual-studio-applications}@anchor{218}
+@anchor{gnat_ugn/platform_specific_information using-gnat-dll-from-msvs}@anchor{1ff}@anchor{gnat_ugn/platform_specific_information using-gnat-dlls-from-microsoft-visual-studio-applications}@anchor{200}
@subsubsection Using GNAT DLLs from Microsoft Visual Studio Applications
@@ -26008,7 +24614,7 @@ $ gprbuild -p mylib.gpr
@item
Produce a .def file for the symbols you need to interface with, either by
hand or automatically with possibly some manual adjustments
-(see @ref{1f9,,Creating Definition File Automatically}):
+(see @ref{1e1,,Creating Definition File Automatically}):
@end enumerate
@quotation
@@ -26025,7 +24631,7 @@ $ dlltool libmylib.dll -z libmylib.def --export-all-symbols
Make sure that MSVS command-line tools are accessible on the path.
@item
-Create the Microsoft-style import library (see @ref{1fc,,MSVS-Style Import Library}):
+Create the Microsoft-style import library (see @ref{1e4,,MSVS-Style Import Library}):
@end enumerate
@quotation
@@ -26067,7 +24673,7 @@ or copy the DLL into into the directory containing the .exe.
@end enumerate
@node Debugging a DLL,Setting Stack Size from gnatlink,Using GNAT DLLs from Microsoft Visual Studio Applications,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id36}@anchor{219}@anchor{gnat_ugn/platform_specific_information debugging-a-dll}@anchor{21a}
+@anchor{gnat_ugn/platform_specific_information id36}@anchor{201}@anchor{gnat_ugn/platform_specific_information debugging-a-dll}@anchor{202}
@subsubsection Debugging a DLL
@@ -26105,7 +24711,7 @@ tools suite used to build the DLL.
@end menu
@node Program and DLL Both Built with GCC/GNAT,Program Built with Foreign Tools and DLL Built with GCC/GNAT,,Debugging a DLL
-@anchor{gnat_ugn/platform_specific_information id37}@anchor{21b}@anchor{gnat_ugn/platform_specific_information program-and-dll-both-built-with-gcc-gnat}@anchor{21c}
+@anchor{gnat_ugn/platform_specific_information id37}@anchor{203}@anchor{gnat_ugn/platform_specific_information program-and-dll-both-built-with-gcc-gnat}@anchor{204}
@subsubsection Program and DLL Both Built with GCC/GNAT
@@ -26115,7 +24721,7 @@ the process. Let's suppose here that the main procedure is named
@code{ada_main} and that in the DLL there is an entry point named
@code{ada_dll}.
-The DLL (@ref{1f2,,Introduction to Dynamic Link Libraries (DLLs)}) and
+The DLL (@ref{1da,,Introduction to Dynamic Link Libraries (DLLs)}) and
program must have been built with the debugging information (see GNAT -g
switch). Here are the step-by-step instructions for debugging it:
@@ -26152,10 +24758,10 @@ Set a breakpoint inside the DLL
At this stage a breakpoint is set inside the DLL. From there on
you can use the standard approach to debug the whole program
-(@ref{24,,Running and Debugging Ada Programs}).
+(@ref{14d,,Running and Debugging Ada Programs}).
@node Program Built with Foreign Tools and DLL Built with GCC/GNAT,,Program and DLL Both Built with GCC/GNAT,Debugging a DLL
-@anchor{gnat_ugn/platform_specific_information program-built-with-foreign-tools-and-dll-built-with-gcc-gnat}@anchor{21d}@anchor{gnat_ugn/platform_specific_information id38}@anchor{21e}
+@anchor{gnat_ugn/platform_specific_information program-built-with-foreign-tools-and-dll-built-with-gcc-gnat}@anchor{205}@anchor{gnat_ugn/platform_specific_information id38}@anchor{206}
@subsubsection Program Built with Foreign Tools and DLL Built with GCC/GNAT
@@ -26172,7 +24778,7 @@ example some C code built with Microsoft Visual C) and that there is a
DLL named @code{test.dll} containing an Ada entry point named
@code{ada_dll}.
-The DLL (see @ref{1f2,,Introduction to Dynamic Link Libraries (DLLs)}) must have
+The DLL (see @ref{1da,,Introduction to Dynamic Link Libraries (DLLs)}) must have
been built with debugging information (see the GNAT @code{-g} option).
@subsubheading Debugging the DLL Directly
@@ -26238,7 +24844,7 @@ Continue the program.
This will run the program until it reaches the breakpoint that has been
set. From that point you can use the standard way to debug a program
-as described in (@ref{24,,Running and Debugging Ada Programs}).
+as described in (@ref{14d,,Running and Debugging Ada Programs}).
@end itemize
It is also possible to debug the DLL by attaching to a running process.
@@ -26308,10 +24914,10 @@ Continue process execution.
This last step will resume the process execution, and stop at
the breakpoint we have set. From there you can use the standard
approach to debug a program as described in
-@ref{24,,Running and Debugging Ada Programs}.
+@ref{14d,,Running and Debugging Ada Programs}.
@node Setting Stack Size from gnatlink,Setting Heap Size from gnatlink,Debugging a DLL,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information setting-stack-size-from-gnatlink}@anchor{136}@anchor{gnat_ugn/platform_specific_information id39}@anchor{21f}
+@anchor{gnat_ugn/platform_specific_information setting-stack-size-from-gnatlink}@anchor{127}@anchor{gnat_ugn/platform_specific_information id39}@anchor{207}
@subsubsection Setting Stack Size from @code{gnatlink}
@@ -26354,7 +24960,7 @@ because the comma is a separator for this option.
@end itemize
@node Setting Heap Size from gnatlink,,Setting Stack Size from gnatlink,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information setting-heap-size-from-gnatlink}@anchor{137}@anchor{gnat_ugn/platform_specific_information id40}@anchor{220}
+@anchor{gnat_ugn/platform_specific_information setting-heap-size-from-gnatlink}@anchor{128}@anchor{gnat_ugn/platform_specific_information id40}@anchor{208}
@subsubsection Setting Heap Size from @code{gnatlink}
@@ -26387,7 +24993,7 @@ because the comma is a separator for this option.
@end itemize
@node Windows Specific Add-Ons,,Mixed-Language Programming on Windows,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information windows-specific-add-ons}@anchor{221}@anchor{gnat_ugn/platform_specific_information win32-specific-addons}@anchor{222}
+@anchor{gnat_ugn/platform_specific_information windows-specific-add-ons}@anchor{209}@anchor{gnat_ugn/platform_specific_information win32-specific-addons}@anchor{20a}
@subsection Windows Specific Add-Ons
@@ -26400,7 +25006,7 @@ This section describes the Windows specific add-ons.
@end menu
@node Win32Ada,wPOSIX,,Windows Specific Add-Ons
-@anchor{gnat_ugn/platform_specific_information win32ada}@anchor{223}@anchor{gnat_ugn/platform_specific_information id41}@anchor{224}
+@anchor{gnat_ugn/platform_specific_information win32ada}@anchor{20b}@anchor{gnat_ugn/platform_specific_information id41}@anchor{20c}
@subsubsection Win32Ada
@@ -26431,7 +25037,7 @@ gprbuild p.gpr
@end quotation
@node wPOSIX,,Win32Ada,Windows Specific Add-Ons
-@anchor{gnat_ugn/platform_specific_information id42}@anchor{225}@anchor{gnat_ugn/platform_specific_information wposix}@anchor{226}
+@anchor{gnat_ugn/platform_specific_information id42}@anchor{20d}@anchor{gnat_ugn/platform_specific_information wposix}@anchor{20e}
@subsubsection wPOSIX
@@ -26464,7 +25070,7 @@ gprbuild p.gpr
@end quotation
@node Mac OS Topics,,Microsoft Windows Topics,Platform-Specific Information
-@anchor{gnat_ugn/platform_specific_information mac-os-topics}@anchor{2d}@anchor{gnat_ugn/platform_specific_information id43}@anchor{227}
+@anchor{gnat_ugn/platform_specific_information mac-os-topics}@anchor{20f}@anchor{gnat_ugn/platform_specific_information id43}@anchor{210}
@section Mac OS Topics
@@ -26479,7 +25085,7 @@ platform.
@end menu
@node Codesigning the Debugger,,,Mac OS Topics
-@anchor{gnat_ugn/platform_specific_information codesigning-the-debugger}@anchor{228}
+@anchor{gnat_ugn/platform_specific_information codesigning-the-debugger}@anchor{211}
@subsection Codesigning the Debugger
@@ -26560,7 +25166,7 @@ the location where you installed GNAT. Also, be sure that users are
in the Unix group @code{_developer}.
@node Example of Binder Output File,Elaboration Order Handling in GNAT,Platform-Specific Information,Top
-@anchor{gnat_ugn/example_of_binder_output example-of-binder-output-file}@anchor{e}@anchor{gnat_ugn/example_of_binder_output doc}@anchor{229}@anchor{gnat_ugn/example_of_binder_output id1}@anchor{22a}
+@anchor{gnat_ugn/example_of_binder_output example-of-binder-output-file}@anchor{e}@anchor{gnat_ugn/example_of_binder_output doc}@anchor{212}@anchor{gnat_ugn/example_of_binder_output id1}@anchor{213}
@chapter Example of Binder Output File
@@ -27312,7 +25918,7 @@ elaboration code in your own application).
@c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit
@node Elaboration Order Handling in GNAT,Inline Assembler,Example of Binder Output File,Top
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order-handling-in-gnat}@anchor{f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat doc}@anchor{22b}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id1}@anchor{22c}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order-handling-in-gnat}@anchor{f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat doc}@anchor{214}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id1}@anchor{215}
@chapter Elaboration Order Handling in GNAT
@@ -27342,7 +25948,7 @@ GNAT, either automatically or with explicit programming features.
@end menu
@node Elaboration Code,Elaboration Order,,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-code}@anchor{22d}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id2}@anchor{22e}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-code}@anchor{216}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id2}@anchor{217}
@section Elaboration Code
@@ -27490,7 +26096,7 @@ elaborated.
@end itemize
@node Elaboration Order,Checking the Elaboration Order,Elaboration Code,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order}@anchor{22f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{230}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order}@anchor{218}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{219}
@section Elaboration Order
@@ -27659,7 +26265,7 @@ however a compiler may not always find such an order due to complications with
respect to control and data flow.
@node Checking the Elaboration Order,Controlling the Elaboration Order in Ada,Elaboration Order,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{231}@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{232}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{21a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{21b}
@section Checking the Elaboration Order
@@ -27720,7 +26326,7 @@ order.
@end itemize
@node Controlling the Elaboration Order in Ada,Controlling the Elaboration Order in GNAT,Checking the Elaboration Order,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-ada}@anchor{233}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{234}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-ada}@anchor{21c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{21d}
@section Controlling the Elaboration Order in Ada
@@ -28048,7 +26654,7 @@ is that the program continues to stay in the last state (one or more correct
orders exist) even if maintenance changes the bodies of targets.
@node Controlling the Elaboration Order in GNAT,Mixing Elaboration Models,Controlling the Elaboration Order in Ada,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{235}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-gnat}@anchor{236}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{21e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-gnat}@anchor{21f}
@section Controlling the Elaboration Order in GNAT
@@ -28178,7 +26784,7 @@ The dynamic, legacy, and static models can be relaxed using compiler switch
may not diagnose certain elaboration issues or install run-time checks.
@node Mixing Elaboration Models,ABE Diagnostics,Controlling the Elaboration Order in GNAT,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{237}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{238}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{220}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{221}
@section Mixing Elaboration Models
@@ -28225,7 +26831,7 @@ warning: "y.ads" which has static elaboration checks
The warnings can be suppressed by binder switch @code{-ws}.
@node ABE Diagnostics,SPARK Diagnostics,Mixing Elaboration Models,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat abe-diagnostics}@anchor{239}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{23a}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat abe-diagnostics}@anchor{222}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{223}
@section ABE Diagnostics
@@ -28332,7 +26938,7 @@ declaration @code{Safe} because the body of function @code{ABE} has already been
elaborated at that point.
@node SPARK Diagnostics,Elaboration Circularities,ABE Diagnostics,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat spark-diagnostics}@anchor{23b}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{23c}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat spark-diagnostics}@anchor{224}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{225}
@section SPARK Diagnostics
@@ -28358,7 +26964,7 @@ rules.
@end quotation
@node Elaboration Circularities,Resolving Elaboration Circularities,SPARK Diagnostics,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{23d}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{23e}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{226}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{227}
@section Elaboration Circularities
@@ -28458,7 +27064,7 @@ This section enumerates various tactics for eliminating the circularity.
@end itemize
@node Resolving Elaboration Circularities,Elaboration-related Compiler Switches,Elaboration Circularities,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{23f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-elaboration-circularities}@anchor{240}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{228}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-elaboration-circularities}@anchor{229}
@section Resolving Elaboration Circularities
@@ -28729,7 +27335,7 @@ Use the relaxed dynamic-elaboration model, with compiler switches
@end itemize
@node Elaboration-related Compiler Switches,Summary of Procedures for Elaboration Control,Resolving Elaboration Circularities,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{241}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{242}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{22a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{22b}
@section Elaboration-related Compiler Switches
@@ -28910,7 +27516,7 @@ checks. The example above will still fail at run time with an ABE.
@end table
@node Summary of Procedures for Elaboration Control,Inspecting the Chosen Elaboration Order,Elaboration-related Compiler Switches,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{243}@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{244}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{22c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{22d}
@section Summary of Procedures for Elaboration Control
@@ -28968,7 +27574,7 @@ Use the relaxed dynamic elaboration model, with compiler switches
@end itemize
@node Inspecting the Chosen Elaboration Order,,Summary of Procedures for Elaboration Control,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{245}@anchor{gnat_ugn/elaboration_order_handling_in_gnat inspecting-the-chosen-elaboration-order}@anchor{246}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{22e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat inspecting-the-chosen-elaboration-order}@anchor{22f}
@section Inspecting the Chosen Elaboration Order
@@ -29111,7 +27717,7 @@ gdbstr (body)
@end quotation
@node Inline Assembler,GNU Free Documentation License,Elaboration Order Handling in GNAT,Top
-@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10}@anchor{gnat_ugn/inline_assembler doc}@anchor{247}@anchor{gnat_ugn/inline_assembler id1}@anchor{248}
+@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10}@anchor{gnat_ugn/inline_assembler doc}@anchor{230}@anchor{gnat_ugn/inline_assembler id1}@anchor{231}
@chapter Inline Assembler
@@ -29170,7 +27776,7 @@ and with assembly language programming.
@end menu
@node Basic Assembler Syntax,A Simple Example of Inline Assembler,,Inline Assembler
-@anchor{gnat_ugn/inline_assembler id2}@anchor{249}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{24a}
+@anchor{gnat_ugn/inline_assembler id2}@anchor{232}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{233}
@section Basic Assembler Syntax
@@ -29286,7 +27892,7 @@ Intel: Destination first; for example @code{mov eax, 4}@w{ }
@node A Simple Example of Inline Assembler,Output Variables in Inline Assembler,Basic Assembler Syntax,Inline Assembler
-@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{24b}@anchor{gnat_ugn/inline_assembler id3}@anchor{24c}
+@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{234}@anchor{gnat_ugn/inline_assembler id3}@anchor{235}
@section A Simple Example of Inline Assembler
@@ -29435,7 +28041,7 @@ If there are no errors, @code{as} will generate an object file
@code{nothing.out}.
@node Output Variables in Inline Assembler,Input Variables in Inline Assembler,A Simple Example of Inline Assembler,Inline Assembler
-@anchor{gnat_ugn/inline_assembler id4}@anchor{24d}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{24e}
+@anchor{gnat_ugn/inline_assembler id4}@anchor{236}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{237}
@section Output Variables in Inline Assembler
@@ -29802,7 +28408,7 @@ end Get_Flags_3;
@end quotation
@node Input Variables in Inline Assembler,Inlining Inline Assembler Code,Output Variables in Inline Assembler,Inline Assembler
-@anchor{gnat_ugn/inline_assembler id5}@anchor{24f}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{250}
+@anchor{gnat_ugn/inline_assembler id5}@anchor{238}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{239}
@section Input Variables in Inline Assembler
@@ -29891,7 +28497,7 @@ _increment__incr.1:
@end quotation
@node Inlining Inline Assembler Code,Other Asm Functionality,Input Variables in Inline Assembler,Inline Assembler
-@anchor{gnat_ugn/inline_assembler id6}@anchor{251}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{252}
+@anchor{gnat_ugn/inline_assembler id6}@anchor{23a}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{23b}
@section Inlining Inline Assembler Code
@@ -29962,7 +28568,7 @@ movl %esi,%eax
thus saving the overhead of stack frame setup and an out-of-line call.
@node Other Asm Functionality,,Inlining Inline Assembler Code,Inline Assembler
-@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{253}@anchor{gnat_ugn/inline_assembler id7}@anchor{254}
+@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{23c}@anchor{gnat_ugn/inline_assembler id7}@anchor{23d}
@section Other @code{Asm} Functionality
@@ -29977,7 +28583,7 @@ and @code{Volatile}, which inhibits unwanted optimizations.
@end menu
@node The Clobber Parameter,The Volatile Parameter,,Other Asm Functionality
-@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{255}@anchor{gnat_ugn/inline_assembler id8}@anchor{256}
+@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{23e}@anchor{gnat_ugn/inline_assembler id8}@anchor{23f}
@subsection The @code{Clobber} Parameter
@@ -30041,7 +28647,7 @@ Use 'register' name @code{memory} if you changed a memory location
@end itemize
@node The Volatile Parameter,,The Clobber Parameter,Other Asm Functionality
-@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{257}@anchor{gnat_ugn/inline_assembler id9}@anchor{258}
+@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{240}@anchor{gnat_ugn/inline_assembler id9}@anchor{241}
@subsection The @code{Volatile} Parameter
@@ -30077,7 +28683,7 @@ to @code{True} only if the compiler's optimizations have created
problems.
@node GNU Free Documentation License,Index,Inline Assembler,Top
-@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{259}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{25a}
+@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{242}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{243}
@chapter GNU Free Documentation License
@@ -30565,8 +29171,8 @@ to permit their use in free software.
@printindex ge
-@anchor{de}@w{ }
@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ }
+@anchor{cf}@w{ }
@c %**end of body
@bye
diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb
index a3b6a7e..be087af 100644
--- a/gcc/ada/gnatbind.adb
+++ b/gcc/ada/gnatbind.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -221,6 +221,9 @@ procedure Gnatbind is
No_Use_Of_Pragma => False,
-- Requires a parameter value, not a count
+ SPARK_05 => False,
+ -- Obsolete restriction
+
others => True);
Additional_Restrictions_Listed : Boolean := False;
@@ -235,8 +238,8 @@ procedure Gnatbind is
------------------------------
function Restriction_Could_Be_Set (R : Restriction_Id) return Boolean is
- CR : Restrictions_Info renames Cumulative_Restrictions;
-
+ CR : Restrictions_Info renames Cumulative_Restrictions;
+ Result : Boolean;
begin
case R is
@@ -244,11 +247,19 @@ procedure Gnatbind is
when All_Boolean_Restrictions =>
- -- The condition for listing a boolean restriction as an
- -- additional restriction that could be set is that it is
- -- not violated by any unit, and not already set.
+ -- Print it if not violated by any unit, and not already set...
- return CR.Violated (R) = False and then CR.Set (R) = False;
+ Result := not CR.Violated (R) and then not CR.Set (R);
+
+ -- ...except that for No_Tasks_Unassigned_To_CPU, we don't want
+ -- to print it if it would violate the restriction post
+ -- compilation.
+
+ if R = No_Tasks_Unassigned_To_CPU
+ and then ALIs.Table (ALIs.First).Main_CPU = No_Main_CPU
+ then
+ Result := False;
+ end if;
-- Parameter restriction
@@ -258,18 +269,18 @@ procedure Gnatbind is
-- unknown, the restriction can definitely not be listed.
if CR.Violated (R) and then CR.Unknown (R) then
- return False;
+ Result := False;
-- We can list the restriction if it is not set
elsif not CR.Set (R) then
- return True;
+ Result := True;
-- We can list the restriction if is set to a greater value
-- than the maximum value known for the violation.
else
- return CR.Value (R) > CR.Count (R);
+ Result := CR.Value (R) > CR.Count (R);
end if;
-- No other values for R possible
@@ -277,6 +288,8 @@ procedure Gnatbind is
when others =>
raise Program_Error;
end case;
+
+ return Result;
end Restriction_Could_Be_Set;
-- Start of processing for List_Applicable_Restrictions
@@ -496,6 +509,11 @@ procedure Gnatbind is
Opt.Bind_Alternate_Main_Name := True;
Opt.Alternate_Main_Name := new String'(Argv (3 .. Argv'Last));
+ -- -xdr
+
+ elsif Argv (2 .. Argv'Last) = "xdr" then
+ Opt.XDR_Stream := True;
+
-- All other options are single character and are handled by
-- Scan_Binder_Switches.
@@ -873,6 +891,17 @@ begin
-- mode where we want to be more flexible.
if not CodePeer_Mode then
+ -- AI12-0117-1, "Restriction No_Tasks_Unassigned_To_CPU":
+ -- If the restriction No_Tasks_Unassigned_To_CPU applies, then
+ -- check that the main subprogram has a CPU assigned.
+
+ if Cumulative_Restrictions.Set (No_Tasks_Unassigned_To_CPU)
+ and then ALIs.Table (ALIs.First).Main_CPU = No_Main_CPU
+ then
+ Error_Msg ("No_Tasks_Unassigned_To_CPU restriction requires CPU" &
+ " aspect to be specified for main procedure");
+ end if;
+
Check_Duplicated_Subunits;
Check_Versions;
Check_Consistency;
diff --git a/gcc/ada/gnatbind.ads b/gcc/ada/gnatbind.ads
index 5ce08f0..503ba33 100644
--- a/gcc/ada/gnatbind.ads
+++ b/gcc/ada/gnatbind.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatchop.adb b/gcc/ada/gnatchop.adb
index 3e58623..f98d93a 100644
--- a/gcc/ada/gnatchop.adb
+++ b/gcc/ada/gnatchop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatclean.adb b/gcc/ada/gnatclean.adb
index 5b1b8bb..1777967 100644
--- a/gcc/ada/gnatclean.adb
+++ b/gcc/ada/gnatclean.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb
index f83b0f2..4e644e3 100644
--- a/gcc/ada/gnatcmd.adb
+++ b/gcc/ada/gnatcmd.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatcmd.ads b/gcc/ada/gnatcmd.ads
index 755c656..0808fa1 100644
--- a/gcc/ada/gnatcmd.ads
+++ b/gcc/ada/gnatcmd.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatdll.adb b/gcc/ada/gnatdll.adb
index 562f642..2de9373 100644
--- a/gcc/ada/gnatdll.adb
+++ b/gcc/ada/gnatdll.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatfind.adb b/gcc/ada/gnatfind.adb
index d408fb0..27af4db 100644
--- a/gcc/ada/gnatfind.adb
+++ b/gcc/ada/gnatfind.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatkr.adb b/gcc/ada/gnatkr.adb
index a6073b3..5373248 100644
--- a/gcc/ada/gnatkr.adb
+++ b/gcc/ada/gnatkr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatkr.ads b/gcc/ada/gnatkr.ads
index 4294a1c..194ad27 100644
--- a/gcc/ada/gnatkr.ads
+++ b/gcc/ada/gnatkr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb
index 69462e9..def37f3 100644
--- a/gcc/ada/gnatlink.adb
+++ b/gcc/ada/gnatlink.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatlink.ads b/gcc/ada/gnatlink.ads
index f923685..ed6d513 100644
--- a/gcc/ada/gnatlink.ads
+++ b/gcc/ada/gnatlink.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb
index b5782aa..3fa00eb 100644
--- a/gcc/ada/gnatls.adb
+++ b/gcc/ada/gnatls.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatls.ads b/gcc/ada/gnatls.ads
index 72ca9f4..5afb1f5 100644
--- a/gcc/ada/gnatls.ads
+++ b/gcc/ada/gnatls.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatmake.adb b/gcc/ada/gnatmake.adb
index 06b0639..fe41ea1 100644
--- a/gcc/ada/gnatmake.adb
+++ b/gcc/ada/gnatmake.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatmake.ads b/gcc/ada/gnatmake.ads
index abadc62..a197de7 100644
--- a/gcc/ada/gnatmake.ads
+++ b/gcc/ada/gnatmake.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb
index cefc276..cf5afd9 100644
--- a/gcc/ada/gnatname.adb
+++ b/gcc/ada/gnatname.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -681,6 +681,8 @@ procedure Gnatname is
Sources.Last
loop
Current_Source := Sources.Table (Index);
+ pragma Annotate
+ (CodePeer, Modified, Current_Source);
if Opt.Verbose_Mode then
if Current_Source.Spec then
diff --git a/gcc/ada/gnatname.ads b/gcc/ada/gnatname.ads
index 20a139a..7cbcd3b 100644
--- a/gcc/ada/gnatname.ads
+++ b/gcc/ada/gnatname.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatprep.adb b/gcc/ada/gnatprep.adb
index b4c4bcd..926d148 100644
--- a/gcc/ada/gnatprep.adb
+++ b/gcc/ada/gnatprep.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatprep.ads b/gcc/ada/gnatprep.ads
index 10644dc..a2357d9 100644
--- a/gcc/ada/gnatprep.ads
+++ b/gcc/ada/gnatprep.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatvsn.adb b/gcc/ada/gnatvsn.adb
index 439bdf9..0e7486c 100644
--- a/gcc/ada/gnatvsn.adb
+++ b/gcc/ada/gnatvsn.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads
index f80d6ce..aacbc22 100644
--- a/gcc/ada/gnatvsn.ads
+++ b/gcc/ada/gnatvsn.ads
@@ -38,7 +38,7 @@ package Gnatvsn is
-- Static string identifying this version, that can be used as an argument
-- to e.g. pragma Ident.
- Library_Version : constant String := "10";
+ Library_Version : constant String := "11";
-- Library version. It needs to be updated whenever the major version
-- number is changed.
--
diff --git a/gcc/ada/gnatxref.adb b/gcc/ada/gnatxref.adb
index 96a2c72..7b7a4db 100644
--- a/gcc/ada/gnatxref.adb
+++ b/gcc/ada/gnatxref.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gprep.adb b/gcc/ada/gprep.adb
index 3e6b70d..5ad1094 100644
--- a/gcc/ada/gprep.adb
+++ b/gcc/ada/gprep.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gprep.ads b/gcc/ada/gprep.ads
index 88e8583..efc8c52 100644
--- a/gcc/ada/gprep.ads
+++ b/gcc/ada/gprep.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gsocket.h b/gcc/ada/gsocket.h
index 91a06b8..e10f954 100644
--- a/gcc/ada/gsocket.h
+++ b/gcc/ada/gsocket.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2004-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2004-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/hostparm.ads b/gcc/ada/hostparm.ads
index 98d5303..1b87a1d 100644
--- a/gcc/ada/hostparm.ads
+++ b/gcc/ada/hostparm.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb
index c53cdf9..2cfda7c 100644
--- a/gcc/ada/impunit.adb
+++ b/gcc/ada/impunit.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -181,6 +181,7 @@ package body Impunit is
("a-ssicst", F), -- Ada.Streams.Stream_IO.C_Streams
("a-suteio", F), -- Ada.Strings.Unbounded.Text_IO
("a-swuwti", F), -- Ada.Strings.Wide_Unbounded.Wide_Text_IO
+ ("a-tasini", F), -- Ada.Task_Initialization
("a-tiocst", F), -- Ada.Text_IO.C_Streams
("a-wtcstr", F), -- Ada.Wide_Text_IO.C_Streams
@@ -218,7 +219,6 @@ package body Impunit is
("a-tifiio", F), -- Ada.Text_IO.Fixed_IO
("a-tiflio", F), -- Ada.Text_IO.Float_IO
("a-tiinio", F), -- Ada.Text_IO.Integer_IO
- ("a-tiinio", F), -- Ada.Text_IO.Integer_IO
("a-timoio", F), -- Ada.Text_IO.Modular_IO
("a-wtdeio", F), -- Ada.Wide_Text_IO.Decimal_IO
("a-wtenio", F), -- Ada.Wide_Text_IO.Enumeration_IO
@@ -620,14 +620,25 @@ package body Impunit is
-- The following units should be used only in Ada 202X mode
Non_Imp_File_Names_2X : constant File_List := (
- ("a-stteou", T), -- Ada.Strings.Text_Output
("a-nubinu", T), -- Ada.Numerics.Big_Numbers
("a-nbnbin", T), -- Ada.Numerics.Big_Numbers.Big_Integers
("a-nbnbre", T), -- Ada.Numerics.Big_Numbers.Big_Reals
+ ("s-aoinar", T), -- System.Atomic_Operations.Integer_Arithmetic
+ ("s-aomoar", T), -- System.Atomic_Operations.Modular_Arithmetic
("s-aotase", T), -- System.Atomic_Operations.Test_And_Set
("s-atoope", T), -- System.Atomic_Operations
- ("s-atopar", T), -- System.Atomic_Operations.Arithmetic
- ("s-atopex", T)); -- System.Atomic_Operations.Exchange
+ ("s-atopex", T), -- System.Atomic_Operations.Exchange
+ ("a-stteou", T), -- Ada.Strings.Text_Output
+ ("a-stouut", T), -- Ada.Strings.Text_Output.Utils
+ ("a-stoubu", T), -- Ada.Strings.Text_Output.Buffers
+ ("a-stoufi", T), -- Ada.Strings.Text_Output.Files
+ ("a-stobfi", T), -- Ada.Strings.Text_Output.Basic_Files
+ ("a-stobbu", T), -- Ada.Strings.Text_Output.Bit_Buckets
+ ("a-stoufo", T), -- Ada.Strings.Text_Output.Formatting
+ ("a-strsto", T), -- Ada.Streams.Storage
+ ("a-ststbo", T), -- Ada.Streams.Storage.Bounded
+ ("a-ststun", T) -- Ada.Streams.Storage.Unbounded
+ );
-----------------------
-- Alternative Units --
diff --git a/gcc/ada/impunit.ads b/gcc/ada/impunit.ads
index 7e6ea61..7ed5c3a 100644
--- a/gcc/ada/impunit.ads
+++ b/gcc/ada/impunit.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/indepsw-aix.adb b/gcc/ada/indepsw-aix.adb
index f295f97..54c556d 100644
--- a/gcc/ada/indepsw-aix.adb
+++ b/gcc/ada/indepsw-aix.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- (AIX version) --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/indepsw-darwin.adb b/gcc/ada/indepsw-darwin.adb
index 3565185..3f2c41a 100644
--- a/gcc/ada/indepsw-darwin.adb
+++ b/gcc/ada/indepsw-darwin.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- (Darwin version) --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/indepsw-gnu.adb b/gcc/ada/indepsw-gnu.adb
index 65c0079..76138c4 100644
--- a/gcc/ada/indepsw-gnu.adb
+++ b/gcc/ada/indepsw-gnu.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- (GNU version) --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/indepsw.adb b/gcc/ada/indepsw.adb
index 1219dea..e35b3da 100644
--- a/gcc/ada/indepsw.adb
+++ b/gcc/ada/indepsw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/indepsw.ads b/gcc/ada/indepsw.ads
index 457cfed..4ac3fd8 100644
--- a/gcc/ada/indepsw.ads
+++ b/gcc/ada/indepsw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/init.c b/gcc/ada/init.c
index 67ea4dc..e76aa79 100644
--- a/gcc/ada/init.c
+++ b/gcc/ada/init.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -122,6 +122,7 @@ int __gl_default_stack_size = -1;
int __gl_leap_seconds_support = 0;
int __gl_canonical_streams = 0;
char *__gl_bind_env_addr = NULL;
+int __gl_xdr_stream = 0;
/* This value is not used anymore, but kept for bootstrapping purpose. */
int __gl_zero_cost_exceptions = 0;
diff --git a/gcc/ada/initialize.c b/gcc/ada/initialize.c
index 0e52feb..7235af8 100644
--- a/gcc/ada/initialize.c
+++ b/gcc/ada/initialize.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb
index c32c0c9..7293cf2 100644
--- a/gcc/ada/inline.adb
+++ b/gcc/ada/inline.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -47,6 +47,7 @@ with Sem_Ch8; use Sem_Ch8;
with Sem_Ch10; use Sem_Ch10;
with Sem_Ch12; use Sem_Ch12;
with Sem_Prag; use Sem_Prag;
+with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
@@ -265,6 +266,19 @@ package body Inline is
-- Make entry in Inlined table for subprogram E, or return table index
-- that already holds E.
+ procedure Establish_Actual_Mapping_For_Inlined_Call
+ (N : Node_Id;
+ Subp : Entity_Id;
+ Decls : List_Id;
+ Body_Or_Expr_To_Check : Node_Id);
+ -- Establish a mapping from formals to actuals in the call N for the target
+ -- subprogram Subp, and create temporaries or renamings when needed for the
+ -- actuals that are expressions (except for actuals given by simple entity
+ -- names or literals) or that are scalars that require copying to preserve
+ -- semantics. Any temporary objects that are created are inserted in Decls.
+ -- Body_Or_Expr_To_Check indicates the target body (or possibly expression
+ -- of an expression function), which may be traversed to count formal uses.
+
function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id;
pragma Inline (Get_Code_Unit_Entity);
-- Return the entity node for the unit containing E. Always return the spec
@@ -307,6 +321,10 @@ package body Inline is
-- Unmodified
-- Unreferenced
+ procedure Reset_Actual_Mapping_For_Inlined_Call (Subp : Entity_Id);
+ -- Reset the Renamed_Object flags on the formals of Subp, which can be set
+ -- by a call to Establish_Actual_Mapping_For_Inlined_Call.
+
------------------------------
-- Deferred Cleanup Actions --
------------------------------
@@ -852,7 +870,7 @@ package body Inline is
return;
end if;
- Elmt := Next_Elmt (Elmt);
+ Next_Elmt (Elmt);
end loop;
Append_Elmt (Scop, To_Clean);
@@ -2775,9 +2793,9 @@ package body Inline is
else
Decl := Unit_Declaration_Node (Scop);
- if Nkind_In (Decl, N_Subprogram_Declaration,
- N_Task_Type_Declaration,
- N_Subprogram_Body_Stub)
+ if Nkind (Decl) in N_Subprogram_Declaration
+ | N_Task_Type_Declaration
+ | N_Subprogram_Body_Stub
then
Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
end if;
@@ -2787,10 +2805,283 @@ package body Inline is
Expand_Cleanup_Actions (Decl);
End_Scope;
- Elmt := Next_Elmt (Elmt);
+ Next_Elmt (Elmt);
end loop;
end Cleanup_Scopes;
+ procedure Establish_Actual_Mapping_For_Inlined_Call
+ (N : Node_Id;
+ Subp : Entity_Id;
+ Decls : List_Id;
+ Body_Or_Expr_To_Check : Node_Id)
+ is
+
+ function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
+ -- Determine whether a formal parameter is used only once in
+ -- Body_Or_Expr_To_Check.
+
+ -------------------------
+ -- Formal_Is_Used_Once --
+ -------------------------
+
+ function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
+ Use_Counter : Int := 0;
+
+ function Count_Uses (N : Node_Id) return Traverse_Result;
+ -- Traverse the tree and count the uses of the formal parameter.
+ -- In this case, for optimization purposes, we do not need to
+ -- continue the traversal once more than one use is encountered.
+
+ ----------------
+ -- Count_Uses --
+ ----------------
+
+ function Count_Uses (N : Node_Id) return Traverse_Result is
+ begin
+ -- The original node is an identifier
+
+ if Nkind (N) = N_Identifier
+ and then Present (Entity (N))
+
+ -- Original node's entity points to the one in the copied body
+
+ and then Nkind (Entity (N)) = N_Identifier
+ and then Present (Entity (Entity (N)))
+
+ -- The entity of the copied node is the formal parameter
+
+ and then Entity (Entity (N)) = Formal
+ then
+ Use_Counter := Use_Counter + 1;
+
+ if Use_Counter > 1 then
+
+ -- Denote more than one use and abandon the traversal
+
+ Use_Counter := 2;
+ return Abandon;
+
+ end if;
+ end if;
+
+ return OK;
+ end Count_Uses;
+
+ procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
+
+ -- Start of processing for Formal_Is_Used_Once
+
+ begin
+ Count_Formal_Uses (Body_Or_Expr_To_Check);
+ return Use_Counter = 1;
+ end Formal_Is_Used_Once;
+
+ -- Local Data --
+
+ F : Entity_Id;
+ A : Node_Id;
+ Decl : Node_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ New_A : Node_Id;
+ Temp : Entity_Id;
+ Temp_Typ : Entity_Id;
+
+ -- Start of processing for Establish_Actual_Mapping_For_Inlined_Call
+
+ begin
+ F := First_Formal (Subp);
+ A := First_Actual (N);
+ while Present (F) loop
+ if Present (Renamed_Object (F)) then
+
+ -- If expander is active, it is an error to try to inline a
+ -- recursive program. In GNATprove mode, just indicate that the
+ -- inlining will not happen, and mark the subprogram as not always
+ -- inlined.
+
+ if GNATprove_Mode then
+ Cannot_Inline
+ ("cannot inline call to recursive subprogram?", N, Subp);
+ Set_Is_Inlined_Always (Subp, False);
+ else
+ Error_Msg_N
+ ("cannot inline call to recursive subprogram", N);
+ end if;
+
+ return;
+ end if;
+
+ -- Reset Last_Assignment for any parameters of mode out or in out, to
+ -- prevent spurious warnings about overwriting for assignments to the
+ -- formal in the inlined code.
+
+ if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then
+ Set_Last_Assignment (Entity (A), Empty);
+ end if;
+
+ -- If the argument may be a controlling argument in a call within
+ -- the inlined body, we must preserve its class-wide nature to ensure
+ -- that dynamic dispatching will take place subsequently. If the
+ -- formal has a constraint, then it must be preserved to retain the
+ -- semantics of the body.
+
+ if Is_Class_Wide_Type (Etype (F))
+ or else (Is_Access_Type (Etype (F))
+ and then Is_Class_Wide_Type (Designated_Type (Etype (F))))
+ then
+ Temp_Typ := Etype (F);
+
+ elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
+ and then Etype (F) /= Base_Type (Etype (F))
+ and then Is_Constrained (Etype (F))
+ then
+ Temp_Typ := Etype (F);
+
+ else
+ Temp_Typ := Etype (A);
+ end if;
+
+ -- If the actual is a simple name or a literal, no need to
+ -- create a temporary, object can be used directly.
+
+ -- If the actual is a literal and the formal has its address taken,
+ -- we cannot pass the literal itself as an argument, so its value
+ -- must be captured in a temporary. Skip this optimization in
+ -- GNATprove mode, to make sure any check on a type conversion
+ -- will be issued.
+
+ if (Is_Entity_Name (A)
+ and then
+ (not Is_Scalar_Type (Etype (A))
+ or else Ekind (Entity (A)) = E_Enumeration_Literal)
+ and then not GNATprove_Mode)
+
+ -- When the actual is an identifier and the corresponding formal is
+ -- used only once in the original body, the formal can be substituted
+ -- directly with the actual parameter. Skip this optimization in
+ -- GNATprove mode, to make sure any check on a type conversion
+ -- will be issued.
+
+ or else
+ (Nkind (A) = N_Identifier
+ and then Formal_Is_Used_Once (F)
+ and then not GNATprove_Mode)
+
+ or else
+ (Nkind (A) in
+ N_Real_Literal | N_Integer_Literal | N_Character_Literal
+ and then not Address_Taken (F))
+ then
+ if Etype (F) /= Etype (A) then
+ Set_Renamed_Object
+ (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
+ else
+ Set_Renamed_Object (F, A);
+ end if;
+
+ else
+ Temp := Make_Temporary (Loc, 'C');
+
+ -- If the actual for an in/in-out parameter is a view conversion,
+ -- make it into an unchecked conversion, given that an untagged
+ -- type conversion is not a proper object for a renaming.
+
+ -- In-out conversions that involve real conversions have already
+ -- been transformed in Expand_Actuals.
+
+ if Nkind (A) = N_Type_Conversion
+ and then Ekind (F) /= E_In_Parameter
+ then
+ New_A :=
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
+ Expression => Relocate_Node (Expression (A)));
+
+ -- In GNATprove mode, keep the most precise type of the actual for
+ -- the temporary variable, when the formal type is unconstrained.
+ -- Otherwise, the AST may contain unexpected assignment statements
+ -- to a temporary variable of unconstrained type renaming a local
+ -- variable of constrained type, which is not expected by
+ -- GNATprove.
+
+ elsif Etype (F) /= Etype (A)
+ and then (not GNATprove_Mode or else Is_Constrained (Etype (F)))
+ then
+ New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
+ Temp_Typ := Etype (F);
+
+ else
+ New_A := Relocate_Node (A);
+ end if;
+
+ Set_Sloc (New_A, Sloc (N));
+
+ -- If the actual has a by-reference type, it cannot be copied,
+ -- so its value is captured in a renaming declaration. Otherwise
+ -- declare a local constant initialized with the actual.
+
+ -- We also use a renaming declaration for expressions of an array
+ -- type that is not bit-packed, both for efficiency reasons and to
+ -- respect the semantics of the call: in most cases the original
+ -- call will pass the parameter by reference, and thus the inlined
+ -- code will have the same semantics.
+
+ -- Finally, we need a renaming declaration in the case of limited
+ -- types for which initialization cannot be by copy either.
+
+ if Ekind (F) = E_In_Parameter
+ and then not Is_By_Reference_Type (Etype (A))
+ and then not Is_Limited_Type (Etype (A))
+ and then
+ (not Is_Array_Type (Etype (A))
+ or else not Is_Object_Reference (A)
+ or else Is_Bit_Packed_Array (Etype (A)))
+ then
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
+ Expression => New_A);
+
+ else
+ -- In GNATprove mode, make an explicit copy of input
+ -- parameters when formal and actual types differ, to make
+ -- sure any check on the type conversion will be issued.
+ -- The legality of the copy is ensured by calling first
+ -- Call_Can_Be_Inlined_In_GNATprove_Mode.
+
+ if GNATprove_Mode
+ and then Ekind (F) /= E_Out_Parameter
+ and then not Same_Type (Etype (F), Etype (A))
+ then
+ pragma Assert (not Is_By_Reference_Type (Etype (A)));
+ pragma Assert (not Is_Limited_Type (Etype (A)));
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'C'),
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
+ Expression => New_Copy_Tree (New_A)));
+ end if;
+
+ Decl :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc),
+ Name => New_A);
+ end if;
+
+ Append (Decl, Decls);
+ Set_Renamed_Object (F, Temp);
+ end if;
+
+ Next_Formal (F);
+ Next_Actual (A);
+ end loop;
+ end Establish_Actual_Mapping_For_Inlined_Call;
+
-------------------------
-- Expand_Inlined_Call --
-------------------------
@@ -2816,15 +3107,11 @@ package body Inline is
Blk : Node_Id;
Decl : Node_Id;
Exit_Lab : Entity_Id := Empty;
- F : Entity_Id;
- A : Node_Id;
Lab_Decl : Node_Id := Empty;
Lab_Id : Node_Id;
- New_A : Node_Id;
Num_Ret : Nat := 0;
Ret_Type : Entity_Id;
Temp : Entity_Id;
- Temp_Typ : Entity_Id;
Is_Unc : Boolean;
Is_Unc_Decl : Boolean;
@@ -2890,9 +3177,6 @@ package body Inline is
-- If procedure body has no local variables, inline body without
-- creating block, otherwise rewrite call with block.
- function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
- -- Determine whether a formal parameter is used only once in Orig_Bod
-
-----------------------------------
-- Declare_Postconditions_Result --
-----------------------------------
@@ -3093,10 +3377,10 @@ package body Inline is
-- and string literals, and attributes that yield a universal
-- type, because those must be resolved to a specific type.
- if Nkind_In (Expression (N), N_Aggregate,
- N_Character_Literal,
- N_Null,
- N_String_Literal)
+ if Nkind (Expression (N)) in N_Aggregate
+ | N_Character_Literal
+ | N_Null
+ | N_String_Literal
or else Yields_Universal_Type (Expression (N))
then
Ret :=
@@ -3409,62 +3693,6 @@ package body Inline is
end if;
end Rewrite_Procedure_Call;
- -------------------------
- -- Formal_Is_Used_Once --
- -------------------------
-
- function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
- Use_Counter : Int := 0;
-
- function Count_Uses (N : Node_Id) return Traverse_Result;
- -- Traverse the tree and count the uses of the formal parameter.
- -- In this case, for optimization purposes, we do not need to
- -- continue the traversal once more than one use is encountered.
-
- ----------------
- -- Count_Uses --
- ----------------
-
- function Count_Uses (N : Node_Id) return Traverse_Result is
- begin
- -- The original node is an identifier
-
- if Nkind (N) = N_Identifier
- and then Present (Entity (N))
-
- -- Original node's entity points to the one in the copied body
-
- and then Nkind (Entity (N)) = N_Identifier
- and then Present (Entity (Entity (N)))
-
- -- The entity of the copied node is the formal parameter
-
- and then Entity (Entity (N)) = Formal
- then
- Use_Counter := Use_Counter + 1;
-
- if Use_Counter > 1 then
-
- -- Denote more than one use and abandon the traversal
-
- Use_Counter := 2;
- return Abandon;
-
- end if;
- end if;
-
- return OK;
- end Count_Uses;
-
- procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
-
- -- Start of processing for Formal_Is_Used_Once
-
- begin
- Count_Formal_Uses (Orig_Bod);
- return Use_Counter = 1;
- end Formal_Is_Used_Once;
-
-- Start of processing for Expand_Inlined_Call
begin
@@ -3694,198 +3922,7 @@ package body Inline is
-- Create temporaries for the actuals that are expressions, or that are
-- scalars and require copying to preserve semantics.
- F := First_Formal (Subp);
- A := First_Actual (N);
- while Present (F) loop
- if Present (Renamed_Object (F)) then
-
- -- If expander is active, it is an error to try to inline a
- -- recursive program. In GNATprove mode, just indicate that the
- -- inlining will not happen, and mark the subprogram as not always
- -- inlined.
-
- if GNATprove_Mode then
- Cannot_Inline
- ("cannot inline call to recursive subprogram?", N, Subp);
- Set_Is_Inlined_Always (Subp, False);
- else
- Error_Msg_N
- ("cannot inline call to recursive subprogram", N);
- end if;
-
- return;
- end if;
-
- -- Reset Last_Assignment for any parameters of mode out or in out, to
- -- prevent spurious warnings about overwriting for assignments to the
- -- formal in the inlined code.
-
- if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then
- Set_Last_Assignment (Entity (A), Empty);
- end if;
-
- -- If the argument may be a controlling argument in a call within
- -- the inlined body, we must preserve its classwide nature to insure
- -- that dynamic dispatching take place subsequently. If the formal
- -- has a constraint it must be preserved to retain the semantics of
- -- the body.
-
- if Is_Class_Wide_Type (Etype (F))
- or else (Is_Access_Type (Etype (F))
- and then Is_Class_Wide_Type (Designated_Type (Etype (F))))
- then
- Temp_Typ := Etype (F);
-
- elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
- and then Etype (F) /= Base_Type (Etype (F))
- and then Is_Constrained (Etype (F))
- then
- Temp_Typ := Etype (F);
-
- else
- Temp_Typ := Etype (A);
- end if;
-
- -- If the actual is a simple name or a literal, no need to
- -- create a temporary, object can be used directly.
-
- -- If the actual is a literal and the formal has its address taken,
- -- we cannot pass the literal itself as an argument, so its value
- -- must be captured in a temporary. Skip this optimization in
- -- GNATprove mode, to make sure any check on a type conversion
- -- will be issued.
-
- if (Is_Entity_Name (A)
- and then
- (not Is_Scalar_Type (Etype (A))
- or else Ekind (Entity (A)) = E_Enumeration_Literal)
- and then not GNATprove_Mode)
-
- -- When the actual is an identifier and the corresponding formal is
- -- used only once in the original body, the formal can be substituted
- -- directly with the actual parameter. Skip this optimization in
- -- GNATprove mode, to make sure any check on a type conversion
- -- will be issued.
-
- or else
- (Nkind (A) = N_Identifier
- and then Formal_Is_Used_Once (F)
- and then not GNATprove_Mode)
-
- or else
- (Nkind_In (A, N_Real_Literal,
- N_Integer_Literal,
- N_Character_Literal)
- and then not Address_Taken (F))
- then
- if Etype (F) /= Etype (A) then
- Set_Renamed_Object
- (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
- else
- Set_Renamed_Object (F, A);
- end if;
-
- else
- Temp := Make_Temporary (Loc, 'C');
-
- -- If the actual for an in/in-out parameter is a view conversion,
- -- make it into an unchecked conversion, given that an untagged
- -- type conversion is not a proper object for a renaming.
-
- -- In-out conversions that involve real conversions have already
- -- been transformed in Expand_Actuals.
-
- if Nkind (A) = N_Type_Conversion
- and then Ekind (F) /= E_In_Parameter
- then
- New_A :=
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
- Expression => Relocate_Node (Expression (A)));
-
- -- In GNATprove mode, keep the most precise type of the actual for
- -- the temporary variable, when the formal type is unconstrained.
- -- Otherwise, the AST may contain unexpected assignment statements
- -- to a temporary variable of unconstrained type renaming a local
- -- variable of constrained type, which is not expected by
- -- GNATprove.
-
- elsif Etype (F) /= Etype (A)
- and then (not GNATprove_Mode or else Is_Constrained (Etype (F)))
- then
- New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
- Temp_Typ := Etype (F);
-
- else
- New_A := Relocate_Node (A);
- end if;
-
- Set_Sloc (New_A, Sloc (N));
-
- -- If the actual has a by-reference type, it cannot be copied,
- -- so its value is captured in a renaming declaration. Otherwise
- -- declare a local constant initialized with the actual.
-
- -- We also use a renaming declaration for expressions of an array
- -- type that is not bit-packed, both for efficiency reasons and to
- -- respect the semantics of the call: in most cases the original
- -- call will pass the parameter by reference, and thus the inlined
- -- code will have the same semantics.
-
- -- Finally, we need a renaming declaration in the case of limited
- -- types for which initialization cannot be by copy either.
-
- if Ekind (F) = E_In_Parameter
- and then not Is_By_Reference_Type (Etype (A))
- and then not Is_Limited_Type (Etype (A))
- and then
- (not Is_Array_Type (Etype (A))
- or else not Is_Object_Reference (A)
- or else Is_Bit_Packed_Array (Etype (A)))
- then
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
- Expression => New_A);
-
- else
- -- In GNATprove mode, make an explicit copy of input
- -- parameters when formal and actual types differ, to make
- -- sure any check on the type conversion will be issued.
- -- The legality of the copy is ensured by calling first
- -- Call_Can_Be_Inlined_In_GNATprove_Mode.
-
- if GNATprove_Mode
- and then Ekind (F) /= E_Out_Parameter
- and then not Same_Type (Etype (F), Etype (A))
- then
- pragma Assert (not Is_By_Reference_Type (Etype (A)));
- pragma Assert (not Is_Limited_Type (Etype (A)));
-
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'C'),
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
- Expression => New_Copy_Tree (New_A)));
- end if;
-
- Decl :=
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Temp,
- Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc),
- Name => New_A);
- end if;
-
- Append (Decl, Decls);
- Set_Renamed_Object (F, Temp);
- end if;
-
- Next_Formal (F);
- Next_Actual (A);
- end loop;
+ Establish_Actual_Mapping_For_Inlined_Call (N, Subp, Decls, Orig_Bod);
-- Establish target of function call. If context is not assignment or
-- declaration, create a temporary as a target. The declaration for the
@@ -4103,7 +4140,15 @@ package body Inline is
Reset_Dispatching_Calls (Blk);
- Analyze (Blk, Suppress => All_Checks);
+ -- In GNATprove mode, always consider checks on, even for
+ -- predefined units.
+
+ if GNATprove_Mode then
+ Analyze (Blk);
+ else
+ Analyze (Blk, Suppress => All_Checks);
+ end if;
+
Style_Check := Style;
end;
@@ -4140,11 +4185,7 @@ package body Inline is
-- Cleanup mapping between formals and actuals for other expansions
- F := First_Formal (Subp);
- while Present (F) loop
- Set_Renamed_Object (F, Empty);
- Next_Formal (F);
- end loop;
+ Reset_Actual_Mapping_For_Inlined_Call (Subp);
end Expand_Inlined_Call;
--------------------------
@@ -4192,7 +4233,7 @@ package body Inline is
then
Conv := Current_Entity (Id);
- elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
+ elsif Nkind (Id) in N_Selected_Component | N_Expanded_Name
and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
then
Conv := Current_Entity (Selector_Name (Id));
@@ -4324,13 +4365,13 @@ package body Inline is
S := First (Stats);
while Present (S) loop
- if Nkind_In (S, N_Abort_Statement,
- N_Asynchronous_Select,
- N_Conditional_Entry_Call,
- N_Delay_Relative_Statement,
- N_Delay_Until_Statement,
- N_Selective_Accept,
- N_Timed_Entry_Call)
+ if Nkind (S) in N_Abort_Statement
+ | N_Asynchronous_Select
+ | N_Conditional_Entry_Call
+ | N_Delay_Relative_Statement
+ | N_Delay_Until_Statement
+ | N_Selective_Accept
+ | N_Timed_Entry_Call
then
Cannot_Inline
("cannot inline & (non-allowed statement)?", S, Subp);
@@ -4590,6 +4631,133 @@ package body Inline is
Backend_Not_Inlined_Subps := No_Elist;
end Initialize;
+ ---------------------------------
+ -- Inline_Static_Function_Call --
+ ---------------------------------
+
+ procedure Inline_Static_Function_Call (N : Node_Id; Subp : Entity_Id) is
+
+ function Replace_Formal (N : Node_Id) return Traverse_Result;
+ -- Replace each occurrence of a formal with the corresponding actual,
+ -- using the mapping created by Establish_Mapping_For_Inlined_Call.
+
+ function Reset_Sloc (Nod : Node_Id) return Traverse_Result;
+ -- Reset the Sloc of a node to that of the call itself, so that errors
+ -- will be flagged on the call to the static expression function itself
+ -- rather than on the expression of the function's declaration.
+
+ --------------------
+ -- Replace_Formal --
+ --------------------
+
+ function Replace_Formal (N : Node_Id) return Traverse_Result is
+ A : Entity_Id;
+ E : Entity_Id;
+
+ begin
+ if Is_Entity_Name (N) and then Present (Entity (N)) then
+ E := Entity (N);
+
+ if Is_Formal (E) and then Scope (E) = Subp then
+ A := Renamed_Object (E);
+
+ if Nkind (A) = N_Defining_Identifier then
+ Rewrite (N, New_Occurrence_Of (A, Sloc (N)));
+
+ -- Literal cases
+
+ else
+ Rewrite (N, New_Copy (A));
+ end if;
+ end if;
+
+ return Skip;
+
+ else
+ return OK;
+ end if;
+ end Replace_Formal;
+
+ procedure Replace_Formals is new Traverse_Proc (Replace_Formal);
+
+ ------------------
+ -- Process_Sloc --
+ ------------------
+
+ function Reset_Sloc (Nod : Node_Id) return Traverse_Result is
+ begin
+ Set_Sloc (Nod, Sloc (N));
+ Set_Comes_From_Source (Nod, False);
+
+ return OK;
+ end Reset_Sloc;
+
+ procedure Reset_Slocs is new Traverse_Proc (Reset_Sloc);
+
+ -- Start of processing for Inline_Static_Function_Call
+
+ begin
+ pragma Assert (Is_Static_Function_Call (N));
+
+ declare
+ Decls : constant List_Id := New_List;
+ Func_Expr : constant Node_Id :=
+ Expression_Of_Expression_Function (Subp);
+ Expr_Copy : constant Node_Id := New_Copy_Tree (Func_Expr);
+
+ begin
+ -- Create a mapping from formals to actuals, also creating temps in
+ -- Decls, when needed, to hold the actuals.
+
+ Establish_Actual_Mapping_For_Inlined_Call (N, Subp, Decls, Func_Expr);
+
+ -- Ensure that the copy has the same parent as the call (this seems
+ -- to matter when GNATprove_Mode is set and there are nested static
+ -- calls; prevents blowups in Insert_Actions, though it's not clear
+ -- exactly why this is needed???).
+
+ Set_Parent (Expr_Copy, Parent (N));
+
+ Insert_Actions (N, Decls);
+
+ -- Now substitute actuals for their corresponding formal references
+ -- within the expression.
+
+ Replace_Formals (Expr_Copy);
+
+ Reset_Slocs (Expr_Copy);
+
+ -- Apply a qualified expression with the function's result subtype,
+ -- to ensure that we check the expression against any constraint
+ -- or predicate, which will cause the call to be illegal if the
+ -- folded expression doesn't satisfy them. (The predicate case
+ -- might not get checked if the subtype hasn't been frozen yet,
+ -- which can happen if this static expression happens to be what
+ -- causes the freezing, because Has_Static_Predicate doesn't get
+ -- set on the subtype until it's frozen and Build_Predicates is
+ -- called. It's not clear how to address this case. ???)
+
+ Rewrite (Expr_Copy,
+ Make_Qualified_Expression (Sloc (Expr_Copy),
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (N), Sloc (Expr_Copy)),
+ Expression =>
+ Relocate_Node (Expr_Copy)));
+
+ Set_Etype (Expr_Copy, Etype (N));
+
+ Analyze_And_Resolve (Expr_Copy, Etype (N));
+
+ -- Finally rewrite the function call as the folded static result
+
+ Rewrite (N, Expr_Copy);
+
+ -- Cleanup mapping between formals and actuals for other expansions
+
+ Reset_Actual_Mapping_For_Inlined_Call (Subp);
+ end;
+ end Inline_Static_Function_Call;
+
------------------------
-- Instantiate_Bodies --
------------------------
@@ -4943,18 +5111,18 @@ package body Inline is
end if;
if Present (Item_Id)
- and then Nam_In (Chars (Item_Id), Name_Contract_Cases,
- Name_Global,
- Name_Depends,
- Name_Postcondition,
- Name_Precondition,
- Name_Refined_Global,
- Name_Refined_Depends,
- Name_Refined_Post,
- Name_Test_Case,
- Name_Unmodified,
- Name_Unreferenced,
- Name_Unused)
+ and then Chars (Item_Id) in Name_Contract_Cases
+ | Name_Global
+ | Name_Depends
+ | Name_Postcondition
+ | Name_Precondition
+ | Name_Refined_Global
+ | Name_Refined_Depends
+ | Name_Refined_Post
+ | Name_Test_Case
+ | Name_Unmodified
+ | Name_Unreferenced
+ | Name_Unused
then
Remove (Item);
end if;
@@ -4994,4 +5162,18 @@ package body Inline is
end loop;
end Remove_Dead_Instance;
+ -------------------------------------------
+ -- Reset_Actual_Mapping_For_Inlined_Call --
+ -------------------------------------------
+
+ procedure Reset_Actual_Mapping_For_Inlined_Call (Subp : Entity_Id) is
+ F : Entity_Id := First_Formal (Subp);
+
+ begin
+ while Present (F) loop
+ Set_Renamed_Object (F, Empty);
+ Next_Formal (F);
+ end loop;
+ end Reset_Actual_Mapping_For_Inlined_Call;
+
end Inline;
diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads
index ed342f5..51eab9c 100644
--- a/gcc/ada/inline.ads
+++ b/gcc/ada/inline.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -227,6 +227,12 @@ package Inline is
-- Check a list of statements, Stats, that make inlining of Subp not
-- worthwhile, including any tasking statement, nested at any level.
+ procedure Inline_Static_Function_Call
+ (N : Node_Id; Subp : Entity_Id);
+ -- Evaluate static call to a static function Subp, substituting actuals in
+ -- place of references to their corresponding formals and rewriting the
+ -- call N as a fully folded and static result expression.
+
procedure List_Inlining_Info;
-- Generate listing of calls inlined by the frontend plus listing of
-- calls to inline subprograms passed to the backend.
diff --git a/gcc/ada/itypes.adb b/gcc/ada/itypes.adb
index a084240..991824c 100644
--- a/gcc/ada/itypes.adb
+++ b/gcc/ada/itypes.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -24,7 +24,6 @@
------------------------------------------------------------------------------
with Atree; use Atree;
-with Opt; use Opt;
with Sem; use Sem;
with Sinfo; use Sinfo;
with Stand; use Stand;
@@ -70,9 +69,7 @@ package body Itypes is
Set_Is_Itype (Typ);
Set_Associated_Node_For_Itype (Typ, Related_Nod);
- if In_Deleted_Code
- and then not ASIS_Mode
- then
+ if In_Deleted_Code then
Set_Is_Frozen (Typ);
end if;
diff --git a/gcc/ada/itypes.ads b/gcc/ada/itypes.ads
index fac5363..36fe2b3 100644
--- a/gcc/ada/itypes.ads
+++ b/gcc/ada/itypes.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/krunch.adb b/gcc/ada/krunch.adb
index c9c77c7..ac9af73 100644
--- a/gcc/ada/krunch.adb
+++ b/gcc/ada/krunch.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/krunch.ads b/gcc/ada/krunch.ads
index 78f9eeb..42896b8 100644
--- a/gcc/ada/krunch.ads
+++ b/gcc/ada/krunch.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb
index ce2fe30..73812f6 100644
--- a/gcc/ada/layout.adb
+++ b/gcc/ada/layout.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -467,6 +467,22 @@ package body Layout is
end if;
end;
end if;
+
+ -- For non-packed arrays set the alignment of the array to the
+ -- alignment of the component type if it is unknown. Skip this
+ -- in atomic/VFA case since a larger alignment may be needed.
+
+ if Is_Array_Type (E)
+ and then not Is_Packed (E)
+ and then Unknown_Alignment (E)
+ and then Known_Alignment (Component_Type (E))
+ and then Known_Static_Component_Size (E)
+ and then Known_Static_Esize (Component_Type (E))
+ and then Component_Size (E) = Esize (Component_Type (E))
+ and then not Is_Atomic_Or_VFA (E)
+ then
+ Set_Alignment (E, Alignment (Component_Type (E)));
+ end if;
end if;
-- Even if the backend performs the layout, we still do a little in
diff --git a/gcc/ada/layout.ads b/gcc/ada/layout.ads
index 81162c1..f145082 100644
--- a/gcc/ada/layout.ads
+++ b/gcc/ada/layout.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/lib-list.adb b/gcc/ada/lib-list.adb
index 6fd3574..3eb5637 100644
--- a/gcc/ada/lib-list.adb
+++ b/gcc/ada/lib-list.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb
index 25c8794..2598285 100644
--- a/gcc/ada/lib-load.adb
+++ b/gcc/ada/lib-load.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/lib-load.ads b/gcc/ada/lib-load.ads
index f824765..c252f1f 100644
--- a/gcc/ada/lib-load.ads
+++ b/gcc/ada/lib-load.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/lib-sort.adb b/gcc/ada/lib-sort.adb
index d873b0c..dc51b64 100644
--- a/gcc/ada/lib-sort.adb
+++ b/gcc/ada/lib-sort.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/lib-util.adb b/gcc/ada/lib-util.adb
index e9c1e9c..a4772ab 100644
--- a/gcc/ada/lib-util.adb
+++ b/gcc/ada/lib-util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/lib-util.ads b/gcc/ada/lib-util.ads
index e0c7ced..9b29298 100644
--- a/gcc/ada/lib-util.ads
+++ b/gcc/ada/lib-util.ads
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb
index d877e7b..6fbcdce 100644
--- a/gcc/ada/lib-writ.adb
+++ b/gcc/ada/lib-writ.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -562,7 +562,7 @@ package body Lib.Writ is
Write_Info_Str (" O");
Write_Info_Char (OA_Setting (Unit_Num));
- if Ekind_In (Uent, E_Package, E_Package_Body)
+ if Ekind (Uent) in E_Package | E_Package_Body
and then Present (Finalizer (Uent))
then
Write_Info_Str (" PF");
@@ -1220,8 +1220,8 @@ package body Lib.Writ is
if Nkind (U) = N_Subprogram_Body
and then Present (Corresponding_Spec (U))
and then
- Ekind_In (Corresponding_Spec (U), E_Generic_Procedure,
- E_Generic_Function)
+ Ekind (Corresponding_Spec (U)) in E_Generic_Procedure
+ | E_Generic_Function
then
null;
diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads
index 5045b91..e7f2e3f 100644
--- a/gcc/ada/lib-writ.ads
+++ b/gcc/ada/lib-writ.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1051,7 +1051,7 @@ package Lib.Writ is
procedure Write_ALI (Object : Boolean);
-- This procedure writes the library information for the current main unit
-- The Object parameter is true if an object file is created, and false
- -- otherwise. Note that the pseudo-object file generated in GNATProve mode
+ -- otherwise. Note that the pseudo-object file generated in GNATprove mode
-- does count as an object file from this point of view.
--
-- Note: in the case where we are not generating code (-gnatc mode), this
diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb
index 0ad7044..269d8ee 100644
--- a/gcc/ada/lib-xref-spark_specific.adb
+++ b/gcc/ada/lib-xref-spark_specific.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -181,11 +181,11 @@ package body SPARK_Specific is
-- If N is the defining identifier for a subprogram, then return the
-- enclosing subprogram or package, not this subprogram.
- if Nkind_In (N, N_Defining_Identifier, N_Defining_Operator_Symbol)
- and then (Ekind (N) in Entry_Kind
- or else Ekind (N) = E_Subprogram_Body
- or else Ekind (N) in Generic_Subprogram_Kind
- or else Ekind (N) in Subprogram_Kind)
+ if Nkind (N) in N_Defining_Identifier | N_Defining_Operator_Symbol
+ and then Ekind (N) in Entry_Kind
+ | E_Subprogram_Body
+ | Generic_Subprogram_Kind
+ | Subprogram_Kind
then
Context := Parent (Unit_Declaration_Node (N));
@@ -291,10 +291,10 @@ package body SPARK_Specific is
procedure Create_Heap is
begin
- Name_Len := Name_Of_Heap_Variable'Length;
- Name_Buffer (1 .. Name_Len) := Name_Of_Heap_Variable;
-
- Heap := Make_Defining_Identifier (Standard_Location, Name_Enter);
+ Heap :=
+ Make_Defining_Identifier
+ (Standard_Location,
+ Name_Enter (Name_Of_Heap_Variable));
Set_Ekind (Heap, E_Variable);
Set_Is_Internal (Heap, True);
diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb
index 395b9a6..ae4b4c7 100644
--- a/gcc/ada/lib-xref.adb
+++ b/gcc/ada/lib-xref.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -569,10 +569,9 @@ package body Lib.Xref is
P := Parent (P);
if Nkind (P) = N_Pragma then
- if Nam_In (Pragma_Name_Unmapped (P),
- Name_Warnings,
- Name_Unmodified,
- Name_Unreferenced)
+ if Pragma_Name_Unmapped (P) in Name_Warnings
+ | Name_Unmodified
+ | Name_Unreferenced
then
return False;
end if;
@@ -596,7 +595,12 @@ package body Lib.Xref is
-- Start of processing for Generate_Reference
begin
- pragma Assert (Nkind (E) in N_Entity);
+ -- May happen in case of severe errors
+
+ if Nkind (E) not in N_Entity then
+ return;
+ end if;
+
Find_Actual (N, Formal, Call);
if Present (Formal) then
@@ -911,7 +915,7 @@ package body Lib.Xref is
-- since the attribute acts as an anonymous alias of the function
-- result and not as a real reference to the function.
- elsif Ekind_In (E, E_Function, E_Generic_Function)
+ elsif Ekind (E) in E_Function | E_Generic_Function
and then Is_Entity_Name (N)
and then Is_Attribute_Result (Parent (N))
then
@@ -1006,18 +1010,18 @@ package body Lib.Xref is
and then Typ /= ' '
then
- if Nkind_In (N, N_Identifier,
- N_Defining_Identifier,
- N_Defining_Operator_Symbol,
- N_Operator_Symbol,
- N_Defining_Character_Literal)
- or else Nkind (N) in N_Op
+ if Nkind (N) in N_Identifier
+ | N_Defining_Identifier
+ | N_Defining_Operator_Symbol
+ | N_Operator_Symbol
+ | N_Defining_Character_Literal
+ | N_Op
or else (Nkind (N) = N_Character_Literal
and then Sloc (Entity (N)) /= Standard_Location)
then
Nod := N;
- elsif Nkind_In (N, N_Expanded_Name, N_Selected_Component) then
+ elsif Nkind (N) in N_Expanded_Name | N_Selected_Component then
Nod := Selector_Name (N);
else
@@ -1135,7 +1139,7 @@ package body Lib.Xref is
-- reads/writes of private protected components) and not worth the
-- effort.
- if Ekind_In (Ent, E_Abstract_State, E_Constant, E_Variable)
+ if Ekind (Ent) in E_Abstract_State | E_Constant | E_Variable
and then Present (Encapsulating_State (Ent))
and then Is_Single_Concurrent_Object (Encapsulating_State (Ent))
then
@@ -1652,7 +1656,7 @@ package body Lib.Xref is
begin
-- Generate language name from convention
- if Conv = Convention_C then
+ if Conv = Convention_C or else Conv in Convention_C_Variadic then
Language_Name := Name_C;
elsif Conv = Convention_CPP then
@@ -2314,15 +2318,15 @@ package body Lib.Xref is
-- Special handling for access parameters and objects and
-- components of an anonymous access type.
- if Ekind_In (Etype (XE.Key.Ent),
- E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type)
+ if Ekind (Etype (XE.Key.Ent)) in
+ E_Anonymous_Access_Type
+ | E_Anonymous_Access_Subprogram_Type
+ | E_Anonymous_Access_Protected_Subprogram_Type
then
if Is_Formal (XE.Key.Ent)
or else
- Ekind_In
- (XE.Key.Ent, E_Variable, E_Constant, E_Component)
+ Ekind (XE.Key.Ent) in
+ E_Variable | E_Constant | E_Component
then
Ctyp := 'p';
end if;
diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads
index 2a29208..79dd57b 100644
--- a/gcc/ada/lib-xref.ads
+++ b/gcc/ada/lib-xref.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -514,7 +514,6 @@ package Lib.Xref is
E_Package_Body => ' ',
E_Protected_Body => ' ',
- E_Protected_Object => ' ',
E_Subprogram_Body => ' ',
E_Task_Body => ' ');
@@ -592,7 +591,7 @@ package Lib.Xref is
-- What we do in such cases is to gather nodes, where we would have liked
-- to call Generate_Reference but we couldn't because we didn't know enough
- -- into this table, Then we deal with generating references later on when
+ -- into this table, then we deal with generating references later on when
-- we have sufficient information to do it right.
type Deferred_Reference_Entry is record
diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb
index d04f0a4..806f939 100644
--- a/gcc/ada/lib.adb
+++ b/gcc/ada/lib.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -43,7 +43,6 @@ with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Stand; use Stand;
with Stringt; use Stringt;
-with Tree_IO; use Tree_IO;
with Uname; use Uname;
with Widechar; use Widechar;
@@ -363,6 +362,12 @@ package body Lib is
-- Step 2: Check subunits. If a subunit is instantiated, follow the
-- instantiation chain rather than the stub chain.
+ -- Note that we must handle the case where the subunit exists in the
+ -- same body as the main unit (which may happen when Naming gets
+ -- manually specified within a project file or through tools like
+ -- gprname). Otherwise, we will have an infinite loop jumping around
+ -- the same file.
+
Unit1 := Unit (Cunit (Unum1));
Unit2 := Unit (Cunit (Unum2));
Inst1 := Instantiation (Sind1);
@@ -385,21 +390,35 @@ package body Lib is
Length_Of_Name (Unit_Name (Unum2))
then
Sloc2 := Sloc (Corresponding_Stub (Unit2));
- Unum2 := Get_Source_Unit (Sloc2);
- goto Continue;
+ if Unum2 /= Get_Source_Unit (Sloc2) then
+ Unum2 := Get_Source_Unit (Sloc2);
+ goto Continue;
+ else
+ null; -- Unum2 already designates the correct unit
+ end if;
else
Sloc1 := Sloc (Corresponding_Stub (Unit1));
- Unum1 := Get_Source_Unit (Sloc1);
- goto Continue;
+
+ if Unum1 /= Get_Source_Unit (Sloc1) then
+ Unum1 := Get_Source_Unit (Sloc1);
+ goto Continue;
+ else
+ null; -- Unum1 already designates the correct unit
+ end if;
end if;
-- Sloc1 in subunit, Sloc2 not
else
Sloc1 := Sloc (Corresponding_Stub (Unit1));
- Unum1 := Get_Source_Unit (Sloc1);
- goto Continue;
+
+ if Unum1 /= Get_Source_Unit (Sloc1) then
+ Unum1 := Get_Source_Unit (Sloc1);
+ goto Continue;
+ else
+ null; -- Unum1 already designates the correct unit
+ end if;
end if;
-- Sloc2 in subunit, Sloc1 not
@@ -409,8 +428,13 @@ package body Lib is
and then Inst2 = No_Location
then
Sloc2 := Sloc (Corresponding_Stub (Unit2));
- Unum2 := Get_Source_Unit (Sloc2);
- goto Continue;
+
+ if Unum2 /= Get_Source_Unit (Sloc2) then
+ Unum2 := Get_Source_Unit (Sloc2);
+ goto Continue;
+ else
+ null; -- Unum2 already designates the correct unit
+ end if;
end if;
-- Step 3: Check instances. The two locations may yield a common
@@ -1254,50 +1278,6 @@ package body Lib is
TSN := TSN + 1;
end Synchronize_Serial_Number;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- N : Nat;
- S : String_Ptr;
-
- begin
- Units.Tree_Read;
-
- -- Read Compilation_Switches table. First release the memory occupied
- -- by the previously loaded switches.
-
- for J in Compilation_Switches.First .. Compilation_Switches.Last loop
- Free (Compilation_Switches.Table (J));
- end loop;
-
- Tree_Read_Int (N);
- Compilation_Switches.Set_Last (N);
-
- for J in 1 .. N loop
- Tree_Read_Str (S);
- Compilation_Switches.Table (J) := S;
- end loop;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Units.Tree_Write;
-
- -- Write Compilation_Switches table
-
- Tree_Write_Int (Compilation_Switches.Last);
-
- for J in 1 .. Compilation_Switches.Last loop
- Tree_Write_Str (Compilation_Switches.Table (J));
- end loop;
- end Tree_Write;
-
--------------------
-- Unit_Name_Hash --
--------------------
@@ -1380,7 +1360,7 @@ package body Lib is
and then (Nkind (Context_Item) /= N_With_Clause
or else Limited_Present (Context_Item))
loop
- Context_Item := Next (Context_Item);
+ Next (Context_Item);
end loop;
if Present (Context_Item) then
@@ -1404,7 +1384,7 @@ package body Lib is
Write_Eol;
end if;
- Context_Item := Next (Context_Item);
+ Next (Context_Item);
end loop;
Outdent;
diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads
index f20a18f..c4ace09 100644
--- a/gcc/ada/lib.ads
+++ b/gcc/ada/lib.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -537,7 +537,7 @@ package Lib is
function Get_Compilation_Switch (N : Pos) return String_Ptr;
-- Return the Nth stored compilation switch, or null if less than N
- -- switches have been stored. Used by ASIS and back ends written in Ada.
+ -- switches have been stored. Used by back ends written in Ada.
function Generic_May_Lack_ALI (Unum : Unit_Number_Type) return Boolean;
-- Generic units must be separately compiled. Since we always use
@@ -755,14 +755,6 @@ package Lib is
-- important to keep the serial numbers synchronized in the two cases (e.g.
-- when the references in a package and a client must be kept consistent).
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
procedure Unlock;
-- Unlock internal tables, in cases where the back end needs to modify them
@@ -998,12 +990,11 @@ private
-- The following table records the compilation switches used to compile
-- the main unit. The table includes only switches. It excludes -o
-- switches as well as artifacts of the gcc/gnat1 interface such as
- -- -quiet, -dumpbase, or -auxbase.
+ -- -quiet, or -dumpbase.
-- This table is set as part of the compiler argument scanning in
-- Back_End. It can also be reset in -gnatc mode from the data in an
- -- existing ali file, and is read and written by the Tree_Read and
- -- Tree_Write routines for ASIS.
+ -- existing ali file.
package Compilation_Switches is new Table.Table (
Table_Component_Type => String_Ptr,
diff --git a/gcc/ada/libgnarl/a-astaco.adb b/gcc/ada/libgnarl/a-astaco.adb
index 9409010..22ae7e2 100644
--- a/gcc/ada/libgnarl/a-astaco.adb
+++ b/gcc/ada/libgnarl/a-astaco.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-dispat.adb b/gcc/ada/libgnarl/a-dispat.adb
index 63ee7e4..9e9fb7e 100644
--- a/gcc/ada/libgnarl/a-dispat.adb
+++ b/gcc/ada/libgnarl/a-dispat.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2015-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-dynpri.adb b/gcc/ada/libgnarl/a-dynpri.adb
index 04a1752..a7e11f3 100644
--- a/gcc/ada/libgnarl/a-dynpri.adb
+++ b/gcc/ada/libgnarl/a-dynpri.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,7 +31,6 @@
with System.Task_Primitives.Operations;
with System.Tasking;
-with System.Parameters;
with System.Soft_Links;
with Ada.Unchecked_Conversion;
@@ -41,7 +40,6 @@ package body Ada.Dynamic_Priorities is
package STPO renames System.Task_Primitives.Operations;
package SSL renames System.Soft_Links;
- use System.Parameters;
use System.Tasking;
function Convert_Ids is new
@@ -103,10 +101,6 @@ package body Ada.Dynamic_Priorities is
SSL.Abort_Defer.all;
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Target);
Target.Common.Base_Priority := Priority;
@@ -141,10 +135,6 @@ package body Ada.Dynamic_Priorities is
STPO.Unlock (Target);
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
if STPO.Self = Target and then Yield_Needed then
-- Yield is needed to enforce FIFO task dispatching
diff --git a/gcc/ada/libgnarl/a-etgrbu.ads b/gcc/ada/libgnarl/a-etgrbu.ads
index c21b481..5d8b9e0 100644
--- a/gcc/ada/libgnarl/a-etgrbu.ads
+++ b/gcc/ada/libgnarl/a-etgrbu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2015-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnarl/a-exetim__darwin.adb b/gcc/ada/libgnarl/a-exetim__darwin.adb
index 9be150e..6e6176a 100644
--- a/gcc/ada/libgnarl/a-exetim__darwin.adb
+++ b/gcc/ada/libgnarl/a-exetim__darwin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-exetim__default.ads b/gcc/ada/libgnarl/a-exetim__default.ads
index 93bdcae4..4abe266 100644
--- a/gcc/ada/libgnarl/a-exetim__default.ads
+++ b/gcc/ada/libgnarl/a-exetim__default.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnarl/a-exetim__mingw.adb b/gcc/ada/libgnarl/a-exetim__mingw.adb
index 9886338..03b3468 100644
--- a/gcc/ada/libgnarl/a-exetim__mingw.adb
+++ b/gcc/ada/libgnarl/a-exetim__mingw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-exetim__mingw.ads b/gcc/ada/libgnarl/a-exetim__mingw.ads
index 3fe99d6..61a5f88 100644
--- a/gcc/ada/libgnarl/a-exetim__mingw.ads
+++ b/gcc/ada/libgnarl/a-exetim__mingw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnarl/a-exetim__posix.adb b/gcc/ada/libgnarl/a-exetim__posix.adb
index a914c96..0ba6742 100644
--- a/gcc/ada/libgnarl/a-exetim__posix.adb
+++ b/gcc/ada/libgnarl/a-exetim__posix.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-interr.adb b/gcc/ada/libgnarl/a-interr.adb
index fa8960e..4cbad55 100644
--- a/gcc/ada/libgnarl/a-interr.adb
+++ b/gcc/ada/libgnarl/a-interr.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-interr.ads b/gcc/ada/libgnarl/a-interr.ads
index fffee02..3fa18e2 100644
--- a/gcc/ada/libgnarl/a-interr.ads
+++ b/gcc/ada/libgnarl/a-interr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnarl/a-intnam.ads b/gcc/ada/libgnarl/a-intnam.ads
index ba9aeb2..f965f10 100644
--- a/gcc/ada/libgnarl/a-intnam.ads
+++ b/gcc/ada/libgnarl/a-intnam.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-intnam__aix.ads b/gcc/ada/libgnarl/a-intnam__aix.ads
index 9edd3f8..cb44dfb 100644
--- a/gcc/ada/libgnarl/a-intnam__aix.ads
+++ b/gcc/ada/libgnarl/a-intnam__aix.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-intnam__darwin.ads b/gcc/ada/libgnarl/a-intnam__darwin.ads
index aaee4e0..d28ac5e 100644
--- a/gcc/ada/libgnarl/a-intnam__darwin.ads
+++ b/gcc/ada/libgnarl/a-intnam__darwin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-intnam__dragonfly.ads b/gcc/ada/libgnarl/a-intnam__dragonfly.ads
index 6949b18..74b6938 100644
--- a/gcc/ada/libgnarl/a-intnam__dragonfly.ads
+++ b/gcc/ada/libgnarl/a-intnam__dragonfly.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-intnam__dummy.ads b/gcc/ada/libgnarl/a-intnam__dummy.ads
index 2c92fff..9fb30834 100644
--- a/gcc/ada/libgnarl/a-intnam__dummy.ads
+++ b/gcc/ada/libgnarl/a-intnam__dummy.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (No Tasking Version) --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-intnam__freebsd.ads b/gcc/ada/libgnarl/a-intnam__freebsd.ads
index b9eba20..c122735 100644
--- a/gcc/ada/libgnarl/a-intnam__freebsd.ads
+++ b/gcc/ada/libgnarl/a-intnam__freebsd.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-intnam__hpux.ads b/gcc/ada/libgnarl/a-intnam__hpux.ads
index e87e6ac..6485e71 100644
--- a/gcc/ada/libgnarl/a-intnam__hpux.ads
+++ b/gcc/ada/libgnarl/a-intnam__hpux.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-intnam__linux.ads b/gcc/ada/libgnarl/a-intnam__linux.ads
index ef81931..68fc6f1 100644
--- a/gcc/ada/libgnarl/a-intnam__linux.ads
+++ b/gcc/ada/libgnarl/a-intnam__linux.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-intnam__lynxos.ads b/gcc/ada/libgnarl/a-intnam__lynxos.ads
index c8e2701..5acd701 100644
--- a/gcc/ada/libgnarl/a-intnam__lynxos.ads
+++ b/gcc/ada/libgnarl/a-intnam__lynxos.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-intnam__mingw.ads b/gcc/ada/libgnarl/a-intnam__mingw.ads
index 93752c6..9267e00 100644
--- a/gcc/ada/libgnarl/a-intnam__mingw.ads
+++ b/gcc/ada/libgnarl/a-intnam__mingw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-intnam__qnx.ads b/gcc/ada/libgnarl/a-intnam__qnx.ads
index 32b097a..82825ca 100644
--- a/gcc/ada/libgnarl/a-intnam__qnx.ads
+++ b/gcc/ada/libgnarl/a-intnam__qnx.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-intnam__rtems.ads b/gcc/ada/libgnarl/a-intnam__rtems.ads
index 367d4b9..4012611 100644
--- a/gcc/ada/libgnarl/a-intnam__rtems.ads
+++ b/gcc/ada/libgnarl/a-intnam__rtems.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-intnam__solaris.ads b/gcc/ada/libgnarl/a-intnam__solaris.ads
index afafe1a..6a44f93 100644
--- a/gcc/ada/libgnarl/a-intnam__solaris.ads
+++ b/gcc/ada/libgnarl/a-intnam__solaris.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-intnam__vxworks.ads b/gcc/ada/libgnarl/a-intnam__vxworks.ads
index 07c5cf3..5876da1 100644
--- a/gcc/ada/libgnarl/a-intnam__vxworks.ads
+++ b/gcc/ada/libgnarl/a-intnam__vxworks.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-reatim.adb b/gcc/ada/libgnarl/a-reatim.adb
index beae5c6..2881752 100644
--- a/gcc/ada/libgnarl/a-reatim.adb
+++ b/gcc/ada/libgnarl/a-reatim.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-reatim.ads b/gcc/ada/libgnarl/a-reatim.ads
index f81a8a0..a390107 100644
--- a/gcc/ada/libgnarl/a-reatim.ads
+++ b/gcc/ada/libgnarl/a-reatim.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnarl/a-retide.adb b/gcc/ada/libgnarl/a-retide.adb
index bb644f0..1415556 100644
--- a/gcc/ada/libgnarl/a-retide.adb
+++ b/gcc/ada/libgnarl/a-retide.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-retide.ads b/gcc/ada/libgnarl/a-retide.ads
index 22c4573..4325b08 100644
--- a/gcc/ada/libgnarl/a-retide.ads
+++ b/gcc/ada/libgnarl/a-retide.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-rttiev.adb b/gcc/ada/libgnarl/a-rttiev.adb
index c2c251c..d049f16 100644
--- a/gcc/ada/libgnarl/a-rttiev.adb
+++ b/gcc/ada/libgnarl/a-rttiev.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-rttiev.ads b/gcc/ada/libgnarl/a-rttiev.ads
index aba32d7..905e0cf 100644
--- a/gcc/ada/libgnarl/a-rttiev.ads
+++ b/gcc/ada/libgnarl/a-rttiev.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnarl/a-synbar.adb b/gcc/ada/libgnarl/a-synbar.adb
index 1b5b4e8..df4f9f4 100644
--- a/gcc/ada/libgnarl/a-synbar.adb
+++ b/gcc/ada/libgnarl/a-synbar.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -33,7 +33,7 @@
-- --
------------------------------------------------------------------------------
-package body Ada.Synchronous_Barriers is
+package body Ada.Synchronous_Barriers with SPARK_Mode => Off is
protected body Synchronous_Barrier is
diff --git a/gcc/ada/libgnarl/a-synbar.ads b/gcc/ada/libgnarl/a-synbar.ads
index a49f982..c423695 100644
--- a/gcc/ada/libgnarl/a-synbar.ads
+++ b/gcc/ada/libgnarl/a-synbar.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -33,7 +33,7 @@
-- --
------------------------------------------------------------------------------
-package Ada.Synchronous_Barriers is
+package Ada.Synchronous_Barriers with SPARK_Mode => Off is
pragma Preelaborate (Synchronous_Barriers);
subtype Barrier_Limit is Positive range 1 .. Positive'Last;
diff --git a/gcc/ada/libgnarl/a-synbar__posix.adb b/gcc/ada/libgnarl/a-synbar__posix.adb
index 0900a86..96f4a7b 100644
--- a/gcc/ada/libgnarl/a-synbar__posix.adb
+++ b/gcc/ada/libgnarl/a-synbar__posix.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -37,7 +37,7 @@
with Interfaces.C; use Interfaces.C;
-package body Ada.Synchronous_Barriers is
+package body Ada.Synchronous_Barriers with SPARK_Mode => Off is
--------------------
-- POSIX barriers --
diff --git a/gcc/ada/libgnarl/a-synbar__posix.ads b/gcc/ada/libgnarl/a-synbar__posix.ads
index 5f36c4d..afbeb6b 100644
--- a/gcc/ada/libgnarl/a-synbar__posix.ads
+++ b/gcc/ada/libgnarl/a-synbar__posix.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -39,7 +39,7 @@ with System;
private with Ada.Finalization;
private with Interfaces.C;
-package Ada.Synchronous_Barriers is
+package Ada.Synchronous_Barriers with SPARK_Mode => Off is
pragma Preelaborate (Synchronous_Barriers);
subtype Barrier_Limit is Positive range 1 .. Positive'Last;
diff --git a/gcc/ada/libgnarl/a-sytaco.adb b/gcc/ada/libgnarl/a-sytaco.adb
index 2d0346b..94788d5 100644
--- a/gcc/ada/libgnarl/a-sytaco.adb
+++ b/gcc/ada/libgnarl/a-sytaco.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-sytaco.ads b/gcc/ada/libgnarl/a-sytaco.ads
index bd69478..906f60a 100644
--- a/gcc/ada/libgnarl/a-sytaco.ads
+++ b/gcc/ada/libgnarl/a-sytaco.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnarl/a-tasatt.adb b/gcc/ada/libgnarl/a-tasatt.adb
index e451c60..af9575f 100644
--- a/gcc/ada/libgnarl/a-tasatt.adb
+++ b/gcc/ada/libgnarl/a-tasatt.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/a-tasatt.ads b/gcc/ada/libgnarl/a-tasatt.ads
index 4a43dd6..e5394e1 100644
--- a/gcc/ada/libgnarl/a-tasatt.ads
+++ b/gcc/ada/libgnarl/a-tasatt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnarl/a-taside.adb b/gcc/ada/libgnarl/a-taside.adb
index 3a0a582..9df547f 100644
--- a/gcc/ada/libgnarl/a-taside.adb
+++ b/gcc/ada/libgnarl/a-taside.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,7 +30,6 @@
------------------------------------------------------------------------------
with System.Address_Image;
-with System.Parameters;
with System.Soft_Links;
with System.Task_Primitives;
with System.Task_Primitives.Operations;
@@ -48,9 +47,6 @@ pragma Warnings (On);
package body Ada.Task_Identification with
SPARK_Mode => Off
is
-
- use System.Parameters;
-
package STPO renames System.Task_Primitives.Operations;
-----------------------
@@ -165,20 +161,11 @@ is
raise Program_Error;
else
System.Soft_Links.Abort_Defer.all;
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Id);
Result := Id.Callable;
STPO.Unlock (Id);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
System.Soft_Links.Abort_Undefer.all;
+
return Result;
end if;
end Is_Callable;
@@ -198,20 +185,11 @@ is
raise Program_Error;
else
System.Soft_Links.Abort_Defer.all;
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Id);
Result := Id.Common.State = Terminated;
STPO.Unlock (Id);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
System.Soft_Links.Abort_Undefer.all;
+
return Result;
end if;
end Is_Terminated;
diff --git a/gcc/ada/libgnarl/a-taside.ads b/gcc/ada/libgnarl/a-taside.ads
index 6bdb252..537ea3e 100644
--- a/gcc/ada/libgnarl/a-taside.ads
+++ b/gcc/ada/libgnarl/a-taside.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnarl/a-tasini.adb b/gcc/ada/libgnarl/a-tasini.adb
new file mode 100644
index 0000000..b1f898f
--- /dev/null
+++ b/gcc/ada/libgnarl/a-tasini.adb
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . T A S K _ I N I T I A L I Z A T I O N --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Conversion;
+with System.Tasking;
+
+package body Ada.Task_Initialization is
+
+ function To_STIH is new Ada.Unchecked_Conversion
+ (Initialization_Handler, System.Tasking.Initialization_Handler);
+
+ --------------------------------
+ -- Set_Initialization_Handler --
+ --------------------------------
+
+ procedure Set_Initialization_Handler (Handler : Initialization_Handler) is
+ begin
+ System.Tasking.Global_Initialization_Handler := To_STIH (Handler);
+ end Set_Initialization_Handler;
+
+end Ada.Task_Initialization;
diff --git a/gcc/ada/libgnarl/a-tasini.ads b/gcc/ada/libgnarl/a-tasini.ads
new file mode 100644
index 0000000..867f8c5
--- /dev/null
+++ b/gcc/ada/libgnarl/a-tasini.ads
@@ -0,0 +1,42 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . T A S K _ I N I T I A L I Z A T I O N --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a way to set up a global initialization handler
+-- when tasks start.
+
+package Ada.Task_Initialization is
+ pragma Preelaborate (Task_Initialization);
+
+ type Initialization_Handler is access procedure;
+
+ procedure Set_Initialization_Handler (Handler : Initialization_Handler);
+ -- Set the global task initialization handler to Handler
+
+private
+ pragma Favor_Top_Level (Initialization_Handler);
+end Ada.Task_Initialization;
diff --git a/gcc/ada/libgnarl/a-taster.adb b/gcc/ada/libgnarl/a-taster.adb
index 1925e0f..fdf4811a 100644
--- a/gcc/ada/libgnarl/a-taster.adb
+++ b/gcc/ada/libgnarl/a-taster.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,7 +31,6 @@
with System.Tasking;
with System.Task_Primitives.Operations;
-with System.Parameters;
with System.Soft_Links;
with Ada.Unchecked_Conversion;
@@ -43,8 +42,6 @@ package body Ada.Task_Termination is
package STPO renames System.Task_Primitives.Operations;
package SSL renames System.Soft_Links;
- use System.Parameters;
-
-----------------------
-- Local subprograms --
-----------------------
@@ -82,21 +79,11 @@ package body Ada.Task_Termination is
begin
SSL.Abort_Defer.all;
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Self);
Self.Common.Fall_Back_Handler := To_ST (Handler);
STPO.Unlock (Self);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
SSL.Abort_Undefer.all;
end Set_Dependents_Fallback_Handler;
@@ -123,21 +110,11 @@ package body Ada.Task_Termination is
begin
SSL.Abort_Defer.all;
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Target);
Target.Common.Specific_Handler := To_ST (Handler);
STPO.Unlock (Target);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
SSL.Abort_Undefer.all;
end;
end if;
@@ -166,21 +143,11 @@ package body Ada.Task_Termination is
begin
SSL.Abort_Defer.all;
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Target);
TH := To_TT (Target.Common.Specific_Handler);
STPO.Unlock (Target);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
SSL.Abort_Undefer.all;
return TH;
diff --git a/gcc/ada/libgnarl/g-boubuf.adb b/gcc/ada/libgnarl/g-boubuf.adb
index dc4a8ec..f9c1850a 100644
--- a/gcc/ada/libgnarl/g-boubuf.adb
+++ b/gcc/ada/libgnarl/g-boubuf.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, AdaCore --
+-- Copyright (C) 2003-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/g-boubuf.ads b/gcc/ada/libgnarl/g-boubuf.ads
index f362baa..c648333 100644
--- a/gcc/ada/libgnarl/g-boubuf.ads
+++ b/gcc/ada/libgnarl/g-boubuf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2019, AdaCore --
+-- Copyright (C) 2003-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/g-boumai.ads b/gcc/ada/libgnarl/g-boumai.ads
index d509ed2..7a00ef3 100644
--- a/gcc/ada/libgnarl/g-boumai.ads
+++ b/gcc/ada/libgnarl/g-boumai.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2019, AdaCore --
+-- Copyright (C) 2003-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/g-semaph.adb b/gcc/ada/libgnarl/g-semaph.adb
index 6efa7f2..1b93985 100644
--- a/gcc/ada/libgnarl/g-semaph.adb
+++ b/gcc/ada/libgnarl/g-semaph.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, AdaCore --
+-- Copyright (C) 2003-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/g-semaph.ads b/gcc/ada/libgnarl/g-semaph.ads
index b7fbaa6..5de7eef 100644
--- a/gcc/ada/libgnarl/g-semaph.ads
+++ b/gcc/ada/libgnarl/g-semaph.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2019, AdaCore --
+-- Copyright (C) 2003-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/g-signal.adb b/gcc/ada/libgnarl/g-signal.adb
index 731ca90..f961486 100644
--- a/gcc/ada/libgnarl/g-signal.adb
+++ b/gcc/ada/libgnarl/g-signal.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/g-signal.ads b/gcc/ada/libgnarl/g-signal.ads
index ed72284..bb374e8 100644
--- a/gcc/ada/libgnarl/g-signal.ads
+++ b/gcc/ada/libgnarl/g-signal.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/g-tastus.ads b/gcc/ada/libgnarl/g-tastus.ads
index 003a1c1..e0475f7 100644
--- a/gcc/ada/libgnarl/g-tastus.ads
+++ b/gcc/ada/libgnarl/g-tastus.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/g-thread.adb b/gcc/ada/libgnarl/g-thread.adb
index ae61937..ff460d9 100644
--- a/gcc/ada/libgnarl/g-thread.adb
+++ b/gcc/ada/libgnarl/g-thread.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/g-thread.ads b/gcc/ada/libgnarl/g-thread.ads
index 8792e9a..9d15dce 100644
--- a/gcc/ada/libgnarl/g-thread.ads
+++ b/gcc/ada/libgnarl/g-thread.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/i-vxinco.adb b/gcc/ada/libgnarl/i-vxinco.adb
index d9f86b6..e722c4f 100644
--- a/gcc/ada/libgnarl/i-vxinco.adb
+++ b/gcc/ada/libgnarl/i-vxinco.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2016-2019, AdaCore --
+-- Copyright (C) 2016-2020, AdaCore --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/i-vxinco.ads b/gcc/ada/libgnarl/i-vxinco.ads
index dd324fa..73fd5da 100644
--- a/gcc/ada/libgnarl/i-vxinco.ads
+++ b/gcc/ada/libgnarl/i-vxinco.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2016-2019, AdaCore --
+-- Copyright (C) 2016-2020, AdaCore --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/libgnarl.gpr b/gcc/ada/libgnarl/libgnarl.gpr
new file mode 100644
index 0000000..3933f6f
--- /dev/null
+++ b/gcc/ada/libgnarl/libgnarl.gpr
@@ -0,0 +1,28 @@
+with "libgnat_common";
+
+library project Libgnarl is
+
+ for Languages use ("Ada", "C");
+ for Source_Dirs use (".");
+ for Source_List_File use "libgnarl.lst";
+ for Object_Dir use "../obj-" & Libgnat_Common.Library_Kind;
+
+ for Library_Name use "gnarl";
+ for Library_Dir use "../adalib";
+ for Library_Kind use Libgnat_Common.Library_Kind;
+
+ package Compiler is
+
+ for Switches ("C") use Libgnat_Common.C_Flags;
+ for Switches ("Ada") use Libgnat_Common.Ada_Flags;
+
+ for Switches ("s-tasdeb.adb") use
+ Libgnat_Common.Ada_Flags &
+ Libgnat_Common.Force_Debug &
+ Libgnat_Common.No_Opt;
+ -- Compile s-tasdeb.o without optimization and with debug info so that
+ -- it is always possible to set conditional breakpoints on tasks.
+
+ end Compiler;
+
+end Libgnarl;
diff --git a/gcc/ada/libgnarl/s-inmaop.ads b/gcc/ada/libgnarl/s-inmaop.ads
index c38903c..dc9be2d 100644
--- a/gcc/ada/libgnarl/s-inmaop.ads
+++ b/gcc/ada/libgnarl/s-inmaop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-inmaop__dummy.adb b/gcc/ada/libgnarl/s-inmaop__dummy.adb
index c16e1ce..96c8d10 100644
--- a/gcc/ada/libgnarl/s-inmaop__dummy.adb
+++ b/gcc/ada/libgnarl/s-inmaop__dummy.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-inmaop__posix.adb b/gcc/ada/libgnarl/s-inmaop__posix.adb
index 601e391..b538b69 100644
--- a/gcc/ada/libgnarl/s-inmaop__posix.adb
+++ b/gcc/ada/libgnarl/s-inmaop__posix.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-inmaop__vxworks.adb b/gcc/ada/libgnarl/s-inmaop__vxworks.adb
index 6827bb0..33c181f 100644
--- a/gcc/ada/libgnarl/s-inmaop__vxworks.adb
+++ b/gcc/ada/libgnarl/s-inmaop__vxworks.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-interr.adb b/gcc/ada/libgnarl/s-interr.adb
index bb5defd..c386c47 100644
--- a/gcc/ada/libgnarl/s-interr.adb
+++ b/gcc/ada/libgnarl/s-interr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1288,11 +1288,6 @@ package body System.Interrupts is
loop
System.Tasking.Initialization.Defer_Abort (Self_ID);
-
- if Single_Lock then
- POP.Lock_RTS;
- end if;
-
POP.Write_Lock (Self_ID);
if User_Handler (Interrupt).H = null
@@ -1327,10 +1322,6 @@ package body System.Interrupts is
Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag;
POP.Unlock (Self_ID);
- if Single_Lock then
- POP.Unlock_RTS;
- end if;
-
-- Avoid race condition when terminating application and
-- System.Parameters.No_Abort is True.
@@ -1347,18 +1338,9 @@ package body System.Interrupts is
-- Inform the Interrupt_Manager of wakeup from above sigwait
POP.Abort_Task (Interrupt_Manager_ID);
-
- if Single_Lock then
- POP.Lock_RTS;
- end if;
-
POP.Write_Lock (Self_ID);
else
- if Single_Lock then
- POP.Lock_RTS;
- end if;
-
POP.Write_Lock (Self_ID);
if Ret_Interrupt /= Interrupt then
@@ -1383,17 +1365,7 @@ package body System.Interrupts is
-- RTS calls should not be made with self being locked
POP.Unlock (Self_ID);
-
- if Single_Lock then
- POP.Unlock_RTS;
- end if;
-
Tmp_Handler.all;
-
- if Single_Lock then
- POP.Lock_RTS;
- end if;
-
POP.Write_Lock (Self_ID);
elsif User_Entry (Interrupt).T /= Null_Task then
@@ -1402,10 +1374,6 @@ package body System.Interrupts is
-- RTS calls should not be made with self being locked
- if Single_Lock then
- POP.Unlock_RTS;
- end if;
-
POP.Unlock (Self_ID);
System.Tasking.Rendezvous.Call_Simple
@@ -1413,10 +1381,6 @@ package body System.Interrupts is
POP.Write_Lock (Self_ID);
- if Single_Lock then
- POP.Lock_RTS;
- end if;
-
else
-- This is a situation that this task wakes up receiving
-- an Interrupt and before it gets the lock the Interrupt
@@ -1432,11 +1396,6 @@ package body System.Interrupts is
end if;
POP.Unlock (Self_ID);
-
- if Single_Lock then
- POP.Unlock_RTS;
- end if;
-
System.Tasking.Initialization.Undefer_Abort (Self_ID);
if Self_ID.Pending_Action then
diff --git a/gcc/ada/libgnarl/s-interr.ads b/gcc/ada/libgnarl/s-interr.ads
index 814ddb0..0f82beb 100644
--- a/gcc/ada/libgnarl/s-interr.ads
+++ b/gcc/ada/libgnarl/s-interr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-interr__dummy.adb b/gcc/ada/libgnarl/s-interr__dummy.adb
index 4e17569..ffa0710 100644
--- a/gcc/ada/libgnarl/s-interr__dummy.adb
+++ b/gcc/ada/libgnarl/s-interr__dummy.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-interr__hwint.adb b/gcc/ada/libgnarl/s-interr__hwint.adb
index ff7fe05..5c2c321 100644
--- a/gcc/ada/libgnarl/s-interr__hwint.adb
+++ b/gcc/ada/libgnarl/s-interr__hwint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-interr__sigaction.adb b/gcc/ada/libgnarl/s-interr__sigaction.adb
index d8fb7ba..83bd36c 100644
--- a/gcc/ada/libgnarl/s-interr__sigaction.adb
+++ b/gcc/ada/libgnarl/s-interr__sigaction.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,11 +42,9 @@ with System.Tasking.Utilities;
with System.Tasking.Rendezvous;
with System.Tasking.Initialization;
with System.Interrupt_Management;
-with System.Parameters;
package body System.Interrupts is
- use Parameters;
use Tasking;
use System.OS_Interface;
use Interfaces.C;
@@ -644,21 +642,11 @@ package body System.Interrupts is
end loop;
Initialization.Defer_Abort (Self_Id);
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Self_Id);
Self_Id.Common.State := Interrupt_Server_Idle_Sleep;
STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep);
Self_Id.Common.State := Runnable;
STPO.Unlock (Self_Id);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
Initialization.Undefer_Abort (Self_Id);
-- Undefer abort here to allow a window for this task to be aborted
diff --git a/gcc/ada/libgnarl/s-interr__vxworks.adb b/gcc/ada/libgnarl/s-interr__vxworks.adb
index 16d22a6..157f82f 100644
--- a/gcc/ada/libgnarl/s-interr__vxworks.adb
+++ b/gcc/ada/libgnarl/s-interr__vxworks.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-intman.ads b/gcc/ada/libgnarl/s-intman.ads
index 494d502..711ef9e 100644
--- a/gcc/ada/libgnarl/s-intman.ads
+++ b/gcc/ada/libgnarl/s-intman.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-intman__android.adb b/gcc/ada/libgnarl/s-intman__android.adb
index 9084a47..54c40d4 100644
--- a/gcc/ada/libgnarl/s-intman__android.adb
+++ b/gcc/ada/libgnarl/s-intman__android.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-intman__dummy.adb b/gcc/ada/libgnarl/s-intman__dummy.adb
index 5b9ff95..596cfe2 100644
--- a/gcc/ada/libgnarl/s-intman__dummy.adb
+++ b/gcc/ada/libgnarl/s-intman__dummy.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-intman__lynxos.adb b/gcc/ada/libgnarl/s-intman__lynxos.adb
index ef0c7ee..5f7d902 100644
--- a/gcc/ada/libgnarl/s-intman__lynxos.adb
+++ b/gcc/ada/libgnarl/s-intman__lynxos.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-intman__mingw.adb b/gcc/ada/libgnarl/s-intman__mingw.adb
index 4408c90..636927b 100644
--- a/gcc/ada/libgnarl/s-intman__mingw.adb
+++ b/gcc/ada/libgnarl/s-intman__mingw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-intman__posix.adb b/gcc/ada/libgnarl/s-intman__posix.adb
index 512e281..8ec5787 100644
--- a/gcc/ada/libgnarl/s-intman__posix.adb
+++ b/gcc/ada/libgnarl/s-intman__posix.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-intman__qnx.adb b/gcc/ada/libgnarl/s-intman__qnx.adb
index fc8c8fd..b4cae71 100644
--- a/gcc/ada/libgnarl/s-intman__qnx.adb
+++ b/gcc/ada/libgnarl/s-intman__qnx.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-intman__solaris.adb b/gcc/ada/libgnarl/s-intman__solaris.adb
index d62c87a..08a15c9 100644
--- a/gcc/ada/libgnarl/s-intman__solaris.adb
+++ b/gcc/ada/libgnarl/s-intman__solaris.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-intman__susv3.adb b/gcc/ada/libgnarl/s-intman__susv3.adb
index 6432456..d20aaa6 100644
--- a/gcc/ada/libgnarl/s-intman__susv3.adb
+++ b/gcc/ada/libgnarl/s-intman__susv3.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-intman__vxworks.adb b/gcc/ada/libgnarl/s-intman__vxworks.adb
index 853a4f8..21ce62f 100644
--- a/gcc/ada/libgnarl/s-intman__vxworks.adb
+++ b/gcc/ada/libgnarl/s-intman__vxworks.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-intman__vxworks.ads b/gcc/ada/libgnarl/s-intman__vxworks.ads
index c91fc0f..2e885be 100644
--- a/gcc/ada/libgnarl/s-intman__vxworks.ads
+++ b/gcc/ada/libgnarl/s-intman__vxworks.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-linux.ads b/gcc/ada/libgnarl/s-linux.ads
index 4220fa0..c06aebc 100644
--- a/gcc/ada/libgnarl/s-linux.ads
+++ b/gcc/ada/libgnarl/s-linux.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-linux__alpha.ads b/gcc/ada/libgnarl/s-linux__alpha.ads
index fea3746..7ce73ff 100644
--- a/gcc/ada/libgnarl/s-linux__alpha.ads
+++ b/gcc/ada/libgnarl/s-linux__alpha.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-linux__android.ads b/gcc/ada/libgnarl/s-linux__android.ads
index 8d8a1f4..108251c 100644
--- a/gcc/ada/libgnarl/s-linux__android.ads
+++ b/gcc/ada/libgnarl/s-linux__android.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-linux__hppa.ads b/gcc/ada/libgnarl/s-linux__hppa.ads
index feb21f6..7796c41 100644
--- a/gcc/ada/libgnarl/s-linux__hppa.ads
+++ b/gcc/ada/libgnarl/s-linux__hppa.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-linux__mips.ads b/gcc/ada/libgnarl/s-linux__mips.ads
index 6aea5a8..bc67c12 100644
--- a/gcc/ada/libgnarl/s-linux__mips.ads
+++ b/gcc/ada/libgnarl/s-linux__mips.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-linux__riscv.ads b/gcc/ada/libgnarl/s-linux__riscv.ads
index 61ccc3b..56f9db3 100644
--- a/gcc/ada/libgnarl/s-linux__riscv.ads
+++ b/gcc/ada/libgnarl/s-linux__riscv.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-linux__sparc.ads b/gcc/ada/libgnarl/s-linux__sparc.ads
index e619890..def0024 100644
--- a/gcc/ada/libgnarl/s-linux__sparc.ads
+++ b/gcc/ada/libgnarl/s-linux__sparc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-linux__x32.ads b/gcc/ada/libgnarl/s-linux__x32.ads
index fc79167..5e3b55d 100644
--- a/gcc/ada/libgnarl/s-linux__x32.ads
+++ b/gcc/ada/libgnarl/s-linux__x32.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2013-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2020, Free Software Foundation, Inc. --
--
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
diff --git a/gcc/ada/libgnarl/s-mudido.adb b/gcc/ada/libgnarl/s-mudido.adb
index ba06293..8796c08 100644
--- a/gcc/ada/libgnarl/s-mudido.adb
+++ b/gcc/ada/libgnarl/s-mudido.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-mudido__affinity.adb b/gcc/ada/libgnarl/s-mudido__affinity.adb
index 615b9b8..05f4a03 100644
--- a/gcc/ada/libgnarl/s-mudido__affinity.adb
+++ b/gcc/ada/libgnarl/s-mudido__affinity.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__aix.adb b/gcc/ada/libgnarl/s-osinte__aix.adb
index 5600afa..2370383 100644
--- a/gcc/ada/libgnarl/s-osinte__aix.adb
+++ b/gcc/ada/libgnarl/s-osinte__aix.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__aix.ads b/gcc/ada/libgnarl/s-osinte__aix.ads
index 63dfb1e..ac1b595 100644
--- a/gcc/ada/libgnarl/s-osinte__aix.ads
+++ b/gcc/ada/libgnarl/s-osinte__aix.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__android.adb b/gcc/ada/libgnarl/s-osinte__android.adb
index 50fa038..00f0d48 100644
--- a/gcc/ada/libgnarl/s-osinte__android.adb
+++ b/gcc/ada/libgnarl/s-osinte__android.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__android.ads b/gcc/ada/libgnarl/s-osinte__android.ads
index 3525e96..7b0b6b0 100644
--- a/gcc/ada/libgnarl/s-osinte__android.ads
+++ b/gcc/ada/libgnarl/s-osinte__android.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__darwin.adb b/gcc/ada/libgnarl/s-osinte__darwin.adb
index bfa52e5..877bcac 100644
--- a/gcc/ada/libgnarl/s-osinte__darwin.adb
+++ b/gcc/ada/libgnarl/s-osinte__darwin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__darwin.ads b/gcc/ada/libgnarl/s-osinte__darwin.ads
index c990bfc..0f2e52b 100644
--- a/gcc/ada/libgnarl/s-osinte__darwin.ads
+++ b/gcc/ada/libgnarl/s-osinte__darwin.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__dragonfly.adb b/gcc/ada/libgnarl/s-osinte__dragonfly.adb
index 843fa2c..f1c3599 100644
--- a/gcc/ada/libgnarl/s-osinte__dragonfly.adb
+++ b/gcc/ada/libgnarl/s-osinte__dragonfly.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__dragonfly.ads b/gcc/ada/libgnarl/s-osinte__dragonfly.ads
index f0b95b8..6b3b631 100644
--- a/gcc/ada/libgnarl/s-osinte__dragonfly.ads
+++ b/gcc/ada/libgnarl/s-osinte__dragonfly.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__dummy.ads b/gcc/ada/libgnarl/s-osinte__dummy.ads
index 3fcf140..0fbb816 100644
--- a/gcc/ada/libgnarl/s-osinte__dummy.ads
+++ b/gcc/ada/libgnarl/s-osinte__dummy.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__freebsd.adb b/gcc/ada/libgnarl/s-osinte__freebsd.adb
index 3108a45..728a723 100644
--- a/gcc/ada/libgnarl/s-osinte__freebsd.adb
+++ b/gcc/ada/libgnarl/s-osinte__freebsd.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__freebsd.ads b/gcc/ada/libgnarl/s-osinte__freebsd.ads
index 797043a..a8122de 100644
--- a/gcc/ada/libgnarl/s-osinte__freebsd.ads
+++ b/gcc/ada/libgnarl/s-osinte__freebsd.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__gnu.adb b/gcc/ada/libgnarl/s-osinte__gnu.adb
index 57b4685..8da6ce3 100644
--- a/gcc/ada/libgnarl/s-osinte__gnu.adb
+++ b/gcc/ada/libgnarl/s-osinte__gnu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2015-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__gnu.ads b/gcc/ada/libgnarl/s-osinte__gnu.ads
index 8656f62..1014cae 100644
--- a/gcc/ada/libgnarl/s-osinte__gnu.ads
+++ b/gcc/ada/libgnarl/s-osinte__gnu.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__hpux-dce.adb b/gcc/ada/libgnarl/s-osinte__hpux-dce.adb
index 2dc5336..06ec5e6 100644
--- a/gcc/ada/libgnarl/s-osinte__hpux-dce.adb
+++ b/gcc/ada/libgnarl/s-osinte__hpux-dce.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__hpux-dce.ads b/gcc/ada/libgnarl/s-osinte__hpux-dce.ads
index 076b7eb..c439f00 100644
--- a/gcc/ada/libgnarl/s-osinte__hpux-dce.ads
+++ b/gcc/ada/libgnarl/s-osinte__hpux-dce.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__hpux.ads b/gcc/ada/libgnarl/s-osinte__hpux.ads
index 6c9b624..954b409 100644
--- a/gcc/ada/libgnarl/s-osinte__hpux.ads
+++ b/gcc/ada/libgnarl/s-osinte__hpux.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads b/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads
index aa6c1a8..36003eb 100644
--- a/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads
+++ b/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__linux.ads b/gcc/ada/libgnarl/s-osinte__linux.ads
index 80cb2b2..f7af00b 100644
--- a/gcc/ada/libgnarl/s-osinte__linux.ads
+++ b/gcc/ada/libgnarl/s-osinte__linux.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -278,9 +278,9 @@ package System.OS_Interface is
PR_GET_NAME : constant := 16;
function prctl
- (option : int;
- arg2, arg3, arg4, arg5 : unsigned_long := 0) return int;
- pragma Import (C, prctl);
+ (option : int;
+ arg : unsigned_long) return int;
+ pragma Import (C_Variadic_1, prctl, "prctl");
-------------
-- Threads --
@@ -314,6 +314,8 @@ package System.OS_Interface is
-- Stack --
-----------
+ subtype char_array is Interfaces.C.char_array;
+
type stack_t is record
ss_sp : System.Address;
ss_flags : int;
@@ -326,13 +328,13 @@ package System.OS_Interface is
oss : access stack_t) return int;
pragma Import (C, sigaltstack, "sigaltstack");
- Alternate_Stack : aliased System.Address;
- pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
- -- The alternate signal stack for stack overflows
-
Alternate_Stack_Size : constant := 16 * 1024;
-- This must be in keeping with init.c:__gnat_alternate_stack
+ Alternate_Stack : aliased char_array (1 .. Alternate_Stack_Size);
+ pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
+ -- The alternate signal stack for stack overflows
+
function Get_Stack_Base (thread : pthread_t) return Address;
pragma Inline (Get_Stack_Base);
-- This is a dummy procedure to share some GNULLI files
@@ -634,8 +636,6 @@ private
type pid_t is new int;
- subtype char_array is Interfaces.C.char_array;
-
type pthread_attr_t is record
Data : char_array (1 .. OS_Constants.PTHREAD_ATTR_SIZE);
end record;
diff --git a/gcc/ada/libgnarl/s-osinte__lynxos178.adb b/gcc/ada/libgnarl/s-osinte__lynxos178.adb
index 3e84e32..08ed178 100644
--- a/gcc/ada/libgnarl/s-osinte__lynxos178.adb
+++ b/gcc/ada/libgnarl/s-osinte__lynxos178.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__lynxos178e.ads b/gcc/ada/libgnarl/s-osinte__lynxos178e.ads
index 6e95059..646d301 100644
--- a/gcc/ada/libgnarl/s-osinte__lynxos178e.ads
+++ b/gcc/ada/libgnarl/s-osinte__lynxos178e.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__mingw.ads b/gcc/ada/libgnarl/s-osinte__mingw.ads
index 2a98664..11c5776 100644
--- a/gcc/ada/libgnarl/s-osinte__mingw.ads
+++ b/gcc/ada/libgnarl/s-osinte__mingw.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__posix.adb b/gcc/ada/libgnarl/s-osinte__posix.adb
index bfbd2b8..5ff7ae7 100644
--- a/gcc/ada/libgnarl/s-osinte__posix.adb
+++ b/gcc/ada/libgnarl/s-osinte__posix.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__qnx.adb b/gcc/ada/libgnarl/s-osinte__qnx.adb
index c101424..b02bc83 100644
--- a/gcc/ada/libgnarl/s-osinte__qnx.adb
+++ b/gcc/ada/libgnarl/s-osinte__qnx.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__qnx.ads b/gcc/ada/libgnarl/s-osinte__qnx.ads
index a592a0e..1855d3c 100644
--- a/gcc/ada/libgnarl/s-osinte__qnx.ads
+++ b/gcc/ada/libgnarl/s-osinte__qnx.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__rtems.adb b/gcc/ada/libgnarl/s-osinte__rtems.adb
index c839515..bfa5cc5 100644
--- a/gcc/ada/libgnarl/s-osinte__rtems.adb
+++ b/gcc/ada/libgnarl/s-osinte__rtems.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__rtems.ads b/gcc/ada/libgnarl/s-osinte__rtems.ads
index 751dabb..05a0c9e 100644
--- a/gcc/ada/libgnarl/s-osinte__rtems.ads
+++ b/gcc/ada/libgnarl/s-osinte__rtems.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__solaris.adb b/gcc/ada/libgnarl/s-osinte__solaris.adb
index ceb82f4..e3bb41e 100644
--- a/gcc/ada/libgnarl/s-osinte__solaris.adb
+++ b/gcc/ada/libgnarl/s-osinte__solaris.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__solaris.ads b/gcc/ada/libgnarl/s-osinte__solaris.ads
index be242ba..b3faa10 100644
--- a/gcc/ada/libgnarl/s-osinte__solaris.ads
+++ b/gcc/ada/libgnarl/s-osinte__solaris.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__vxworks.adb b/gcc/ada/libgnarl/s-osinte__vxworks.adb
index b8612a4..d9de575 100644
--- a/gcc/ada/libgnarl/s-osinte__vxworks.adb
+++ b/gcc/ada/libgnarl/s-osinte__vxworks.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__vxworks.ads b/gcc/ada/libgnarl/s-osinte__vxworks.ads
index dfffac4..3b39bce 100644
--- a/gcc/ada/libgnarl/s-osinte__vxworks.ads
+++ b/gcc/ada/libgnarl/s-osinte__vxworks.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-osinte__x32.adb b/gcc/ada/libgnarl/s-osinte__x32.adb
index ebc771d..80f7825 100644
--- a/gcc/ada/libgnarl/s-osinte__x32.adb
+++ b/gcc/ada/libgnarl/s-osinte__x32.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-proinf.adb b/gcc/ada/libgnarl/s-proinf.adb
index eacd1f9..216ee42 100644
--- a/gcc/ada/libgnarl/s-proinf.adb
+++ b/gcc/ada/libgnarl/s-proinf.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-proinf.ads b/gcc/ada/libgnarl/s-proinf.ads
index 44a9579..0248cb7 100644
--- a/gcc/ada/libgnarl/s-proinf.ads
+++ b/gcc/ada/libgnarl/s-proinf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-qnx.ads b/gcc/ada/libgnarl/s-qnx.ads
index 9943d76..00c4a7d 100644
--- a/gcc/ada/libgnarl/s-qnx.ads
+++ b/gcc/ada/libgnarl/s-qnx.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2017-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2017-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-solita.adb b/gcc/ada/libgnarl/s-solita.adb
index 8b9d052..bdd5f9c 100644
--- a/gcc/ada/libgnarl/s-solita.adb
+++ b/gcc/ada/libgnarl/s-solita.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-solita.ads b/gcc/ada/libgnarl/s-solita.ads
index f502962..51dc585 100644
--- a/gcc/ada/libgnarl/s-solita.ads
+++ b/gcc/ada/libgnarl/s-solita.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-stusta.adb b/gcc/ada/libgnarl/s-stusta.adb
index ee8cb96..80be087 100644
--- a/gcc/ada/libgnarl/s-stusta.adb
+++ b/gcc/ada/libgnarl/s-stusta.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-stusta.ads b/gcc/ada/libgnarl/s-stusta.ads
index 3ff1d27..fd7088c 100644
--- a/gcc/ada/libgnarl/s-stusta.ads
+++ b/gcc/ada/libgnarl/s-stusta.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-taasde.adb b/gcc/ada/libgnarl/s-taasde.adb
index 66a17b0..dc7dac1 100644
--- a/gcc/ada/libgnarl/s-taasde.adb
+++ b/gcc/ada/libgnarl/s-taasde.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -51,8 +51,6 @@ package body System.Tasking.Async_Delays is
package STI renames System.Tasking.Initialization;
package OSP renames System.OS_Primitives;
- use Parameters;
-
function To_System is new Ada.Unchecked_Conversion
(Ada.Task_Identification.Task_Id, Task_Id);
@@ -118,11 +116,6 @@ package body System.Tasking.Async_Delays is
-- Remove self from timer queue
STI.Defer_Abort_Nestable (D.Self_Id);
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Timer_Server_ID);
Dpred := D.Pred;
Dsucc := D.Succ;
@@ -141,11 +134,6 @@ package body System.Tasking.Async_Delays is
STPO.Write_Lock (D.Self_Id);
STU.Exit_One_ATC_Level (D.Self_Id);
STPO.Unlock (D.Self_Id);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
STI.Undefer_Abort_Nestable (D.Self_Id);
end Cancel_Async_Delay;
@@ -217,11 +205,6 @@ package body System.Tasking.Async_Delays is
D.Level := Self_Id.ATC_Nesting_Level;
D.Self_Id := Self_Id;
D.Resume_Time := T;
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Timer_Server_ID);
-- Previously, there was code here to dynamically create
@@ -258,10 +241,6 @@ package body System.Tasking.Async_Delays is
end if;
STPO.Unlock (Timer_Server_ID);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
end Time_Enqueue;
---------------
@@ -305,11 +284,6 @@ package body System.Tasking.Async_Delays is
loop
STI.Defer_Abort (Timer_Server_ID);
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Timer_Server_ID);
-- The timer server needs to catch pending aborts after finalization
@@ -383,11 +357,6 @@ package body System.Tasking.Async_Delays is
-- an actual delay in this server.
STPO.Unlock (Timer_Server_ID);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
STI.Undefer_Abort (Timer_Server_ID);
end loop;
end Timer_Server;
diff --git a/gcc/ada/libgnarl/s-taasde.ads b/gcc/ada/libgnarl/s-taasde.ads
index df9a8bc..002ede9 100644
--- a/gcc/ada/libgnarl/s-taasde.ads
+++ b/gcc/ada/libgnarl/s-taasde.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tadeca.adb b/gcc/ada/libgnarl/s-tadeca.adb
index 15657d9..512e0ca 100644
--- a/gcc/ada/libgnarl/s-tadeca.adb
+++ b/gcc/ada/libgnarl/s-tadeca.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tadeca.ads b/gcc/ada/libgnarl/s-tadeca.ads
index d1ad701..7af3c06 100644
--- a/gcc/ada/libgnarl/s-tadeca.ads
+++ b/gcc/ada/libgnarl/s-tadeca.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tadert.adb b/gcc/ada/libgnarl/s-tadert.adb
index 7b857e5..bc8f09b 100644
--- a/gcc/ada/libgnarl/s-tadert.adb
+++ b/gcc/ada/libgnarl/s-tadert.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tadert.ads b/gcc/ada/libgnarl/s-tadert.ads
index 07a6609..db65536 100644
--- a/gcc/ada/libgnarl/s-tadert.ads
+++ b/gcc/ada/libgnarl/s-tadert.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-taenca.adb b/gcc/ada/libgnarl/s-taenca.adb
index 961f093..49c4c30 100644
--- a/gcc/ada/libgnarl/s-taenca.adb
+++ b/gcc/ada/libgnarl/s-taenca.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -35,13 +35,11 @@ with System.Tasking.Protected_Objects.Entries;
with System.Tasking.Protected_Objects.Operations;
with System.Tasking.Queuing;
with System.Tasking.Utilities;
-with System.Parameters;
package body System.Tasking.Entry_Calls is
package STPO renames System.Task_Primitives.Operations;
- use Parameters;
use Protected_Objects.Entries;
use Protected_Objects.Operations;
@@ -71,24 +69,18 @@ package body System.Tasking.Entry_Calls is
-- permitted. Since the server cannot be obtained reliably, it must be
-- obtained unreliably and then checked again once it has been locked.
--
- -- If Single_Lock and server is a PO, release RTS_Lock
- --
-- This should only be called by the Entry_Call.Self.
-- It should be holding no other ATCB locks at the time.
procedure Unlock_Server (Entry_Call : Entry_Call_Link);
-- STPO.Unlock the server targeted by Entry_Call. The server must
-- be locked before calling this.
- --
- -- If Single_Lock and server is a PO, take RTS_Lock on exit.
procedure Unlock_And_Update_Server
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link);
-- Similar to Unlock_Server, but services entry calls if the
-- server is a protected object.
- --
- -- If Single_Lock and server is a PO, take RTS_Lock on exit.
procedure Check_Pending_Actions_For_Entry_Call
(Self_ID : Task_Id;
@@ -200,19 +192,9 @@ package body System.Tasking.Entry_Calls is
-- We had very bad luck, interleaving with TWO different
-- requeue operations. Go around the loop and try again.
- if Single_Lock then
- STPO.Unlock_RTS;
- STPO.Yield;
- STPO.Lock_RTS;
- else
- STPO.Yield;
- end if;
+ STPO.Yield;
else
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
Lock_Entries_With_Status (Test_PO, Ceiling_Violation);
-- ???
@@ -232,10 +214,6 @@ package body System.Tasking.Entry_Calls is
Old_Base_Priority : System.Any_Priority;
begin
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Current_Task);
Old_Base_Priority := Current_Task.Common.Base_Priority;
Current_Task.New_Base_Priority := Test_PO.Ceiling;
@@ -243,10 +221,6 @@ package body System.Tasking.Entry_Calls is
(Current_Task);
STPO.Unlock (Current_Task);
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
-- Following lock should not fail
Lock_Entries (Test_PO);
@@ -258,10 +232,6 @@ package body System.Tasking.Entry_Calls is
exit when To_Address (Test_PO) = Entry_Call.Called_PO;
Unlock_Entries (Test_PO);
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
end if;
else
@@ -343,11 +313,6 @@ package body System.Tasking.Entry_Calls is
pragma Assert (Entry_Call.Mode = Asynchronous_Call);
Initialization.Defer_Abort_Nestable (Self_ID);
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Self_ID);
Entry_Call.Cancellation_Attempted := True;
@@ -357,13 +322,7 @@ package body System.Tasking.Entry_Calls is
Entry_Calls.Wait_For_Completion (Entry_Call);
STPO.Unlock (Self_ID);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
Succeeded := Entry_Call.State = Cancelled;
-
Initialization.Undefer_Abort_Nestable (Self_ID);
-- Ideally, abort should no longer be deferred at this point, so we
@@ -401,26 +360,13 @@ package body System.Tasking.Entry_Calls is
if Called_PO.Pending_Action then
Called_PO.Pending_Action := False;
Caller := STPO.Self;
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Caller);
Caller.New_Base_Priority := Called_PO.Old_Base_Priority;
Initialization.Change_Base_Priority (Caller);
STPO.Unlock (Caller);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
end if;
Unlock_Entries (Called_PO);
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
end if;
end Unlock_And_Update_Server;
@@ -441,26 +387,13 @@ package body System.Tasking.Entry_Calls is
if Called_PO.Pending_Action then
Called_PO.Pending_Action := False;
Caller := STPO.Self;
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Caller);
Caller.New_Base_Priority := Called_PO.Old_Base_Priority;
Initialization.Change_Base_Priority (Caller);
STPO.Unlock (Caller);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
end if;
Unlock_Entries (Called_PO);
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
end if;
end Unlock_Server;
@@ -481,21 +414,13 @@ package body System.Tasking.Entry_Calls is
-- a chance of getting ready immediately, using Unlock & Yield.
-- See similar action in Wait_For_Call & Timed_Selective_Wait.
- if Single_Lock then
- STPO.Unlock_RTS;
- else
- STPO.Unlock (Self_Id);
- end if;
+ STPO.Unlock (Self_Id);
if Entry_Call.State < Done then
STPO.Yield;
end if;
- if Single_Lock then
- STPO.Lock_RTS;
- else
- STPO.Write_Lock (Self_Id);
- end if;
+ STPO.Write_Lock (Self_Id);
loop
Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call);
@@ -507,7 +432,6 @@ package body System.Tasking.Entry_Calls is
Self_Id.Common.State := Runnable;
Utilities.Exit_One_ATC_Level (Self_Id);
-
end Wait_For_Completion;
--------------------------------------
diff --git a/gcc/ada/libgnarl/s-taenca.ads b/gcc/ada/libgnarl/s-taenca.ads
index 31f3012..2b013eb 100644
--- a/gcc/ada/libgnarl/s-taenca.ads
+++ b/gcc/ada/libgnarl/s-taenca.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -61,8 +61,7 @@ package System.Tasking.Entry_Calls is
Call : Entry_Call_Link);
-- This procedure suspends the calling task until the specified entry
-- call is queued abortably or completes.
- -- Abortion must be deferred when calling this procedure, and the global
- -- RTS lock taken when Single_Lock.
+ -- Abortion must be deferred when calling this procedure.
procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean);
pragma Inline (Try_To_Cancel_Entry_Call);
diff --git a/gcc/ada/libgnarl/s-taprob.adb b/gcc/ada/libgnarl/s-taprob.adb
index bd051dc..3f8a457 100644
--- a/gcc/ada/libgnarl/s-taprob.adb
+++ b/gcc/ada/libgnarl/s-taprob.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-taprob.ads b/gcc/ada/libgnarl/s-taprob.ads
index 8cb151b..c336225 100644
--- a/gcc/ada/libgnarl/s-taprob.ads
+++ b/gcc/ada/libgnarl/s-taprob.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-taprop.ads b/gcc/ada/libgnarl/s-taprop.ads
index ee872c9..32faac5 100644
--- a/gcc/ada/libgnarl/s-taprop.ads
+++ b/gcc/ada/libgnarl/s-taprop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -181,11 +181,8 @@ package System.Task_Primitives.Operations is
procedure Write_Lock
(L : not null access Lock;
Ceiling_Violation : out Boolean);
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False);
- procedure Write_Lock
- (T : ST.Task_Id);
+ procedure Write_Lock (L : not null access RTS_Lock);
+ procedure Write_Lock (T : ST.Task_Id);
pragma Inline (Write_Lock);
-- Lock a lock object for write access. After this operation returns,
-- the calling task holds write permission for the lock object. No other
@@ -198,9 +195,6 @@ package System.Task_Primitives.Operations is
-- operation failed, which will happen if there is a priority ceiling
-- violation.
--
- -- For the operation on RTS_Lock, Global_Lock should be set to True
- -- if L is a global lock (Single_RTS_Lock, Global_Task_Lock).
- --
-- For the operation on ST.Task_Id, the lock is the special lock object
-- associated with that task's ATCB. This lock has effective ceiling
-- priority high enough that it is safe to call by a task with any
@@ -235,11 +229,8 @@ package System.Task_Primitives.Operations is
procedure Unlock
(L : not null access Lock);
- procedure Unlock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False);
- procedure Unlock
- (T : ST.Task_Id);
+ procedure Unlock (L : not null access RTS_Lock);
+ procedure Unlock (T : ST.Task_Id);
pragma Inline (Unlock);
-- Unlock a locked lock object
--
@@ -249,9 +240,6 @@ package System.Task_Primitives.Operations is
-- read or write permission. (That is, matching pairs of Lock and Unlock
-- operations on each lock object must be properly nested.)
- -- For the operation on RTS_Lock, Global_Lock should be set to True if L
- -- is a global lock (Single_RTS_Lock, Global_Task_Lock).
- --
-- Note that Write_Lock for RTS_Lock does not have an out-parameter.
-- RTS_Locks are used in situations where we have not made provision for
-- recovery from ceiling violations. We do not expect them to occur inside
@@ -424,10 +412,7 @@ package System.Task_Primitives.Operations is
-- Following two routines are used for possible operations needed to be
-- setup/cleared upon entrance/exit of RTS while maintaining a single
- -- thread of control in the RTS. Since we intend these routines to be used
- -- for implementing the Single_Lock RTS, Lock_RTS should follow the first
- -- Defer_Abort operation entering RTS. In the same fashion Unlock_RTS
- -- should precede the last Undefer_Abort exiting RTS.
+ -- thread of control in the RTS.
--
-- These routines also replace the functions Lock/Unlock_All_Tasks_List
diff --git a/gcc/ada/libgnarl/s-taprop__dummy.adb b/gcc/ada/libgnarl/s-taprop__dummy.adb
index bd6387d..b6fa63b 100644
--- a/gcc/ada/libgnarl/s-taprop__dummy.adb
+++ b/gcc/ada/libgnarl/s-taprop__dummy.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb b/gcc/ada/libgnarl/s-taprop__hpux-dce.adb
index 4f66d4d..99049f1 100644
--- a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb
+++ b/gcc/ada/libgnarl/s-taprop__hpux-dce.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -83,7 +83,7 @@ package body System.Task_Primitives.Operations is
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
- -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+ -- Used to protect All_Tasks_List
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task
@@ -325,25 +325,18 @@ package body System.Task_Primitives.Operations is
Ceiling_Violation := False;
end Write_Lock;
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
+ procedure Write_Lock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
begin
- if not Single_Lock or else Global_Lock then
- Result := pthread_mutex_lock (L);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
- if not Single_Lock then
- Result := pthread_mutex_lock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
end Write_Lock;
---------------
@@ -369,25 +362,18 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end Unlock;
- procedure Unlock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
+ procedure Unlock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
begin
- if not Single_Lock or else Global_Lock then
- Result := pthread_mutex_unlock (L);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
end Unlock;
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
- if not Single_Lock then
- Result := pthread_mutex_unlock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
end Unlock;
-----------------
@@ -421,9 +407,7 @@ package body System.Task_Primitives.Operations is
Result :=
pthread_cond_wait
(cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access));
+ mutex => Self_ID.Common.LL.L'Access);
-- EINTR is not considered a failure
@@ -467,9 +451,7 @@ package body System.Task_Primitives.Operations is
Result :=
pthread_cond_timedwait
(cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access),
+ mutex => Self_ID.Common.LL.L'Access,
abstime => Request'Access);
exit when Abs_Time <= Monotonic_Clock;
@@ -504,10 +486,6 @@ package body System.Task_Primitives.Operations is
pragma Warnings (Off, Result);
begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Self_ID);
Abs_Time :=
@@ -525,9 +503,7 @@ package body System.Task_Primitives.Operations is
Result :=
pthread_cond_timedwait
(cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access),
+ mutex => Self_ID.Common.LL.L'Access,
abstime => Request'Access);
exit when Abs_Time <= Monotonic_Clock;
@@ -541,11 +517,6 @@ package body System.Task_Primitives.Operations is
end if;
Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Result := sched_yield;
end Timed_Delay;
@@ -733,26 +704,24 @@ package body System.Task_Primitives.Operations is
Cond_Attr : aliased pthread_condattr_t;
begin
- if not Single_Lock then
- Result := pthread_mutexattr_init (Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = 0 then
- Result :=
- pthread_mutex_init
- (Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
- end if;
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
- if Result /= 0 then
- Succeeded := False;
- return;
- end if;
+ if Result = 0 then
+ Result :=
+ pthread_mutex_init
+ (Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+ end if;
- Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
- pragma Assert (Result = 0);
+ if Result /= 0 then
+ Succeeded := False;
+ return;
end if;
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+
Result := pthread_condattr_init (Cond_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
@@ -767,10 +736,8 @@ package body System.Task_Primitives.Operations is
if Result = 0 then
Succeeded := True;
else
- if not Single_Lock then
- Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
Succeeded := False;
end if;
@@ -841,10 +808,8 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
- if not Single_Lock then
- Result := pthread_mutex_destroy (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
Result := pthread_cond_destroy (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -1093,7 +1058,7 @@ package body System.Task_Primitives.Operations is
procedure Lock_RTS is
begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
@@ -1102,7 +1067,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock_RTS is
begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
------------------
diff --git a/gcc/ada/libgnarl/s-taprop__linux.adb b/gcc/ada/libgnarl/s-taprop__linux.adb
index c45559e..fb11e02 100644
--- a/gcc/ada/libgnarl/s-taprop__linux.adb
+++ b/gcc/ada/libgnarl/s-taprop__linux.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -75,7 +75,7 @@ package body System.Task_Primitives.Operations is
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
- -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+ -- Used to protect All_Tasks_List
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task
@@ -243,9 +243,9 @@ package body System.Task_Primitives.Operations is
return Ceiling_Support;
end Get_Ceiling_Support;
- pragma Warnings (Off, "non-static call not allowed in preelaborated unit");
+ pragma Warnings (Off, "non-preelaborable call not allowed*");
Ceiling_Support : constant Boolean := Get_Ceiling_Support;
- pragma Warnings (On, "non-static call not allowed in preelaborated unit");
+ pragma Warnings (On, "non-preelaborable call not allowed*");
-- True if the locking policy is Ceiling_Locking, and the current process
-- has permission to use this policy. The process has permission if it is
-- running as 'root', or if the capability was set by the setcap command,
@@ -304,7 +304,7 @@ package body System.Task_Primitives.Operations is
procedure Lock_RTS is
begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
@@ -313,7 +313,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock_RTS is
begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
-----------------
@@ -484,25 +484,18 @@ package body System.Task_Primitives.Operations is
Ceiling_Violation := Result = EINVAL;
end Write_Lock;
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
+ procedure Write_Lock (L : not null access RTS_Lock) is
Result : C.int;
begin
- if not Single_Lock or else Global_Lock then
- Result := pthread_mutex_lock (L);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
Result : C.int;
begin
- if not Single_Lock then
- Result := pthread_mutex_lock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
end Write_Lock;
---------------
@@ -542,25 +535,18 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end Unlock;
- procedure Unlock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
+ procedure Unlock (L : not null access RTS_Lock) is
Result : C.int;
begin
- if not Single_Lock or else Global_Lock then
- Result := pthread_mutex_unlock (L);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
end Unlock;
procedure Unlock (T : Task_Id) is
Result : C.int;
begin
- if not Single_Lock then
- Result := pthread_mutex_unlock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
end Unlock;
-----------------
@@ -596,9 +582,7 @@ package body System.Task_Primitives.Operations is
Result :=
pthread_cond_wait
(cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access));
+ mutex => Self_ID.Common.LL.L'Access);
-- EINTR is not considered a failure
@@ -860,13 +844,9 @@ package body System.Task_Primitives.Operations is
Self_ID.Common.LL.Thread := Null_Thread_Id;
- if not Single_Lock then
- if Init_Mutex
- (Self_ID.Common.LL.L'Access, Any_Priority'Last) /= 0
- then
- Succeeded := False;
- return;
- end if;
+ if Init_Mutex (Self_ID.Common.LL.L'Access, Any_Priority'Last) /= 0 then
+ Succeeded := False;
+ return;
end if;
Result := pthread_condattr_init (Cond_Attr'Access);
@@ -885,10 +865,8 @@ package body System.Task_Primitives.Operations is
if Result = 0 then
Succeeded := True;
else
- if not Single_Lock then
- Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
Succeeded := False;
end if;
@@ -1070,10 +1048,8 @@ package body System.Task_Primitives.Operations is
Result : C.int;
begin
- if not Single_Lock then
- Result := pthread_mutex_destroy (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
Result := pthread_cond_destroy (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
diff --git a/gcc/ada/libgnarl/s-taprop__mingw.adb b/gcc/ada/libgnarl/s-taprop__mingw.adb
index 91eb441..8fa5435 100644
--- a/gcc/ada/libgnarl/s-taprop__mingw.adb
+++ b/gcc/ada/libgnarl/s-taprop__mingw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -111,7 +111,7 @@ package body System.Task_Primitives.Operations is
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
- -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+ -- Used to protect All_Tasks_List
Time_Slice_Val : Integer;
pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
@@ -290,7 +290,7 @@ package body System.Task_Primitives.Operations is
Result_Bool := ResetEvent (HANDLE (Cond.all));
pragma Assert (Result_Bool = Win32.TRUE);
- Unlock (L, Global_Lock => True);
+ Unlock (L);
-- No problem if we are interrupted here: if the condition is signaled,
-- WaitForSingleObject will simply not block
@@ -298,7 +298,7 @@ package body System.Task_Primitives.Operations is
Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite);
pragma Assert (Result = 0);
- Write_Lock (L, Global_Lock => True);
+ Write_Lock (L);
end Cond_Wait;
---------------------
@@ -330,7 +330,7 @@ package body System.Task_Primitives.Operations is
Result := ResetEvent (HANDLE (Cond.all));
pragma Assert (Result = Win32.TRUE);
- Unlock (L, Global_Lock => True);
+ Unlock (L);
-- No problem if we are interrupted here: if the condition is signaled,
-- WaitForSingleObject will simply not block.
@@ -355,7 +355,7 @@ package body System.Task_Primitives.Operations is
end if;
end if;
- Write_Lock (L, Global_Lock => True);
+ Write_Lock (L);
-- Ensure post-condition
@@ -465,21 +465,14 @@ package body System.Task_Primitives.Operations is
Ceiling_Violation := False;
end Write_Lock;
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
+ procedure Write_Lock (L : not null access RTS_Lock) is
begin
- if not Single_Lock or else Global_Lock then
- EnterCriticalSection (L);
- end if;
+ EnterCriticalSection (L);
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
begin
- if not Single_Lock then
- EnterCriticalSection (T.Common.LL.L'Access);
- end if;
+ EnterCriticalSection (T.Common.LL.L'Access);
end Write_Lock;
---------------
@@ -501,19 +494,14 @@ package body System.Task_Primitives.Operations is
LeaveCriticalSection (L.Mutex'Access);
end Unlock;
- procedure Unlock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False) is
+ procedure Unlock (L : not null access RTS_Lock) is
begin
- if not Single_Lock or else Global_Lock then
- LeaveCriticalSection (L);
- end if;
+ LeaveCriticalSection (L);
end Unlock;
procedure Unlock (T : Task_Id) is
begin
- if not Single_Lock then
- LeaveCriticalSection (T.Common.LL.L'Access);
- end if;
+ LeaveCriticalSection (T.Common.LL.L'Access);
end Unlock;
-----------------
@@ -544,11 +532,7 @@ package body System.Task_Primitives.Operations is
begin
pragma Assert (Self_ID = Self);
- if Single_Lock then
- Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
- else
- Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
- end if;
+ Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
if Self_ID.Deferral_Level = 0
and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
@@ -599,19 +583,12 @@ package body System.Task_Primitives.Operations is
loop
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
- if Single_Lock then
- Cond_Timed_Wait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access,
- Rel_Time, Local_Timedout, Result);
- else
- Cond_Timed_Wait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access,
- Rel_Time, Local_Timedout, Result);
- end if;
-
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Rel_Time, Local_Timedout, Result);
Check_Time := Monotonic_Clock;
+
exit when Abs_Time <= Check_Time;
if not Local_Timedout then
@@ -645,10 +622,6 @@ package body System.Task_Primitives.Operations is
pragma Unreferenced (Timedout, Result);
begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Self_ID);
if Mode = Relative then
@@ -665,19 +638,12 @@ package body System.Task_Primitives.Operations is
loop
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
- if Single_Lock then
- Cond_Timed_Wait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access,
- Rel_Time, Timedout, Result);
- else
- Cond_Timed_Wait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access,
- Rel_Time, Timedout, Result);
- end if;
-
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Rel_Time, Timedout, Result);
Check_Time := Monotonic_Clock;
+
exit when Abs_Time <= Check_Time;
Rel_Time := Abs_Time - Check_Time;
@@ -687,11 +653,6 @@ package body System.Task_Primitives.Operations is
end if;
Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Yield;
end Timed_Delay;
@@ -845,10 +806,7 @@ package body System.Task_Primitives.Operations is
Self_ID.Common.LL.Thread := Null_Thread_Id;
Initialize_Cond (Self_ID.Common.LL.CV'Access);
-
- if not Single_Lock then
- Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
- end if;
+ Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
Succeeded := True;
end Initialize_TCB;
@@ -976,10 +934,7 @@ package body System.Task_Primitives.Operations is
pragma Unreferenced (Succeeded);
begin
- if not Single_Lock then
- Finalize_Lock (T.Common.LL.L'Access);
- end if;
-
+ Finalize_Lock (T.Common.LL.L'Access);
Finalize_Cond (T.Common.LL.CV'Access);
if T.Known_Tasks_Index /= -1 then
@@ -1035,7 +990,7 @@ package body System.Task_Primitives.Operations is
procedure Lock_RTS is
begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
@@ -1044,7 +999,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock_RTS is
begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
----------------
diff --git a/gcc/ada/libgnarl/s-taprop__posix.adb b/gcc/ada/libgnarl/s-taprop__posix.adb
index 8b49cce..c983c77 100644
--- a/gcc/ada/libgnarl/s-taprop__posix.adb
+++ b/gcc/ada/libgnarl/s-taprop__posix.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -82,7 +82,7 @@ package body System.Task_Primitives.Operations is
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
- -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+ -- Used to protect All_Tasks_List
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task
@@ -443,25 +443,18 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0 or else Ceiling_Violation);
end Write_Lock;
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
+ procedure Write_Lock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
begin
- if not Single_Lock or else Global_Lock then
- Result := pthread_mutex_lock (L);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
- if not Single_Lock then
- Result := pthread_mutex_lock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
end Write_Lock;
---------------
@@ -485,24 +478,18 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end Unlock;
- procedure Unlock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False)
- is
+ procedure Unlock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
begin
- if not Single_Lock or else Global_Lock then
- Result := pthread_mutex_unlock (L);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
end Unlock;
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
- if not Single_Lock then
- Result := pthread_mutex_unlock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
end Unlock;
-----------------
@@ -536,9 +523,7 @@ package body System.Task_Primitives.Operations is
Result :=
pthread_cond_wait
(cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access));
+ mutex => Self_ID.Common.LL.L'Access);
-- EINTR is not considered a failure
@@ -728,48 +713,46 @@ package body System.Task_Primitives.Operations is
Next_Serial_Number := Next_Serial_Number + 1;
pragma Assert (Next_Serial_Number /= 0);
- if not Single_Lock then
- Result := pthread_mutexattr_init (Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = 0 then
- if Locking_Policy = 'C' then
- Result :=
- pthread_mutexattr_setprotocol
- (Mutex_Attr'Access,
- PTHREAD_PRIO_PROTECT);
- pragma Assert (Result = 0);
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
- Result :=
- pthread_mutexattr_setprioceiling
- (Mutex_Attr'Access,
- Interfaces.C.int (System.Any_Priority'Last));
- pragma Assert (Result = 0);
+ if Result = 0 then
+ if Locking_Policy = 'C' then
+ Result :=
+ pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access,
+ PTHREAD_PRIO_PROTECT);
+ pragma Assert (Result = 0);
- elsif Locking_Policy = 'I' then
- Result :=
- pthread_mutexattr_setprotocol
- (Mutex_Attr'Access,
- PTHREAD_PRIO_INHERIT);
- pragma Assert (Result = 0);
- end if;
+ Result :=
+ pthread_mutexattr_setprioceiling
+ (Mutex_Attr'Access,
+ Interfaces.C.int (System.Any_Priority'Last));
+ pragma Assert (Result = 0);
+ elsif Locking_Policy = 'I' then
Result :=
- pthread_mutex_init
- (Self_ID.Common.LL.L'Access,
- Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
+ pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access,
+ PTHREAD_PRIO_INHERIT);
+ pragma Assert (Result = 0);
end if;
- if Result /= 0 then
- Succeeded := False;
- return;
- end if;
+ Result :=
+ pthread_mutex_init
+ (Self_ID.Common.LL.L'Access,
+ Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+ end if;
- Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
- pragma Assert (Result = 0);
+ if Result /= 0 then
+ Succeeded := False;
+ return;
end if;
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+
Result := pthread_condattr_init (Cond_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
@@ -786,11 +769,8 @@ package body System.Task_Primitives.Operations is
if Result = 0 then
Succeeded := True;
else
- if not Single_Lock then
- Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
-
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
Succeeded := False;
end if;
@@ -915,10 +895,8 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
- if not Single_Lock then
- Result := pthread_mutex_destroy (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
Result := pthread_cond_destroy (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -1212,7 +1190,7 @@ package body System.Task_Primitives.Operations is
procedure Lock_RTS is
begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
@@ -1221,7 +1199,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock_RTS is
begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
------------------
diff --git a/gcc/ada/libgnarl/s-taprop__qnx.adb b/gcc/ada/libgnarl/s-taprop__qnx.adb
index e244d03..52d353c 100644
--- a/gcc/ada/libgnarl/s-taprop__qnx.adb
+++ b/gcc/ada/libgnarl/s-taprop__qnx.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -82,7 +82,7 @@ package body System.Task_Primitives.Operations is
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
- -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+ -- Used to protect All_Tasks_List
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task
@@ -458,25 +458,18 @@ package body System.Task_Primitives.Operations is
end if;
end Write_Lock;
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
+ procedure Write_Lock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
begin
- if not Single_Lock or else Global_Lock then
- Result := pthread_mutex_lock (L);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
- if not Single_Lock then
- Result := pthread_mutex_lock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
end Write_Lock;
---------------
@@ -500,24 +493,18 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end Unlock;
- procedure Unlock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False)
- is
+ procedure Unlock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
begin
- if not Single_Lock or else Global_Lock then
- Result := pthread_mutex_unlock (L);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
end Unlock;
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
- if not Single_Lock then
- Result := pthread_mutex_unlock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
end Unlock;
-----------------
@@ -551,9 +538,7 @@ package body System.Task_Primitives.Operations is
Result :=
pthread_cond_wait
(cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access));
+ mutex => Self_ID.Common.LL.L'Access);
-- EINTR is not considered a failure
@@ -713,8 +698,7 @@ package body System.Task_Primitives.Operations is
-- Initialize_TCB --
--------------------
- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean)
- is
+ procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Result : Interfaces.C.int;
Cond_Attr : aliased pthread_condattr_t;
@@ -725,14 +709,12 @@ package body System.Task_Primitives.Operations is
Next_Serial_Number := Next_Serial_Number + 1;
pragma Assert (Next_Serial_Number /= 0);
- if not Single_Lock then
- Result := Init_Mutex (Self_ID.Common.LL.L'Access, Any_Priority'Last);
- pragma Assert (Result = 0);
+ Result := Init_Mutex (Self_ID.Common.LL.L'Access, Any_Priority'Last);
+ pragma Assert (Result = 0);
- if Result /= 0 then
- Succeeded := False;
- return;
- end if;
+ if Result /= 0 then
+ Succeeded := False;
+ return;
end if;
Result := pthread_condattr_init (Cond_Attr'Access);
@@ -751,10 +733,8 @@ package body System.Task_Primitives.Operations is
if Result = 0 then
Succeeded := True;
else
- if not Single_Lock then
- Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
Succeeded := False;
end if;
@@ -894,10 +874,8 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
- if not Single_Lock then
- Result := pthread_mutex_destroy (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
Result := pthread_cond_destroy (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -1191,7 +1169,7 @@ package body System.Task_Primitives.Operations is
procedure Lock_RTS is
begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
@@ -1200,7 +1178,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock_RTS is
begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
------------------
diff --git a/gcc/ada/libgnarl/s-taprop__solaris.adb b/gcc/ada/libgnarl/s-taprop__solaris.adb
index 3878558..8b0183d 100644
--- a/gcc/ada/libgnarl/s-taprop__solaris.adb
+++ b/gcc/ada/libgnarl/s-taprop__solaris.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -91,7 +91,7 @@ package body System.Task_Primitives.Operations is
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
- -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+ -- Used to protect All_Tasks_List
Next_Serial_Number : Task_Serial_Number := 100;
-- We start at 100, to reserve some special values for
@@ -653,29 +653,22 @@ package body System.Task_Primitives.Operations is
pragma Assert (Record_Lock (Lock_Ptr (L)));
end Write_Lock;
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
+ procedure Write_Lock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
begin
- if not Single_Lock or else Global_Lock then
- pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
- Result := mutex_lock (L.L'Access);
- pragma Assert (Result = 0);
- pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
- end if;
+ pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
+ Result := mutex_lock (L.L'Access);
+ pragma Assert (Result = 0);
+ pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
- if not Single_Lock then
- pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
- Result := mutex_lock (T.Common.LL.L.L'Access);
- pragma Assert (Result = 0);
- pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
- end if;
+ pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
+ Result := mutex_lock (T.Common.LL.L.L'Access);
+ pragma Assert (Result = 0);
+ pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
end Write_Lock;
---------------
@@ -717,27 +710,20 @@ package body System.Task_Primitives.Operations is
end if;
end Unlock;
- procedure Unlock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
+ procedure Unlock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
begin
- if not Single_Lock or else Global_Lock then
- pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
- Result := mutex_unlock (L.L'Access);
- pragma Assert (Result = 0);
- end if;
+ pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
+ Result := mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
end Unlock;
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
- if not Single_Lock then
- pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access)));
- Result := mutex_unlock (T.Common.LL.L.L'Access);
- pragma Assert (Result = 0);
- end if;
+ pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access)));
+ Result := mutex_unlock (T.Common.LL.L.L'Access);
+ pragma Assert (Result = 0);
end Unlock;
-----------------
@@ -929,14 +915,12 @@ package body System.Task_Primitives.Operations is
Self_ID.Common.LL.Thread := Null_Thread_Id;
- if not Single_Lock then
- Result :=
- mutex_init
- (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address);
- Self_ID.Common.LL.L.Level :=
- Private_Task_Serial_Number (Self_ID.Serial_Number);
- pragma Assert (Result = 0 or else Result = ENOMEM);
- end if;
+ Result :=
+ mutex_init
+ (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address);
+ Self_ID.Common.LL.L.Level :=
+ Private_Task_Serial_Number (Self_ID.Serial_Number);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
Result := cond_init (Self_ID.Common.LL.CV'Access, USYNC_THREAD, 0);
@@ -946,10 +930,8 @@ package body System.Task_Primitives.Operations is
if Result = 0 then
Succeeded := True;
else
- if not Single_Lock then
- Result := mutex_destroy (Self_ID.Common.LL.L.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := mutex_destroy (Self_ID.Common.LL.L.L'Access);
+ pragma Assert (Result = 0);
Succeeded := False;
end if;
@@ -1049,10 +1031,8 @@ package body System.Task_Primitives.Operations is
begin
T.Common.LL.Thread := Null_Thread_Id;
- if not Single_Lock then
- Result := mutex_destroy (T.Common.LL.L.L'Access);
- pragma Assert (Result = 0);
- end if;
+ Result := mutex_destroy (T.Common.LL.L.L'Access);
+ pragma Assert (Result = 0);
Result := cond_destroy (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -1107,15 +1087,9 @@ package body System.Task_Primitives.Operations is
begin
pragma Assert (Check_Sleep (Reason));
- if Single_Lock then
- Result :=
- cond_wait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access);
- else
- Result :=
- cond_wait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access);
- end if;
+ Result :=
+ cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access);
pragma Assert
(Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
@@ -1221,21 +1195,13 @@ package body System.Task_Primitives.Operations is
loop
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
- if Single_Lock then
- Result :=
- cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock.L'Access, Request'Access);
- else
- Result :=
- cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L.L'Access, Request'Access);
- end if;
-
+ Result :=
+ cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L.L'Access, Request'Access);
Yielded := True;
-
Check_Time := Monotonic_Clock;
+
exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
if Result = 0 or Result = EINTR then
@@ -1271,10 +1237,6 @@ package body System.Task_Primitives.Operations is
Yielded : Boolean := False;
begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Self_ID);
Abs_Time :=
@@ -1291,23 +1253,14 @@ package body System.Task_Primitives.Operations is
loop
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
- if Single_Lock then
- Result :=
- cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock.L'Access,
- Request'Access);
- else
- Result :=
- cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L.L'Access,
- Request'Access);
- end if;
-
+ Result :=
+ cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L.L'Access,
+ Request'Access);
Yielded := True;
-
Check_Time := Monotonic_Clock;
+
exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
pragma Assert
@@ -1325,10 +1278,6 @@ package body System.Task_Primitives.Operations is
Unlock (Self_ID);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
if not Yielded then
thr_yield;
end if;
@@ -1412,10 +1361,6 @@ package body System.Task_Primitives.Operations is
return False;
end if;
- if Single_Lock then
- return True;
- end if;
-
-- Check that TCB lock order rules are satisfied
P := Self_ID.Common.LL.Locks;
@@ -1451,10 +1396,6 @@ package body System.Task_Primitives.Operations is
L.Owner := To_Owner_ID (To_Address (Self_ID));
- if Single_Lock then
- return True;
- end if;
-
-- Check that TCB lock order rules are satisfied
P := Self_ID.Common.LL.Locks;
@@ -1485,10 +1426,6 @@ package body System.Task_Primitives.Operations is
return False;
end if;
- if Single_Lock then
- return True;
- end if;
-
-- Check that caller is holding own lock, on top of list
if Self_ID.Common.LL.Locks /=
@@ -1528,10 +1465,6 @@ package body System.Task_Primitives.Operations is
L.Owner := To_Owner_ID (To_Address (Self_ID));
- if Single_Lock then
- return True;
- end if;
-
-- Check that TCB lock order rules are satisfied
P := Self_ID.Common.LL.Locks;
@@ -1880,7 +1813,7 @@ package body System.Task_Primitives.Operations is
procedure Lock_RTS is
begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
@@ -1889,7 +1822,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock_RTS is
begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
------------------
diff --git a/gcc/ada/libgnarl/s-taprop__vxworks.adb b/gcc/ada/libgnarl/s-taprop__vxworks.adb
index 6ef0a9b..32c301d 100644
--- a/gcc/ada/libgnarl/s-taprop__vxworks.adb
+++ b/gcc/ada/libgnarl/s-taprop__vxworks.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -101,7 +101,7 @@ package body System.Task_Primitives.Operations is
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at a
-- time; it is used to execute in mutual exclusion from all other tasks.
- -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+ -- Used to protect All_Tasks_List
Time_Slice_Val : Integer;
pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
@@ -374,25 +374,18 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end Write_Lock;
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
+ procedure Write_Lock (L : not null access RTS_Lock) is
Result : int;
begin
- if not Single_Lock or else Global_Lock then
- Result := semTake (L.Mutex, WAIT_FOREVER);
- pragma Assert (Result = 0);
- end if;
+ Result := semTake (L.Mutex, WAIT_FOREVER);
+ pragma Assert (Result = 0);
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
Result : int;
begin
- if not Single_Lock then
- Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER);
- pragma Assert (Result = 0);
- end if;
+ Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER);
+ pragma Assert (Result = 0);
end Write_Lock;
---------------
@@ -401,8 +394,7 @@ package body System.Task_Primitives.Operations is
procedure Read_Lock
(L : not null access Lock;
- Ceiling_Violation : out Boolean)
- is
+ Ceiling_Violation : out Boolean) is
begin
Write_Lock (L, Ceiling_Violation);
end Read_Lock;
@@ -418,25 +410,18 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end Unlock;
- procedure Unlock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
+ procedure Unlock (L : not null access RTS_Lock) is
Result : int;
begin
- if not Single_Lock or else Global_Lock then
- Result := semGive (L.Mutex);
- pragma Assert (Result = 0);
- end if;
+ Result := semGive (L.Mutex);
+ pragma Assert (Result = 0);
end Unlock;
procedure Unlock (T : Task_Id) is
Result : int;
begin
- if not Single_Lock then
- Result := semGive (T.Common.LL.L.Mutex);
- pragma Assert (Result = 0);
- end if;
+ Result := semGive (T.Common.LL.L.Mutex);
+ pragma Assert (Result = 0);
end Unlock;
-----------------
@@ -468,10 +453,7 @@ package body System.Task_Primitives.Operations is
-- Release the mutex before sleeping
- Result :=
- semGive (if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex);
+ Result := semGive (Self_ID.Common.LL.L.Mutex);
pragma Assert (Result = 0);
-- Perform a blocking operation to take the CV semaphore. Note that a
@@ -484,10 +466,7 @@ package body System.Task_Primitives.Operations is
-- Take the mutex back
- Result :=
- semTake ((if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
+ Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
pragma Assert (Result = 0);
end Sleep;
@@ -540,10 +519,7 @@ package body System.Task_Primitives.Operations is
loop
-- Release the mutex before sleeping
- Result :=
- semGive (if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex);
+ Result := semGive (Self_ID.Common.LL.L.Mutex);
pragma Assert (Result = 0);
-- Perform a blocking operation to take the CV semaphore. Note
@@ -583,10 +559,7 @@ package body System.Task_Primitives.Operations is
-- Take the mutex back
- Result :=
- semTake ((if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
+ Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
pragma Assert (Result = 0);
exit when Timedout or Wakeup;
@@ -597,16 +570,9 @@ package body System.Task_Primitives.Operations is
-- Should never hold a lock while yielding
- if Single_Lock then
- Result := semGive (Single_RTS_Lock.Mutex);
- Result := taskDelay (0);
- Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
-
- else
- Result := semGive (Self_ID.Common.LL.L.Mutex);
- Result := taskDelay (0);
- Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
- end if;
+ Result := semGive (Self_ID.Common.LL.L.Mutex);
+ Result := taskDelay (0);
+ Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
end if;
end Timed_Sleep;
@@ -653,10 +619,7 @@ package body System.Task_Primitives.Operations is
-- Modifying State, locking the TCB
- Result :=
- semTake ((if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
+ Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
pragma Assert (Result = 0);
@@ -668,10 +631,7 @@ package body System.Task_Primitives.Operations is
-- Release the TCB before sleeping
- Result :=
- semGive (if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex);
+ Result := semGive (Self_ID.Common.LL.L.Mutex);
pragma Assert (Result = 0);
exit when Aborted;
@@ -697,11 +657,7 @@ package body System.Task_Primitives.Operations is
-- Take back the lock after having slept, to protect further
-- access to Self_ID.
- Result :=
- semTake
- ((if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
+ Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
pragma Assert (Result = 0);
@@ -710,11 +666,7 @@ package body System.Task_Primitives.Operations is
Self_ID.Common.State := Runnable;
- Result :=
- semGive
- (if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex);
+ Result := semGive (Self_ID.Common.LL.L.Mutex);
else
Result := taskDelay (0);
@@ -875,10 +827,7 @@ package body System.Task_Primitives.Operations is
else
Succeeded := True;
-
- if not Single_Lock then
- Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
- end if;
+ Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
end if;
end Initialize_TCB;
@@ -996,10 +945,8 @@ package body System.Task_Primitives.Operations is
Result : int;
begin
- if not Single_Lock then
- Result := semDelete (T.Common.LL.L.Mutex);
- pragma Assert (Result = 0);
- end if;
+ Result := semDelete (T.Common.LL.L.Mutex);
+ pragma Assert (Result = 0);
T.Common.LL.Thread := Null_Thread_Id;
@@ -1251,7 +1198,7 @@ package body System.Task_Primitives.Operations is
procedure Lock_RTS is
begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
@@ -1260,7 +1207,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock_RTS is
begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
------------------
diff --git a/gcc/ada/libgnarl/s-tarest.adb b/gcc/ada/libgnarl/s-tarest.adb
index 5cd207f..ddaa983 100644
--- a/gcc/ada/libgnarl/s-tarest.adb
+++ b/gcc/ada/libgnarl/s-tarest.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -62,7 +62,6 @@ package body System.Tasking.Restricted.Stages is
use Ada.Exceptions;
- use Parameters;
use Task_Primitives.Operations;
Tasks_Activation_Chain : Task_Id;
@@ -153,7 +152,7 @@ package body System.Tasking.Restricted.Stages is
Self_ID.Common.Global_Task_Lock_Nesting + 1;
if Self_ID.Common.Global_Task_Lock_Nesting = 1 then
- STPO.Write_Lock (Global_Task_Lock'Access, Global_Lock => True);
+ STPO.Write_Lock (Global_Task_Lock'Access);
end if;
end Task_Lock;
@@ -170,7 +169,7 @@ package body System.Tasking.Restricted.Stages is
Self_ID.Common.Global_Task_Lock_Nesting - 1;
if Self_ID.Common.Global_Task_Lock_Nesting = 0 then
- STPO.Unlock (Global_Task_Lock'Access, Global_Lock => True);
+ STPO.Unlock (Global_Task_Lock'Access);
end if;
end Task_Unlock;
@@ -265,20 +264,12 @@ package body System.Tasking.Restricted.Stages is
TH : Termination_Handler := null;
begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Self_ID.Common.Parent);
TH := Self_ID.Common.Parent.Common.Fall_Back_Handler;
Unlock (Self_ID.Common.Parent);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
-- Execute the task termination handler if we found it
if TH /= null then
@@ -347,10 +338,6 @@ package body System.Tasking.Restricted.Stages is
pragma Assert (Self_ID = Environment_Task);
pragma Assert (Self_ID.Common.Wait_Count = 0);
- if Single_Lock then
- Lock_RTS;
- end if;
-
-- Lock self, to prevent activated tasks from racing ahead before we
-- finish activating the chain.
@@ -403,10 +390,6 @@ package body System.Tasking.Restricted.Stages is
Self_ID.Common.State := Runnable;
Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
end Activate_Tasks;
------------------------------------
@@ -423,10 +406,6 @@ package body System.Tasking.Restricted.Stages is
Activator : constant Task_Id := Self_ID.Common.Activator;
begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Activator);
Write_Lock (Self_ID);
@@ -449,10 +428,6 @@ package body System.Tasking.Restricted.Stages is
Unlock (Self_ID);
Unlock (Activator);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
-- After the activation, active priority should be the same as base
-- priority. We must unlock the Activator first, though, since it should
-- not wait if we have lower priority.
@@ -533,10 +508,6 @@ package body System.Tasking.Restricted.Stages is
else System.Multiprocessors.CPU_Range (CPU));
end if;
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Self_ID);
-- With no task hierarchy, the parent of all non-Environment tasks that
@@ -554,11 +525,6 @@ package body System.Tasking.Restricted.Stages is
if not Success then
Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
raise Program_Error;
end if;
@@ -581,10 +547,6 @@ package body System.Tasking.Restricted.Stages is
Unlock (Self_ID);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
-- Create TSD as early as possible in the creation of a task, since
-- it may be used by the operation of Ada code within the task. If the
-- compiler has not allocated a secondary stack, a stack will be
@@ -681,10 +643,6 @@ package body System.Tasking.Restricted.Stages is
begin
pragma Assert (Self_ID = STPO.Environment_Task);
- if Single_Lock then
- Lock_RTS;
- end if;
-
-- Handle normal task termination by the environment task, but only for
-- the normal task termination. In the case of Abnormal and
-- Unhandled_Exception they must have been handled before, and the task
@@ -705,10 +663,6 @@ package body System.Tasking.Restricted.Stages is
Sleep (Self_ID, Master_Completion_Sleep);
Unlock (Self_ID);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
-- Should never return from Master Completion Sleep
raise Program_Error;
diff --git a/gcc/ada/libgnarl/s-tarest.ads b/gcc/ada/libgnarl/s-tarest.ads
index f1906a9..9c67a83 100644
--- a/gcc/ada/libgnarl/s-tarest.ads
+++ b/gcc/ada/libgnarl/s-tarest.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tasdeb.adb b/gcc/ada/libgnarl/s-tasdeb.adb
index 411994f..f1f3989 100644
--- a/gcc/ada/libgnarl/s-tasdeb.adb
+++ b/gcc/ada/libgnarl/s-tasdeb.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tasdeb.ads b/gcc/ada/libgnarl/s-tasdeb.ads
index 86986a4..9e0f0ff 100644
--- a/gcc/ada/libgnarl/s-tasdeb.ads
+++ b/gcc/ada/libgnarl/s-tasdeb.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tasinf.adb b/gcc/ada/libgnarl/s-tasinf.adb
index 474f441..2636de9 100644
--- a/gcc/ada/libgnarl/s-tasinf.adb
+++ b/gcc/ada/libgnarl/s-tasinf.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- (Compiler Interface) --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tasinf.ads b/gcc/ada/libgnarl/s-tasinf.ads
index 396f95c..a05ddf5 100644
--- a/gcc/ada/libgnarl/s-tasinf.ads
+++ b/gcc/ada/libgnarl/s-tasinf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tasinf__linux.adb b/gcc/ada/libgnarl/s-tasinf__linux.adb
index 93e0432..ad0b422 100644
--- a/gcc/ada/libgnarl/s-tasinf__linux.adb
+++ b/gcc/ada/libgnarl/s-tasinf__linux.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tasinf__linux.ads b/gcc/ada/libgnarl/s-tasinf__linux.ads
index 3a7231d..df25fbe 100644
--- a/gcc/ada/libgnarl/s-tasinf__linux.ads
+++ b/gcc/ada/libgnarl/s-tasinf__linux.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tasinf__mingw.adb b/gcc/ada/libgnarl/s-tasinf__mingw.adb
index d6c978e..397cdfe 100644
--- a/gcc/ada/libgnarl/s-tasinf__mingw.adb
+++ b/gcc/ada/libgnarl/s-tasinf__mingw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tasinf__mingw.ads b/gcc/ada/libgnarl/s-tasinf__mingw.ads
index bc16aed..9296345 100644
--- a/gcc/ada/libgnarl/s-tasinf__mingw.ads
+++ b/gcc/ada/libgnarl/s-tasinf__mingw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tasinf__solaris.adb b/gcc/ada/libgnarl/s-tasinf__solaris.adb
index 44a9115..91c849b 100644
--- a/gcc/ada/libgnarl/s-tasinf__solaris.adb
+++ b/gcc/ada/libgnarl/s-tasinf__solaris.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tasinf__solaris.ads b/gcc/ada/libgnarl/s-tasinf__solaris.ads
index 0d2cbfd..58687fd 100644
--- a/gcc/ada/libgnarl/s-tasinf__solaris.ads
+++ b/gcc/ada/libgnarl/s-tasinf__solaris.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tasinf__vxworks.ads b/gcc/ada/libgnarl/s-tasinf__vxworks.ads
index 7b573fb..52eb587 100644
--- a/gcc/ada/libgnarl/s-tasinf__vxworks.ads
+++ b/gcc/ada/libgnarl/s-tasinf__vxworks.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tasini.adb b/gcc/ada/libgnarl/s-tasini.adb
index 516b6e7..cdcb0ba 100644
--- a/gcc/ada/libgnarl/s-tasini.adb
+++ b/gcc/ada/libgnarl/s-tasini.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -44,7 +44,6 @@ with System.Soft_Links;
with System.Soft_Links.Tasking;
with System.Tasking.Debug;
with System.Tasking.Task_Attributes;
-with System.Parameters;
with System.Secondary_Stack;
pragma Elaborate_All (System.Secondary_Stack);
@@ -244,18 +243,10 @@ package body System.Tasking.Initialization is
Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1;
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Self_ID);
Self_ID.Pending_Action := False;
Unlock (Self_ID);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
-- Restore the original Deferral value
Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1;
@@ -309,7 +300,7 @@ package body System.Tasking.Initialization is
procedure Final_Task_Unlock (Self_ID : Task_Id) is
begin
pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting = 1);
- Unlock (Global_Task_Lock'Access, Global_Lock => True);
+ Unlock (Global_Task_Lock'Access);
end Final_Task_Unlock;
--------------
@@ -563,7 +554,7 @@ package body System.Tasking.Initialization is
if Self_ID.Common.Global_Task_Lock_Nesting = 1 then
Defer_Abort_Nestable (Self_ID);
- Write_Lock (Global_Task_Lock'Access, Global_Lock => True);
+ Write_Lock (Global_Task_Lock'Access);
end if;
end Task_Lock;
@@ -593,7 +584,7 @@ package body System.Tasking.Initialization is
Self_ID.Common.Global_Task_Lock_Nesting - 1;
if Self_ID.Common.Global_Task_Lock_Nesting = 0 then
- Unlock (Global_Task_Lock'Access, Global_Lock => True);
+ Unlock (Global_Task_Lock'Access);
Undefer_Abort_Nestable (Self_ID);
end if;
end Task_Unlock;
diff --git a/gcc/ada/libgnarl/s-tasini.ads b/gcc/ada/libgnarl/s-tasini.ads
index 9a032b3..f8fc3e9 100644
--- a/gcc/ada/libgnarl/s-tasini.ads
+++ b/gcc/ada/libgnarl/s-tasini.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-taskin.adb b/gcc/ada/libgnarl/s-taskin.adb
index 7842b08..1c6ab4a 100644
--- a/gcc/ada/libgnarl/s-taskin.adb
+++ b/gcc/ada/libgnarl/s-taskin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-taskin.ads b/gcc/ada/libgnarl/s-taskin.ads
index b2ae675..db1e3b9 100644
--- a/gcc/ada/libgnarl/s-taskin.ads
+++ b/gcc/ada/libgnarl/s-taskin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -368,6 +368,14 @@ package System.Tasking is
-- Used to represent protected procedures to be executed when task
-- terminates.
+ type Initialization_Handler is access procedure;
+ pragma Favor_Top_Level (Initialization_Handler);
+ -- Use to represent procedures to be executed at task initialization.
+
+ Global_Initialization_Handler : Initialization_Handler := null;
+ pragma Atomic (Global_Initialization_Handler);
+ -- Global handler called when each task initializes.
+
------------------------------------
-- Dispatching domain definitions --
------------------------------------
diff --git a/gcc/ada/libgnarl/s-taspri__dummy.ads b/gcc/ada/libgnarl/s-taspri__dummy.ads
index c1529f8..6428ec9 100644
--- a/gcc/ada/libgnarl/s-taspri__dummy.ads
+++ b/gcc/ada/libgnarl/s-taspri__dummy.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-taspri__hpux-dce.ads b/gcc/ada/libgnarl/s-taspri__hpux-dce.ads
index 7e61613..65eda3c 100644
--- a/gcc/ada/libgnarl/s-taspri__hpux-dce.ads
+++ b/gcc/ada/libgnarl/s-taspri__hpux-dce.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-taspri__lynxos.ads b/gcc/ada/libgnarl/s-taspri__lynxos.ads
index 1a05310..1e54e4c 100644
--- a/gcc/ada/libgnarl/s-taspri__lynxos.ads
+++ b/gcc/ada/libgnarl/s-taspri__lynxos.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-taspri__mingw.ads b/gcc/ada/libgnarl/s-taspri__mingw.ads
index dd0f837..ecf0958 100644
--- a/gcc/ada/libgnarl/s-taspri__mingw.ads
+++ b/gcc/ada/libgnarl/s-taspri__mingw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads b/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads
index 3651e45..30475c8 100644
--- a/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads
+++ b/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-taspri__posix.ads b/gcc/ada/libgnarl/s-taspri__posix.ads
index ebf6a98..89a35ad 100644
--- a/gcc/ada/libgnarl/s-taspri__posix.ads
+++ b/gcc/ada/libgnarl/s-taspri__posix.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-taspri__solaris.ads b/gcc/ada/libgnarl/s-taspri__solaris.ads
index 35d5d41..bc45168 100644
--- a/gcc/ada/libgnarl/s-taspri__solaris.ads
+++ b/gcc/ada/libgnarl/s-taspri__solaris.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-taspri__vxworks.ads b/gcc/ada/libgnarl/s-taspri__vxworks.ads
index 7801bce..92cd88c 100644
--- a/gcc/ada/libgnarl/s-taspri__vxworks.ads
+++ b/gcc/ada/libgnarl/s-taspri__vxworks.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tasque.adb b/gcc/ada/libgnarl/s-tasque.adb
index 67b1280..7a9211a 100644
--- a/gcc/ada/libgnarl/s-tasque.adb
+++ b/gcc/ada/libgnarl/s-tasque.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -35,11 +35,9 @@
with System.Task_Primitives.Operations;
with System.Tasking.Initialization;
-with System.Parameters;
package body System.Tasking.Queuing is
- use Parameters;
use Task_Primitives.Operations;
use Protected_Objects;
use Protected_Objects.Entries;
@@ -68,15 +66,10 @@ package body System.Tasking.Queuing is
procedure Broadcast_Program_Error
(Self_ID : Task_Id;
Object : Protection_Entries_Access;
- Pending_Call : Entry_Call_Link;
- RTS_Locked : Boolean := False)
+ Pending_Call : Entry_Call_Link)
is
Entry_Call : Entry_Call_Link;
begin
- if Single_Lock and then not RTS_Locked then
- Lock_RTS;
- end if;
-
if Pending_Call /= null then
Send_Program_Error (Self_ID, Pending_Call);
end if;
@@ -91,10 +84,6 @@ package body System.Tasking.Queuing is
Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
end loop;
end loop;
-
- if Single_Lock and then not RTS_Locked then
- Unlock_RTS;
- end if;
end Broadcast_Program_Error;
-----------------
diff --git a/gcc/ada/libgnarl/s-tasque.ads b/gcc/ada/libgnarl/s-tasque.ads
index ea3dd9e..0754019 100644
--- a/gcc/ada/libgnarl/s-tasque.ads
+++ b/gcc/ada/libgnarl/s-tasque.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -38,13 +38,10 @@ package System.Tasking.Queuing is
procedure Broadcast_Program_Error
(Self_ID : Task_Id;
Object : POE.Protection_Entries_Access;
- Pending_Call : Entry_Call_Link;
- RTS_Locked : Boolean := False);
+ Pending_Call : Entry_Call_Link);
-- Raise Program_Error in all tasks calling the protected entries of Object
-- The exception will not be raised immediately for the calling task; it
-- will be deferred until it calls Check_Exception.
- -- RTS_Locked indicates whether the global RTS lock is taken (only
- -- relevant if Single_Lock is True).
procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link);
-- Enqueue Call at the end of entry_queue E
diff --git a/gcc/ada/libgnarl/s-tasren.adb b/gcc/ada/libgnarl/s-tasren.adb
index f0c9259..567b955 100644
--- a/gcc/ada/libgnarl/s-tasren.adb
+++ b/gcc/ada/libgnarl/s-tasren.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -37,7 +37,6 @@ with System.Tasking.Utilities;
with System.Tasking.Protected_Objects.Operations;
with System.Tasking.Debug;
with System.Restrictions;
-with System.Parameters;
package body System.Tasking.Rendezvous is
@@ -45,7 +44,6 @@ package body System.Tasking.Rendezvous is
package POO renames Protected_Objects.Operations;
package POE renames Protected_Objects.Entries;
- use Parameters;
use Task_Primitives.Operations;
type Select_Treatment is (
@@ -155,11 +153,6 @@ package body System.Tasking.Rendezvous is
begin
Initialization.Defer_Abort (Self_Id);
-
- if Single_Lock then
- Lock_RTS;
- end if;
-
STPO.Write_Lock (Self_Id);
if not Self_Id.Callable then
@@ -168,11 +161,6 @@ package body System.Tasking.Rendezvous is
pragma Assert (Self_Id.Pending_Action);
STPO.Unlock (Self_Id);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Initialization.Undefer_Abort (Self_Id);
-- Should never get here ???
@@ -221,13 +209,7 @@ package body System.Tasking.Rendezvous is
-- return, we will start the rendezvous.
STPO.Unlock (Self_Id);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Initialization.Undefer_Abort (Self_Id);
-
end Accept_Call;
--------------------
@@ -242,11 +224,6 @@ package body System.Tasking.Rendezvous is
begin
Initialization.Defer_Abort_Nestable (Self_Id);
-
- if Single_Lock then
- Lock_RTS;
- end if;
-
STPO.Write_Lock (Self_Id);
if not Self_Id.Callable then
@@ -255,11 +232,6 @@ package body System.Tasking.Rendezvous is
pragma Assert (Self_Id.Pending_Action);
STPO.Unlock (Self_Id);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Initialization.Undefer_Abort_Nestable (Self_Id);
-- Should never get here ???
@@ -303,10 +275,6 @@ package body System.Tasking.Rendezvous is
STPO.Unlock (Caller);
end if;
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Initialization.Undefer_Abort_Nestable (Self_Id);
end Accept_Trivial;
@@ -401,20 +369,12 @@ package body System.Tasking.Rendezvous is
-- Note: the caller will undefer abort on return (see WARNING above)
- if Single_Lock then
- Lock_RTS;
- end if;
-
if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
STPO.Write_Lock (Self_Id);
Utilities.Exit_One_ATC_Level (Self_Id);
STPO.Unlock (Self_Id);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Local_Undefer_Abort (Self_Id);
+
raise Tasking_Error;
end if;
@@ -426,11 +386,6 @@ package body System.Tasking.Rendezvous is
(Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R'));
Rendezvous_Successful := Entry_Call.State = Done;
STPO.Unlock (Self_Id);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Local_Undefer_Abort (Self_Id);
Entry_Calls.Check_Exception (Self_Id, Entry_Call);
end Call_Synchronous;
@@ -445,20 +400,11 @@ package body System.Tasking.Rendezvous is
begin
Initialization.Defer_Abort_Nestable (Self_Id);
-
- if Single_Lock then
- Lock_RTS;
- end if;
-
STPO.Write_Lock (T);
Result := T.Callable;
STPO.Unlock (T);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Initialization.Undefer_Abort_Nestable (Self_Id);
+
return Result;
end Callable;
@@ -545,10 +491,6 @@ package body System.Tasking.Rendezvous is
-- it was aborted.
if Ex = Standard'Abort_Signal'Identity then
- if Single_Lock then
- Lock_RTS;
- end if;
-
while Entry_Call /= null loop
Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
@@ -568,11 +510,6 @@ package body System.Tasking.Rendezvous is
STPO.Unlock (Caller);
Entry_Call := Entry_Call.Acceptor_Prev_Call;
end loop;
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
else
Caller := Entry_Call.Self;
@@ -588,23 +525,10 @@ package body System.Tasking.Rendezvous is
-- Requeue to another task entry
- if Single_Lock then
- Lock_RTS;
- end if;
-
if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Initialization.Undefer_Abort (Self_Id);
raise Tasking_Error;
end if;
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
else
-- Requeue to a protected entry
@@ -614,20 +538,11 @@ package body System.Tasking.Rendezvous is
if Ceiling_Violation then
pragma Assert (Ex = Ada.Exceptions.Null_Id);
Entry_Call.Exception_To_Raise := Program_Error'Identity;
-
- if Single_Lock then
- Lock_RTS;
- end if;
-
STPO.Write_Lock (Caller);
Initialization.Wakeup_Entry_Caller
(Self_Id, Entry_Call, Done);
STPO.Unlock (Caller);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
else
POO.PO_Do_Or_Queue (Self_Id, Called_PO, Entry_Call);
POO.PO_Service_Entries (Self_Id, Called_PO);
@@ -642,11 +557,6 @@ package body System.Tasking.Rendezvous is
Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
Entry_Call.Exception_To_Raise := Ex;
-
- if Single_Lock then
- Lock_RTS;
- end if;
-
STPO.Write_Lock (Caller);
-- Done with Caller locked to make sure that Wakeup is not lost
@@ -661,11 +571,6 @@ package body System.Tasking.Rendezvous is
Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
STPO.Unlock (Caller);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority);
end if;
end if;
@@ -733,11 +638,6 @@ package body System.Tasking.Rendezvous is
begin
Initialization.Defer_Abort (Self_Id);
-
- if Single_Lock then
- Lock_RTS;
- end if;
-
STPO.Write_Lock (Self_Id);
if not Self_Id.Callable then
@@ -747,10 +647,6 @@ package body System.Tasking.Rendezvous is
STPO.Unlock (Self_Id);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
-- ??? In some cases abort is deferred more than once. Need to
-- figure out why this happens.
@@ -902,10 +798,6 @@ package body System.Tasking.Rendezvous is
STPO.Unlock (Self_Id);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Index := Self_Id.Chosen_Index;
Initialization.Undefer_Abort_Nestable (Self_Id);
@@ -961,21 +853,11 @@ package body System.Tasking.Rendezvous is
else
STPO.Unlock (Self_Id);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Initialization.Undefer_Abort (Self_Id);
- raise Program_Error with
- "entry call not a delay mode";
+ raise Program_Error with "entry call not a delay mode";
end if;
end case;
- if Single_Lock then
- Unlock_RTS;
- end if;
-
-- Caller has been chosen
-- Self_Id.Common.Call should already be updated by the Caller.
@@ -1018,19 +900,9 @@ package body System.Tasking.Rendezvous is
begin
Initialization.Defer_Abort (Self_Id);
-
- if Single_Lock then
- Lock_RTS;
- end if;
-
STPO.Write_Lock (Self_Id);
Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
STPO.Unlock (Self_Id);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Initialization.Undefer_Abort (Self_Id);
return Return_Count;
@@ -1306,19 +1178,10 @@ package body System.Tasking.Rendezvous is
Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
Entry_Call.With_Abort := True;
- if Single_Lock then
- Lock_RTS;
- end if;
-
if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
STPO.Write_Lock (Self_Id);
Utilities.Exit_One_ATC_Level (Self_Id);
STPO.Unlock (Self_Id);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Initialization.Undefer_Abort (Self_Id);
raise Tasking_Error;
@@ -1335,10 +1198,6 @@ package body System.Tasking.Rendezvous is
Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
end if;
- if Single_Lock then
- Unlock_RTS;
- end if;
-
-- Note: following assignment needs to be atomic
Rendezvous_Successful := Entry_Call.State = Done;
@@ -1392,10 +1251,6 @@ package body System.Tasking.Rendezvous is
-- If we are aborted here, the effect will be pending
- if Single_Lock then
- Lock_RTS;
- end if;
-
STPO.Write_Lock (Self_Id);
if not Self_Id.Callable then
@@ -1404,11 +1259,6 @@ package body System.Tasking.Rendezvous is
pragma Assert (Self_Id.Pending_Action);
STPO.Unlock (Self_Id);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Initialization.Undefer_Abort (Self_Id);
-- Should never get here ???
@@ -1484,21 +1334,13 @@ package body System.Tasking.Rendezvous is
-- caller a chance of getting ready immediately, using Unlock
-- Yield. See similar action in Wait_For_Completion/Wait_For_Call.
- if Single_Lock then
- Unlock_RTS;
- else
- Unlock (Self_Id);
- end if;
+ Unlock (Self_Id);
if Self_Id.Open_Accepts /= null then
Yield;
end if;
- if Single_Lock then
- Lock_RTS;
- else
- Write_Lock (Self_Id);
- end if;
+ Write_Lock (Self_Id);
-- Check if this task has been aborted while the lock was released
@@ -1574,10 +1416,6 @@ package body System.Tasking.Rendezvous is
null;
end case;
- if Single_Lock then
- Unlock_RTS;
- end if;
-
if not Yielded then
Yield;
end if;
@@ -1657,19 +1495,10 @@ package body System.Tasking.Rendezvous is
-- Note: the caller will undefer abort on return (see WARNING above)
- if Single_Lock then
- Lock_RTS;
- end if;
-
if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
STPO.Write_Lock (Self_Id);
Utilities.Exit_One_ATC_Level (Self_Id);
STPO.Unlock (Self_Id);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Initialization.Undefer_Abort (Self_Id);
raise Tasking_Error;
@@ -1680,10 +1509,6 @@ package body System.Tasking.Rendezvous is
(Entry_Call, Timeout, Mode, Yielded);
Unlock (Self_Id);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
-- ??? Do we need to yield in case Yielded is False
Rendezvous_Successful := Entry_Call.State = Done;
@@ -1703,21 +1528,13 @@ package body System.Tasking.Rendezvous is
-- a chance of getting ready immediately, using Unlock & Yield.
-- See similar action in Wait_For_Completion & Timed_Selective_Wait.
- if Single_Lock then
- Unlock_RTS;
- else
- Unlock (Self_Id);
- end if;
+ Unlock (Self_Id);
if Self_Id.Open_Accepts /= null then
Yield;
end if;
- if Single_Lock then
- Lock_RTS;
- else
- Write_Lock (Self_Id);
- end if;
+ Write_Lock (Self_Id);
-- Check if this task has been aborted while the lock was released
diff --git a/gcc/ada/libgnarl/s-tasren.ads b/gcc/ada/libgnarl/s-tasren.ads
index 77c12c0..52b21c3 100644
--- a/gcc/ada/libgnarl/s-tasren.ads
+++ b/gcc/ada/libgnarl/s-tasren.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -317,8 +317,7 @@ package System.Tasking.Rendezvous is
function Task_Do_Or_Queue
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link) return Boolean;
- -- Call this only with abort deferred and holding no locks, except
- -- the global RTS lock when Single_Lock is True which must be owned.
+ -- Call this only with abort deferred and holding no locks.
-- Returns False iff the call cannot be served or queued, as is the
-- case if the caller is not callable; i.e., a False return value
-- indicates that Tasking_Error should be raised.
diff --git a/gcc/ada/libgnarl/s-tasres.ads b/gcc/ada/libgnarl/s-tasres.ads
index 367b631..b108e5b 100644
--- a/gcc/ada/libgnarl/s-tasres.ads
+++ b/gcc/ada/libgnarl/s-tasres.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tassta.adb b/gcc/ada/libgnarl/s-tassta.adb
index b6be815..c594027 100644
--- a/gcc/ada/libgnarl/s-tassta.adb
+++ b/gcc/ada/libgnarl/s-tassta.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -74,7 +74,6 @@ package body System.Tasking.Stages is
use Ada.Exceptions;
- use Parameters;
use Secondary_Stack;
use Task_Primitives;
use Task_Primitives.Operations;
@@ -341,9 +340,7 @@ package body System.Tasking.Stages is
C := C.Common.Activation_Link;
end loop;
- if not Single_Lock then
- Unlock_RTS;
- end if;
+ Unlock_RTS;
-- Close the entries of any tasks that failed thread creation, and count
-- those that have not finished activation.
@@ -382,10 +379,6 @@ package body System.Tasking.Stages is
Self_ID.Common.State := Runnable;
Unlock (Self_ID);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
-- Remove the tasks from the chain
Chain_Access.T_ID := null;
@@ -406,17 +399,7 @@ package body System.Tasking.Stages is
begin
Initialization.Defer_Abort_Nestable (Self_ID);
-
- if Single_Lock then
- Lock_RTS;
- end if;
-
Vulnerable_Complete_Activation (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Initialization.Undefer_Abort_Nestable (Self_ID);
-- ??? Why do we need to allow for nested deferral here?
@@ -846,12 +829,8 @@ package body System.Tasking.Stages is
-- Force termination of "independent" library-level server tasks
Lock_RTS;
-
Abort_Dependents (Self_ID);
-
- if not Single_Lock then
- Unlock_RTS;
- end if;
+ Unlock_RTS;
-- We need to explicitly wait for the task to be terminated here
-- because on true concurrent system, we may end this procedure before
@@ -891,10 +870,6 @@ package body System.Tasking.Stages is
Unlock (Self_ID);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
-- Complete the environment task
Vulnerable_Complete_Task (Self_ID);
@@ -1212,6 +1187,12 @@ package body System.Tasking.Stages is
-- we do not call Set_Jmpbuf_Address (which needs Self) before we
-- set Self in Enter_Task
+ -- Call the initialization hook if any
+
+ if Global_Initialization_Handler /= null then
+ Global_Initialization_Handler.all;
+ end if;
+
-- Call the task body procedure
-- The task body is called with abort still deferred. That
@@ -1294,10 +1275,6 @@ package body System.Tasking.Stages is
-- the environment task. The task termination code for the environment
-- task is executed by SSL.Task_Termination_Handler.
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Self_ID);
if Self_ID.Common.Specific_Handler /= null then
@@ -1320,10 +1297,6 @@ package body System.Tasking.Stages is
Unlock (Self_ID);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
-- Execute the task termination handler if we found it
if TH /= null then
@@ -1393,26 +1366,16 @@ package body System.Tasking.Stages is
Initialization.Task_Lock (Self_ID);
- if Single_Lock then
- Lock_RTS;
- end if;
-
Master_Of_Task := Self_ID.Master_Of_Task;
-- Check if the current task is an independent task If so, decrement
-- the Independent_Task_Count value.
if Master_Of_Task = Independent_Task_Level then
- if Single_Lock then
- Utilities.Independent_Task_Count :=
- Utilities.Independent_Task_Count - 1;
-
- else
- Write_Lock (Environment_Task);
- Utilities.Independent_Task_Count :=
- Utilities.Independent_Task_Count - 1;
- Unlock (Environment_Task);
- end if;
+ Write_Lock (Environment_Task);
+ Utilities.Independent_Task_Count :=
+ Utilities.Independent_Task_Count - 1;
+ Unlock (Environment_Task);
end if;
-- Unprotect the guard page if needed
@@ -1422,10 +1385,6 @@ package body System.Tasking.Stages is
Utilities.Make_Passive (Self_ID, Task_Completed => True);
Deallocate := Self_ID.Free_On_Termination;
- if Single_Lock then
- Unlock_RTS;
- end if;
-
pragma Assert (Check_Exit (Self_ID));
SSL.Destroy_TSD (Self_ID.Common.Compiler_Data);
@@ -1454,20 +1413,11 @@ package body System.Tasking.Stages is
begin
Initialization.Defer_Abort_Nestable (Self_ID);
-
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (T);
Result := T.Common.State = Terminated;
Unlock (T);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Initialization.Undefer_Abort_Nestable (Self_ID);
+
return Result;
end Terminated;
@@ -1600,10 +1550,7 @@ package body System.Tasking.Stages is
function Check_Unactivated_Tasks return Boolean is
begin
- if not Single_Lock then
- Lock_RTS;
- end if;
-
+ Lock_RTS;
Write_Lock (Self_ID);
C := All_Tasks_List;
@@ -1626,10 +1573,7 @@ package body System.Tasking.Stages is
end loop;
Unlock (Self_ID);
-
- if not Single_Lock then
- Unlock_RTS;
- end if;
+ Unlock_RTS;
return True;
end Check_Unactivated_Tasks;
@@ -1698,10 +1642,7 @@ package body System.Tasking.Stages is
Self_ID.Common.State := Master_Completion_Sleep;
Unlock (Self_ID);
-
- if not Single_Lock then
- Unlock_RTS;
- end if;
+ Unlock_RTS;
-- Wait until dependent tasks are all terminated or ready to terminate.
-- While waiting, the task may be awakened if the task's priority needs
@@ -1718,15 +1659,11 @@ package body System.Tasking.Stages is
if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
and then not Self_ID.Dependents_Aborted
then
- if Single_Lock then
- Abort_Dependents (Self_ID);
- else
- Unlock (Self_ID);
- Lock_RTS;
- Abort_Dependents (Self_ID);
- Unlock_RTS;
- Write_Lock (Self_ID);
- end if;
+ Unlock (Self_ID);
+ Lock_RTS;
+ Abort_Dependents (Self_ID);
+ Unlock_RTS;
+ Write_Lock (Self_ID);
else
pragma Debug
(Debug.Trace (Self_ID, "master_completion_sleep", 'C'));
@@ -1753,10 +1690,7 @@ package body System.Tasking.Stages is
-- Force any remaining dependents to terminate by aborting them
- if not Single_Lock then
- Lock_RTS;
- end if;
-
+ Lock_RTS;
Abort_Dependents (Self_ID);
-- Above, when we "abort" the dependents we are simply using this
@@ -1801,10 +1735,7 @@ package body System.Tasking.Stages is
Self_ID.Common.State := Master_Phase_2_Sleep;
Unlock (Self_ID);
-
- if not Single_Lock then
- Unlock_RTS;
- end if;
+ Unlock_RTS;
-- Wait for all counted tasks to finish terminating themselves
@@ -1828,10 +1759,7 @@ package body System.Tasking.Stages is
-- locks. Instead, we put those ATCBs to be freed onto a temporary list,
-- called To_Be_Freed.
- if not Single_Lock then
- Lock_RTS;
- end if;
-
+ Lock_RTS;
C := All_Tasks_List;
P := null;
while C /= null loop
@@ -1986,10 +1914,6 @@ package body System.Tasking.Stages is
pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C'));
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Self_ID);
Self_ID.Callable := False;
@@ -2005,10 +1929,6 @@ package body System.Tasking.Stages is
Vulnerable_Complete_Activation (Self_ID);
end if;
- if Single_Lock then
- Unlock_RTS;
- end if;
-
-- If Self_ID.Master_Within = Self_ID.Master_Of_Task + 2 we may have
-- dependent tasks for which we need to wait. Otherwise we just exit.
@@ -2035,18 +1955,10 @@ package body System.Tasking.Stages is
begin
pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T));
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (T);
Initialization.Finalize_Attributes (T);
Unlock (T);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
System.Task_Primitives.Operations.Finalize_TCB (T);
end Vulnerable_Free_Task;
diff --git a/gcc/ada/libgnarl/s-tassta.ads b/gcc/ada/libgnarl/s-tassta.ads
index 88cb21a..772d058 100644
--- a/gcc/ada/libgnarl/s-tassta.ads
+++ b/gcc/ada/libgnarl/s-tassta.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tasuti.adb b/gcc/ada/libgnarl/s-tasuti.adb
index fb331ae..90c5bd9 100644
--- a/gcc/ada/libgnarl/s-tasuti.adb
+++ b/gcc/ada/libgnarl/s-tasuti.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -41,13 +41,11 @@ with System.Tasking.Debug;
with System.Task_Primitives.Operations;
with System.Tasking.Initialization;
with System.Tasking.Queuing;
-with System.Parameters;
package body System.Tasking.Utilities is
package STPO renames System.Task_Primitives.Operations;
- use Parameters;
use Tasking.Debug;
use Task_Primitives;
use Task_Primitives.Operations;
@@ -58,7 +56,7 @@ package body System.Tasking.Utilities is
-- Similar to Locked_Abort_To_Level (Self_ID, T, Level_Completed_Task),
-- but:
- -- (1) caller should be holding no locks except RTS_Lock when Single_Lock
+ -- (1) caller should be holding no locks
-- (2) may be called for tasks that have not yet been activated
-- (3) always aborts whole task
@@ -248,11 +246,6 @@ package body System.Tasking.Utilities is
end if;
Initialization.Defer_Abort (Self_Id);
-
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Environment_Task);
Write_Lock (Self_Id);
@@ -277,11 +270,6 @@ package body System.Tasking.Utilities is
pragma Assert (Environment_Task.Common.State /= Master_Completion_Sleep);
Unlock (Environment_Task);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Initialization.Undefer_Abort (Self_Id);
-- Return True. Actually the return value is junk, since we expect it
diff --git a/gcc/ada/libgnarl/s-tasuti.ads b/gcc/ada/libgnarl/s-tasuti.ads
index 0a08b5f..1ef237e 100644
--- a/gcc/ada/libgnarl/s-tasuti.ads
+++ b/gcc/ada/libgnarl/s-tasuti.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -102,7 +102,7 @@ package System.Tasking.Utilities is
procedure Cancel_Queued_Entry_Calls (T : Task_Id);
-- Cancel any entry calls queued on target task.
- -- Call this while holding T's lock (or RTS_Lock in Single_Lock mode).
+ -- Call this while holding T's lock.
procedure Exit_One_ATC_Level (Self_ID : Task_Id);
pragma Inline (Exit_One_ATC_Level);
@@ -124,7 +124,6 @@ package System.Tasking.Utilities is
procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean);
-- Update counts to indicate current task is either terminated or
-- accepting on a terminate alternative. Call holding no locks except
- -- Global_Task_Lock when calling from Terminate_Task, and RTS_Lock when
- -- Single_Lock is True.
+ -- Global_Task_Lock when calling from Terminate_Task.
end System.Tasking.Utilities;
diff --git a/gcc/ada/libgnarl/s-tataat.adb b/gcc/ada/libgnarl/s-tataat.adb
index 2c8001d..8ca1b8e 100644
--- a/gcc/ada/libgnarl/s-tataat.adb
+++ b/gcc/ada/libgnarl/s-tataat.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tataat.ads b/gcc/ada/libgnarl/s-tataat.ads
index 5ae9a75..5515edb4 100644
--- a/gcc/ada/libgnarl/s-tataat.ads
+++ b/gcc/ada/libgnarl/s-tataat.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tpinop.adb b/gcc/ada/libgnarl/s-tpinop.adb
index 906f066..fbed553 100644
--- a/gcc/ada/libgnarl/s-tpinop.adb
+++ b/gcc/ada/libgnarl/s-tpinop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tpinop.ads b/gcc/ada/libgnarl/s-tpinop.ads
index c4f3e3b..1d91f19 100644
--- a/gcc/ada/libgnarl/s-tpinop.ads
+++ b/gcc/ada/libgnarl/s-tpinop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tpoaal.adb b/gcc/ada/libgnarl/s-tpoaal.adb
index 55fbacb..44eb7c0 100644
--- a/gcc/ada/libgnarl/s-tpoaal.adb
+++ b/gcc/ada/libgnarl/s-tpoaal.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tpoben.adb b/gcc/ada/libgnarl/s-tpoben.adb
index 30fb994..ae06ede 100644
--- a/gcc/ada/libgnarl/s-tpoben.adb
+++ b/gcc/ada/libgnarl/s-tpoben.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -43,7 +43,6 @@
with System.Task_Primitives.Operations;
with System.Restrictions;
-with System.Parameters;
with System.Tasking.Initialization;
pragma Elaborate_All (System.Tasking.Initialization);
@@ -53,7 +52,6 @@ package body System.Tasking.Protected_Objects.Entries is
package STPO renames System.Task_Primitives.Operations;
- use Parameters;
use Task_Primitives.Operations;
----------------
@@ -81,10 +79,6 @@ package body System.Tasking.Protected_Objects.Entries is
STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
- if Single_Lock then
- Lock_RTS;
- end if;
-
if Ceiling_Violation then
-- Dip our own priority down to ceiling of lock. See similar code in
@@ -95,21 +89,12 @@ package body System.Tasking.Protected_Objects.Entries is
Self_ID.New_Base_Priority := Object.Ceiling;
Initialization.Change_Base_Priority (Self_ID);
STPO.Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
if Ceiling_Violation then
raise Program_Error with "ceiling violation";
end if;
- if Single_Lock then
- Lock_RTS;
- end if;
-
Object.Old_Base_Priority := Old_Base_Priority;
Object.Pending_Action := True;
end if;
@@ -133,13 +118,7 @@ package body System.Tasking.Protected_Objects.Entries is
end loop;
Object.Finalized := True;
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
STPO.Unlock (Object.L'Unrestricted_Access);
-
STPO.Finalize_Lock (Object.L'Unrestricted_Access);
end Finalize;
diff --git a/gcc/ada/libgnarl/s-tpoben.ads b/gcc/ada/libgnarl/s-tpoben.ads
index 98902ac..0455f55 100644
--- a/gcc/ada/libgnarl/s-tpoben.ads
+++ b/gcc/ada/libgnarl/s-tpoben.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tpobmu.adb b/gcc/ada/libgnarl/s-tpobmu.adb
index 6963247..d5b6310 100644
--- a/gcc/ada/libgnarl/s-tpobmu.adb
+++ b/gcc/ada/libgnarl/s-tpobmu.adb
@@ -6,7 +6,7 @@
-- M U L T I P R O C E S S O R S --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, AdaCore --
+-- Copyright (C) 2010-2020, AdaCore --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tpobmu.ads b/gcc/ada/libgnarl/s-tpobmu.ads
index f1f1190..8487606 100644
--- a/gcc/ada/libgnarl/s-tpobmu.ads
+++ b/gcc/ada/libgnarl/s-tpobmu.ads
@@ -6,7 +6,7 @@
-- M U L T I P R O C E S S O R S --
-- S p e c --
-- --
--- Copyright (C) 2010-2019, AdaCore --
+-- Copyright (C) 2010-2020, AdaCore --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tpobop.adb b/gcc/ada/libgnarl/s-tpobop.adb
index 0cd0704..5537c1a 100644
--- a/gcc/ada/libgnarl/s-tpobop.adb
+++ b/gcc/ada/libgnarl/s-tpobop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -48,7 +48,6 @@ with System.Tasking.Queuing;
with System.Tasking.Rendezvous;
with System.Tasking.Utilities;
with System.Tasking.Debug;
-with System.Parameters;
with System.Restrictions;
with System.Tasking.Initialization;
@@ -59,7 +58,6 @@ package body System.Tasking.Protected_Objects.Operations is
package STPO renames System.Task_Primitives.Operations;
- use Parameters;
use Ada.Exceptions;
use Entries;
@@ -313,19 +311,10 @@ package body System.Tasking.Protected_Objects.Operations is
-- Body of current entry served call to completion
Object.Call_In_Progress := null;
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Entry_Call.Self);
Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
STPO.Unlock (Entry_Call.Self);
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
else
Requeue_Call (Self_ID, Object, Entry_Call);
end if;
@@ -353,19 +342,10 @@ package body System.Tasking.Protected_Objects.Operations is
-- Max_Queue_Length bound, raise Program_Error.
Entry_Call.Exception_To_Raise := Program_Error'Identity;
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Entry_Call.Self);
Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
STPO.Unlock (Entry_Call.Self);
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
return;
end if;
end if;
@@ -379,18 +359,10 @@ package body System.Tasking.Protected_Objects.Operations is
else
-- Conditional_Call and With_Abort
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Entry_Call.Self);
pragma Assert (Entry_Call.State /= Not_Yet_Abortable);
Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
STPO.Unlock (Entry_Call.Self);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
end if;
exception
@@ -437,8 +409,7 @@ package body System.Tasking.Protected_Objects.Operations is
exception
when others =>
- Queuing.Broadcast_Program_Error
- (Self_ID, Object, Entry_Call);
+ Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call);
end;
if Object.Call_In_Progress = null then
@@ -448,18 +419,9 @@ package body System.Tasking.Protected_Objects.Operations is
else
Object.Call_In_Progress := null;
Caller := Entry_Call.Self;
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Caller);
Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
STPO.Unlock (Caller);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
end if;
end loop;
@@ -608,18 +570,10 @@ package body System.Tasking.Protected_Objects.Operations is
-- Once State >= Done it will not change any more
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Self_ID);
Utilities.Exit_One_ATC_Level (Self_ID);
STPO.Unlock (Self_ID);
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
Block.Enqueued := False;
Block.Cancelled := Entry_Call.State = Cancelled;
Initialization.Undefer_Abort_Nestable (Self_ID);
@@ -640,13 +594,7 @@ package body System.Tasking.Protected_Objects.Operations is
-- Try to avoid an expensive call
if not Initially_Abortable then
- if Single_Lock then
- STPO.Lock_RTS;
- Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
- STPO.Unlock_RTS;
- else
- Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
- end if;
+ Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
end if;
else
@@ -654,16 +602,9 @@ package body System.Tasking.Protected_Objects.Operations is
when Conditional_Call
| Simple_Call
=>
- if Single_Lock then
- STPO.Lock_RTS;
- Entry_Calls.Wait_For_Completion (Entry_Call);
- STPO.Unlock_RTS;
-
- else
- STPO.Write_Lock (Self_ID);
- Entry_Calls.Wait_For_Completion (Entry_Call);
- STPO.Unlock (Self_ID);
- end if;
+ STPO.Write_Lock (Self_ID);
+ Entry_Calls.Wait_For_Completion (Entry_Call);
+ STPO.Unlock (Self_ID);
Block.Cancelled := Entry_Call.State = Cancelled;
@@ -700,21 +641,11 @@ package body System.Tasking.Protected_Objects.Operations is
-- Call is to be requeued to a task entry
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
Result := Rendezvous.Task_Do_Or_Queue (Self_Id, Entry_Call);
if not Result then
- Queuing.Broadcast_Program_Error
- (Self_Id, Object, Entry_Call, RTS_Locked => True);
+ Queuing.Broadcast_Program_Error (Self_Id, Object, Entry_Call);
end if;
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
else
-- Call should be requeued to a PO
@@ -767,19 +698,11 @@ package body System.Tasking.Protected_Objects.Operations is
Entry_Call.Exception_To_Raise := Program_Error'Identity;
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Entry_Call.Self);
Initialization.Wakeup_Entry_Caller
(Self_Id, Entry_Call, Done);
STPO.Unlock (Entry_Call.Self);
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
else
Queuing.Enqueue
(New_Object.Entry_Queues (E), Entry_Call);
@@ -993,23 +916,13 @@ package body System.Tasking.Protected_Objects.Operations is
PO_Do_Or_Queue (Self_Id, Object, Entry_Call);
PO_Service_Entries (Self_Id, Object);
-
- if Single_Lock then
- STPO.Lock_RTS;
- else
- STPO.Write_Lock (Self_Id);
- end if;
+ STPO.Write_Lock (Self_Id);
-- Try to avoid waiting for completed or cancelled calls
if Entry_Call.State >= Done then
Utilities.Exit_One_ATC_Level (Self_Id);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- else
- STPO.Unlock (Self_Id);
- end if;
+ STPO.Unlock (Self_Id);
Entry_Call_Successful := Entry_Call.State = Done;
Initialization.Undefer_Abort_Nestable (Self_Id);
@@ -1019,12 +932,7 @@ package body System.Tasking.Protected_Objects.Operations is
Entry_Calls.Wait_For_Completion_With_Timeout
(Entry_Call, Timeout, Mode, Yielded);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- else
- STPO.Unlock (Self_Id);
- end if;
+ STPO.Unlock (Self_Id);
-- ??? Do we need to yield in case Yielded is False
@@ -1075,10 +983,6 @@ package body System.Tasking.Protected_Objects.Operations is
if Old < Was_Abortable and then
Entry_Call.State = Now_Abortable
then
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Entry_Call.Self);
if Entry_Call.Self.Common.State = Async_Select_Sleep then
@@ -1086,11 +990,6 @@ package body System.Tasking.Protected_Objects.Operations is
end if;
STPO.Unlock (Entry_Call.Self);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
end if;
elsif Entry_Call.Mode = Conditional_Call then
diff --git a/gcc/ada/libgnarl/s-tpobop.ads b/gcc/ada/libgnarl/s-tpobop.ads
index f8592a7..45bd936 100644
--- a/gcc/ada/libgnarl/s-tpobop.ads
+++ b/gcc/ada/libgnarl/s-tpobop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tpopmo.adb b/gcc/ada/libgnarl/s-tpopmo.adb
index 4dfc910..ab70679 100644
--- a/gcc/ada/libgnarl/s-tpopmo.adb
+++ b/gcc/ada/libgnarl/s-tpopmo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -193,9 +193,7 @@ package body Monotonic is
Result :=
pthread_cond_timedwait
(cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access),
+ mutex => Self_ID.Common.LL.L'Access,
abstime => Request'Access);
case Result is
@@ -244,10 +242,6 @@ package body Monotonic is
Exit_Outer : Boolean := False;
begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Self_ID);
Compute_Deadline
@@ -286,9 +280,7 @@ package body Monotonic is
Result :=
pthread_cond_timedwait
(cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access),
+ mutex => Self_ID.Common.LL.L'Access,
abstime => Request'Access);
case Result is
@@ -314,11 +306,6 @@ package body Monotonic is
end if;
Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
pragma Unreferenced (Result);
Result := sched_yield;
end Timed_Delay;
diff --git a/gcc/ada/libgnarl/s-tpopsp__posix-foreign.adb b/gcc/ada/libgnarl/s-tpopsp__posix-foreign.adb
index c429842..e9fd0f9 100644
--- a/gcc/ada/libgnarl/s-tpopsp__posix-foreign.adb
+++ b/gcc/ada/libgnarl/s-tpopsp__posix-foreign.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tpopsp__posix.adb b/gcc/ada/libgnarl/s-tpopsp__posix.adb
index eb18cc3..abe4079 100644
--- a/gcc/ada/libgnarl/s-tpopsp__posix.adb
+++ b/gcc/ada/libgnarl/s-tpopsp__posix.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tpopsp__solaris.adb b/gcc/ada/libgnarl/s-tpopsp__solaris.adb
index 19182ab..d628f95 100644
--- a/gcc/ada/libgnarl/s-tpopsp__solaris.adb
+++ b/gcc/ada/libgnarl/s-tpopsp__solaris.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tpopsp__tls.adb b/gcc/ada/libgnarl/s-tpopsp__tls.adb
index d819515..26171b4 100644
--- a/gcc/ada/libgnarl/s-tpopsp__tls.adb
+++ b/gcc/ada/libgnarl/s-tpopsp__tls.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tpopsp__vxworks-rtp.adb b/gcc/ada/libgnarl/s-tpopsp__vxworks-rtp.adb
index e5f445e..9459841 100644
--- a/gcc/ada/libgnarl/s-tpopsp__vxworks-rtp.adb
+++ b/gcc/ada/libgnarl/s-tpopsp__vxworks-rtp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tpopsp__vxworks-tls.adb b/gcc/ada/libgnarl/s-tpopsp__vxworks-tls.adb
index 0239cd4..e8fa9bd 100644
--- a/gcc/ada/libgnarl/s-tpopsp__vxworks-tls.adb
+++ b/gcc/ada/libgnarl/s-tpopsp__vxworks-tls.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tpopsp__vxworks.adb b/gcc/ada/libgnarl/s-tpopsp__vxworks.adb
index c0c0fa3..265ea2f 100644
--- a/gcc/ada/libgnarl/s-tpopsp__vxworks.adb
+++ b/gcc/ada/libgnarl/s-tpopsp__vxworks.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tporft.adb b/gcc/ada/libgnarl/s-tporft.adb
index f47610b..9d99eac 100644
--- a/gcc/ada/libgnarl/s-tporft.adb
+++ b/gcc/ada/libgnarl/s-tporft.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-tposen.adb b/gcc/ada/libgnarl/s-tposen.adb
index bb4ff51..3545435 100644
--- a/gcc/ada/libgnarl/s-tposen.adb
+++ b/gcc/ada/libgnarl/s-tposen.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -62,14 +62,11 @@ pragma Suppress (All_Checks);
with Ada.Exceptions;
with System.Task_Primitives.Operations;
-with System.Parameters;
package body System.Tasking.Protected_Objects.Single_Entry is
package STPO renames System.Task_Primitives.Operations;
- use Parameters;
-
-----------------------
-- Local Subprograms --
-----------------------
@@ -143,18 +140,9 @@ package body System.Tasking.Protected_Objects.Single_Entry is
begin
Entry_Call.Exception_To_Raise := Program_Error'Identity;
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Caller);
Wakeup_Entry_Caller (Entry_Call);
STPO.Unlock (Caller);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
end Send_Program_Error;
-------------------------
@@ -286,18 +274,10 @@ package body System.Tasking.Protected_Objects.Single_Entry is
(Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
Object.Call_In_Progress := null;
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Entry_Call.Self);
Wakeup_Entry_Caller (Entry_Call);
STPO.Unlock (Entry_Call.Self);
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
else
pragma Assert (Entry_Call.Mode = Simple_Call);
@@ -370,17 +350,9 @@ package body System.Tasking.Protected_Objects.Single_Entry is
pragma Assert (Entry_Call.State /= Cancelled);
if Entry_Call.State /= Done then
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Self_Id);
Wait_For_Completion (Entry_Call'Access);
STPO.Unlock (Self_Id);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
end if;
Check_Exception (Self_Id, Entry_Call'Access);
@@ -427,18 +399,10 @@ package body System.Tasking.Protected_Objects.Single_Entry is
Caller := Entry_Call.Self;
Unlock_Entry (Object);
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Caller);
Wakeup_Entry_Caller (Entry_Call);
STPO.Unlock (Caller);
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
else
-- Just unlock the entry
diff --git a/gcc/ada/libgnarl/s-tposen.ads b/gcc/ada/libgnarl/s-tposen.ads
index 33a67e7..a340697 100644
--- a/gcc/ada/libgnarl/s-tposen.ads
+++ b/gcc/ada/libgnarl/s-tposen.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-vxwext.adb b/gcc/ada/libgnarl/s-vxwext.adb
index cb3c495..ef36c4f 100644
--- a/gcc/ada/libgnarl/s-vxwext.adb
+++ b/gcc/ada/libgnarl/s-vxwext.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-vxwext.ads b/gcc/ada/libgnarl/s-vxwext.ads
index 400e2cd..76c2113 100644
--- a/gcc/ada/libgnarl/s-vxwext.ads
+++ b/gcc/ada/libgnarl/s-vxwext.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-vxwext__kernel-smp.adb b/gcc/ada/libgnarl/s-vxwext__kernel-smp.adb
index 7e1b6a7..99c3c56 100644
--- a/gcc/ada/libgnarl/s-vxwext__kernel-smp.adb
+++ b/gcc/ada/libgnarl/s-vxwext__kernel-smp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-vxwext__kernel.adb b/gcc/ada/libgnarl/s-vxwext__kernel.adb
index 89ab1ea..7c15add 100644
--- a/gcc/ada/libgnarl/s-vxwext__kernel.adb
+++ b/gcc/ada/libgnarl/s-vxwext__kernel.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-vxwext__kernel.ads b/gcc/ada/libgnarl/s-vxwext__kernel.ads
index 35a8744..92fc8f1 100644
--- a/gcc/ada/libgnarl/s-vxwext__kernel.ads
+++ b/gcc/ada/libgnarl/s-vxwext__kernel.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-vxwext__noints.adb b/gcc/ada/libgnarl/s-vxwext__noints.adb
index 044d365..761533e 100644
--- a/gcc/ada/libgnarl/s-vxwext__noints.adb
+++ b/gcc/ada/libgnarl/s-vxwext__noints.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-vxwext__rtp-smp.adb b/gcc/ada/libgnarl/s-vxwext__rtp-smp.adb
index 0f3620d..a48c82c 100644
--- a/gcc/ada/libgnarl/s-vxwext__rtp-smp.adb
+++ b/gcc/ada/libgnarl/s-vxwext__rtp-smp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-vxwext__rtp.adb b/gcc/ada/libgnarl/s-vxwext__rtp.adb
index 1d66622..f60c8bc 100644
--- a/gcc/ada/libgnarl/s-vxwext__rtp.adb
+++ b/gcc/ada/libgnarl/s-vxwext__rtp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-vxwext__rtp.ads b/gcc/ada/libgnarl/s-vxwext__rtp.ads
index 65ce296..229fc8f 100644
--- a/gcc/ada/libgnarl/s-vxwext__rtp.ads
+++ b/gcc/ada/libgnarl/s-vxwext__rtp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-vxwext__vthreads.ads b/gcc/ada/libgnarl/s-vxwext__vthreads.ads
index 71f6ff9..3601688 100644
--- a/gcc/ada/libgnarl/s-vxwext__vthreads.ads
+++ b/gcc/ada/libgnarl/s-vxwext__vthreads.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-vxwork__aarch64.ads b/gcc/ada/libgnarl/s-vxwork__aarch64.ads
index 17c8012..b778f25 100644
--- a/gcc/ada/libgnarl/s-vxwork__aarch64.ads
+++ b/gcc/ada/libgnarl/s-vxwork__aarch64.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-vxwork__arm.ads b/gcc/ada/libgnarl/s-vxwork__arm.ads
index 42b3e72..781626c 100644
--- a/gcc/ada/libgnarl/s-vxwork__arm.ads
+++ b/gcc/ada/libgnarl/s-vxwork__arm.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-vxwork__ppc.ads b/gcc/ada/libgnarl/s-vxwork__ppc.ads
index 6b8a169..2c153a7 100644
--- a/gcc/ada/libgnarl/s-vxwork__ppc.ads
+++ b/gcc/ada/libgnarl/s-vxwork__ppc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/s-vxwork__x86.ads b/gcc/ada/libgnarl/s-vxwork__x86.ads
index dcf22c5..cbe1a61 100644
--- a/gcc/ada/libgnarl/s-vxwork__x86.ads
+++ b/gcc/ada/libgnarl/s-vxwork__x86.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnarl/thread.c b/gcc/ada/libgnarl/thread.c
index 454c9e3..636c619 100644
--- a/gcc/ada/libgnarl/thread.c
+++ b/gcc/ada/libgnarl/thread.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2011-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2011-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/libgnat/a-assert.adb b/gcc/ada/libgnat/a-assert.adb
index c76b7c3..f3fb837 100644
--- a/gcc/ada/libgnat/a-assert.adb
+++ b/gcc/ada/libgnat/a-assert.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-assert.ads b/gcc/ada/libgnat/a-assert.ads
index 362989a..f7aef0f 100644
--- a/gcc/ada/libgnat/a-assert.ads
+++ b/gcc/ada/libgnat/a-assert.ads
@@ -4,7 +4,7 @@
-- --
-- A D A . A S S E R T I O N S --
-- --
--- Copyright (C) 2015-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2020, Free Software Foundation, Inc. --
-- --
-- S p e c --
-- --
diff --git a/gcc/ada/libgnat/a-btgbso.adb b/gcc/ada/libgnat/a-btgbso.adb
index 08b4198..75c6dd5 100644
--- a/gcc/ada/libgnat/a-btgbso.adb
+++ b/gcc/ada/libgnat/a-btgbso.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-btgbso.ads b/gcc/ada/libgnat/a-btgbso.ads
index 389824a..a30ccf3 100644
--- a/gcc/ada/libgnat/a-btgbso.ads
+++ b/gcc/ada/libgnat/a-btgbso.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-calari.adb b/gcc/ada/libgnat/a-calari.adb
index 4c8bf46..27d6da4 100644
--- a/gcc/ada/libgnat/a-calari.adb
+++ b/gcc/ada/libgnat/a-calari.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2006-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-calari.ads b/gcc/ada/libgnat/a-calari.ads
index 4dc26e6..f319572 100644
--- a/gcc/ada/libgnat/a-calari.ads
+++ b/gcc/ada/libgnat/a-calari.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
diff --git a/gcc/ada/libgnat/a-calcon.adb b/gcc/ada/libgnat/a-calcon.adb
index a6bb156..3b5ec6b 100644
--- a/gcc/ada/libgnat/a-calcon.adb
+++ b/gcc/ada/libgnat/a-calcon.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,7 +30,6 @@
------------------------------------------------------------------------------
with Interfaces.C; use Interfaces.C;
-with Interfaces.C.Extensions; use Interfaces.C.Extensions;
package body Ada.Calendar.Conversions is
diff --git a/gcc/ada/libgnat/a-calcon.ads b/gcc/ada/libgnat/a-calcon.ads
index 0847f36..23f176e 100644
--- a/gcc/ada/libgnat/a-calcon.ads
+++ b/gcc/ada/libgnat/a-calcon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,7 +33,6 @@
-- time models - Time, Duration, struct tm and struct timespec.
with Interfaces.C;
-with Interfaces.C.Extensions;
package Ada.Calendar.Conversions is
@@ -112,7 +111,7 @@ package Ada.Calendar.Conversions is
-- fit into a Time value.
function To_Unix_Nano_Time
- (Ada_Time : Time) return Interfaces.C.Extensions.long_long;
+ (Ada_Time : Time) return Interfaces.C.long_long;
-- Convert a time value represented as number of time units since the Ada
-- implementation-defined Epoch to a value relative to the Unix Epoch. The
-- units of the result are nanoseconds. Raises Time_Error if the result
diff --git a/gcc/ada/libgnat/a-caldel.adb b/gcc/ada/libgnat/a-caldel.adb
index b7cfefc..5b64ef7 100644
--- a/gcc/ada/libgnat/a-caldel.adb
+++ b/gcc/ada/libgnat/a-caldel.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -103,6 +103,8 @@ begin
-- this soft link, or this will be overridden during the elaboration of
-- System.Tasking.Initialization
+ pragma Annotate (CodePeer, Modified, SSL.Timed_Delay);
+
if SSL.Timed_Delay = null then
SSL.Timed_Delay := Timed_Delay_NT'Access;
end if;
diff --git a/gcc/ada/libgnat/a-caldel.ads b/gcc/ada/libgnat/a-caldel.ads
index c45b765..9fa5d60 100644
--- a/gcc/ada/libgnat/a-caldel.ads
+++ b/gcc/ada/libgnat/a-caldel.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-calend.adb b/gcc/ada/libgnat/a-calend.adb
index 4cbfeff..f457412 100644
--- a/gcc/ada/libgnat/a-calend.adb
+++ b/gcc/ada/libgnat/a-calend.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -167,9 +167,9 @@ is
Secs_In_Non_Leap_Year : constant := 365 * Secs_In_Day;
Nanos_In_Four_Years : constant := Secs_In_Four_Years * Nano;
- -- Lower and upper bound of Ada time. The zero (0) value of type Time is
- -- positioned at year 2150. Note that the lower and upper bound account
- -- for the non-leap centennial years.
+ -- Lower and upper bound of Ada time. Note that the lower and upper bound
+ -- account for the non-leap centennial years. See "Implementation of Time"
+ -- in the spec for what the zero value represents.
Ada_Low : constant Time_Rep := -(61 * 366 + 188 * 365) * Nanos_In_Day;
Ada_High : constant Time_Rep := (60 * 366 + 190 * 365) * Nanos_In_Day;
@@ -435,18 +435,14 @@ is
if End_T < Leap_Second_Times (1) then
Elapsed_Leaps := 0;
Next_Leap := Leap_Second_Times (1);
- return;
elsif Start_T > Leap_Second_Times (Leap_Seconds_Count) then
Elapsed_Leaps := 0;
Next_Leap := End_Of_Time;
- return;
- end if;
-
- -- Perform the calculations only if the start date is within the leap
- -- second occurrences table.
- if Start_T <= Leap_Second_Times (Leap_Seconds_Count) then
+ else
+ -- Perform the calculations only if the start date is within the leap
+ -- second occurrences table.
-- 1 2 N - 1 N
-- +----+----+-- . . . --+-------+---+
@@ -480,9 +476,6 @@ is
end if;
Elapsed_Leaps := End_Index - Start_Index;
-
- else
- Elapsed_Leaps := 0;
end if;
end Cumulative_Leap_Seconds;
@@ -763,6 +756,7 @@ is
(Secs_T'Unchecked_Access,
Flag'Unchecked_Access,
Offset'Unchecked_Access);
+ pragma Annotate (CodePeer, Modified, Offset);
return Long_Integer (Offset);
end UTC_Time_Offset;
diff --git a/gcc/ada/libgnat/a-calend.ads b/gcc/ada/libgnat/a-calend.ads
index 1b782f0..e7eb3ef 100644
--- a/gcc/ada/libgnat/a-calend.ads
+++ b/gcc/ada/libgnat/a-calend.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -157,16 +157,20 @@ private
-- Implementation of Time --
----------------------------
- -- Time is represented as a signed 64 bit integer count of nanoseconds
- -- since the start of Ada time (1901-01-01 00:00:00.0 UTC). Time values
- -- produced by Time_Of are internally normalized to UTC regardless of their
- -- local time zone. This representation ensures correct handling of leap
- -- seconds as well as performing arithmetic. In Ada 95, Split and Time_Of
- -- will treat a time value as being in the local time zone, in Ada 2005,
- -- Split and Time_Of will treat a time value as being in the designated
- -- time zone by the formal parameter or in UTC by default. The size of the
- -- type is large enough to cover the Ada 2005 range of time (1901-01-01
- -- 00:00:00.0 UTC - 2399-12-31-23:59:59.999999999 UTC).
+ -- Time is represented as a signed 64 bit signed integer count of
+ -- nanoseconds since the "epoch" 2150-01-01 00:00:00 UTC. Thus a value of 0
+ -- represents the epoch. As of this writing, the epoch is in the future,
+ -- so Time values returned by Clock will be negative.
+ --
+ -- Time values produced by Time_Of are internally normalized to UTC
+ -- regardless of their local time zone. This representation ensures correct
+ -- handling of leap seconds as well as performing arithmetic. In Ada 95,
+ -- Split and Time_Of will treat a time value as being in the local time
+ -- zone, in Ada 2005, Split and Time_Of will treat a time value as being in
+ -- the designated time zone by the formal parameter or in UTC by
+ -- default. The size of the type is large enough to cover the Ada
+ -- range of time (1901-01-01T00:00:00.0 UTC - 2399-12-31T23:59:59.999999999
+ -- UTC).
------------------
-- Leap Seconds --
@@ -234,8 +238,8 @@ private
function Epoch_Offset return Time_Rep;
pragma Inline (Epoch_Offset);
- -- Return the difference between 2150-1-1 UTC and 1970-1-1 UTC expressed in
- -- nanoseconds. Note that year 2100 is non-leap.
+ -- Return the difference between our epoch and 1970-1-1 UTC (the Unix
+ -- epoch) expressed in nanoseconds. Note that year 2100 is non-leap.
Days_In_Month : constant array (Month_Number) of Day_Number :=
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
diff --git a/gcc/ada/libgnat/a-calfor.adb b/gcc/ada/libgnat/a-calfor.adb
index 5cc151d..7d53d56 100644
--- a/gcc/ada/libgnat/a-calfor.adb
+++ b/gcc/ada/libgnat/a-calfor.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2006-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-calfor.ads b/gcc/ada/libgnat/a-calfor.ads
index 60a586e..599e395 100644
--- a/gcc/ada/libgnat/a-calfor.ads
+++ b/gcc/ada/libgnat/a-calfor.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
@@ -206,6 +206,14 @@ package Ada.Calendar.Formatting is
-- prefixed with a minus sign. If abs Elapsed_Time represents 100 hours or
-- more, Time_Error is raised.
+ function Local_Image
+ (Date : Time;
+ Include_Time_Fraction : Boolean := False) return String
+ is (Image (Date,
+ Include_Time_Fraction,
+ Time_Zones.Local_Time_Offset (Date)));
+ -- Returns a string form of Date relative to the local time offset.
+
function Value (Elapsed_Time : String) return Duration;
-- Returns a Duration value for the image given as Elapsed_Time.
-- Constraint_Error is raised if the string is not formatted as described
diff --git a/gcc/ada/libgnat/a-catizo.adb b/gcc/ada/libgnat/a-catizo.adb
index 8937572..f183445 100644
--- a/gcc/ada/libgnat/a-catizo.adb
+++ b/gcc/ada/libgnat/a-catizo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -38,11 +38,11 @@ package body Ada.Calendar.Time_Zones is
-- All operations in this package are target and time representation
-- independent, thus only one source file is needed for multiple targets.
- ---------------------
- -- UTC_Time_Offset --
- ---------------------
+ -----------------------
+ -- Local_Time_Offset --
+ -----------------------
- function UTC_Time_Offset (Date : Time := Clock) return Time_Offset is
+ function Local_Time_Offset (Date : Time := Clock) return Time_Offset is
Offset_L : constant Long_Integer :=
Time_Zones_Operations.UTC_Time_Offset (Date);
Offset : Time_Offset;
@@ -64,6 +64,6 @@ package body Ada.Calendar.Time_Zones is
end if;
return Offset;
- end UTC_Time_Offset;
+ end Local_Time_Offset;
end Ada.Calendar.Time_Zones;
diff --git a/gcc/ada/libgnat/a-catizo.ads b/gcc/ada/libgnat/a-catizo.ads
index 5f55869..8ef139c 100644
--- a/gcc/ada/libgnat/a-catizo.ads
+++ b/gcc/ada/libgnat/a-catizo.ads
@@ -21,10 +21,13 @@ package Ada.Calendar.Time_Zones is
-- Time zone manipulation
type Time_Offset is range -(28 * 60) .. 28 * 60;
+ -- Offset in minutes
Unknown_Zone_Error : exception;
- function UTC_Time_Offset (Date : Time := Clock) return Time_Offset;
+ function Local_Time_Offset (Date : Time := Clock) return Time_Offset;
+ function UTC_Time_Offset (Date : Time := Clock) return Time_Offset
+ renames Local_Time_Offset;
-- Returns (in minutes), the difference between the implementation-defined
-- time zone of Calendar, and UTC time, at the time Date. If the time zone
-- of the Calendar implementation is unknown, raises Unknown_Zone_Error.
diff --git a/gcc/ada/libgnat/a-cbdlli.adb b/gcc/ada/libgnat/a-cbdlli.adb
index 9a2282b..0f0c872 100644
--- a/gcc/ada/libgnat/a-cbdlli.adb
+++ b/gcc/ada/libgnat/a-cbdlli.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,7 +29,9 @@
with System; use type System.Address;
-package body Ada.Containers.Bounded_Doubly_Linked_Lists is
+package body Ada.Containers.Bounded_Doubly_Linked_Lists with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -358,6 +360,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
X : Count_Type;
begin
+ TC_Check (Container.TC);
+
if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor has no element";
@@ -386,8 +390,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
return;
end if;
- TC_Check (Container.TC);
-
for Index in 1 .. Count loop
pragma Assert (Container.Length >= 2);
@@ -427,6 +429,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
X : Count_Type;
begin
+ TC_Check (Container.TC);
+
if Count >= Container.Length then
Clear (Container);
return;
@@ -436,8 +440,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
return;
end if;
- TC_Check (Container.TC);
-
for J in 1 .. Count loop
X := Container.First;
pragma Assert (N (N (X).Next).Prev = Container.First);
@@ -463,6 +465,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
X : Count_Type;
begin
+ TC_Check (Container.TC);
+
if Count >= Container.Length then
Clear (Container);
return;
@@ -472,8 +476,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
return;
end if;
- TC_Check (Container.TC);
-
for J in 1 .. Count loop
X := Container.Last;
pragma Assert (N (N (X).Prev).Next = Container.Last);
@@ -759,6 +761,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
Source : in out List)
is
begin
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
+
-- The semantics of Merge changed slightly per AI05-0021. It was
-- originally the case that if Target and Source denoted the same
-- container object, then the GNAT implementation of Merge did
@@ -786,9 +791,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
raise Capacity_Error with "new length exceeds target capacity";
end if;
- TC_Check (Target.TC);
- TC_Check (Source.TC);
-
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
@@ -964,6 +966,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
New_Node : Count_Type;
begin
+ TC_Check (Container.TC);
+
if Before.Container /= null then
if Checks and then Before.Container /= Container'Unrestricted_Access
then
@@ -983,8 +987,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
raise Capacity_Error with "capacity exceeded";
end if;
- TC_Check (Container.TC);
-
Allocate (Container, New_Item, New_Node);
First_Node := New_Node;
Insert_Internal (Container, Before.Node, New_Node);
@@ -1261,6 +1263,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
X : Count_Type;
begin
+ TC_Check (Source.TC);
+
if Target'Address = Source'Address then
return;
end if;
@@ -1269,8 +1273,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
raise Capacity_Error with "Source length exceeds Target capacity";
end if;
- TC_Check (Source.TC);
-
-- Clear target, note that this checks busy bits of Target
Clear (Target);
@@ -1579,6 +1581,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
New_Item : Element_Type)
is
begin
+ TE_Check (Container.TC);
+
if Checks and then Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
@@ -1588,8 +1592,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
"Position cursor designates wrong container";
end if;
- TE_Check (Container.TC);
-
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
Container.Nodes (Position.Node).Element := New_Item;
@@ -1751,6 +1753,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
Source : in out List)
is
begin
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
+
if Before.Container /= null then
if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
@@ -1772,9 +1777,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
raise Capacity_Error with "new length exceeds target capacity";
end if;
- TC_Check (Target.TC);
- TC_Check (Source.TC);
-
Splice_Internal (Target, Before.Node, Source);
end Splice;
@@ -1786,6 +1788,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
N : Node_Array renames Container.Nodes;
begin
+ TC_Check (Container.TC);
+
if Before.Container /= null then
if Checks and then Before.Container /= Container'Unchecked_Access then
raise Program_Error with
@@ -1815,8 +1819,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
pragma Assert (Container.Length >= 2);
- TC_Check (Container.TC);
-
if Before.Node = 0 then
pragma Assert (Position.Node /= Container.Last);
@@ -1894,6 +1896,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
return;
end if;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
+
if Before.Container /= null then
if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
@@ -1918,9 +1923,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
raise Capacity_Error with "Target is full";
end if;
- TC_Check (Target.TC);
- TC_Check (Source.TC);
-
Splice_Internal
(Target => Target,
Before => Before.Node,
@@ -2063,6 +2065,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
I, J : Cursor)
is
begin
+ TE_Check (Container.TC);
+
if Checks and then I.Node = 0 then
raise Constraint_Error with "I cursor has no element";
end if;
@@ -2083,8 +2087,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
return;
end if;
- TE_Check (Container.TC);
-
pragma Assert (Vet (I), "bad I cursor in Swap");
pragma Assert (Vet (J), "bad J cursor in Swap");
@@ -2109,6 +2111,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
I, J : Cursor)
is
begin
+ TC_Check (Container.TC);
+
if Checks and then I.Node = 0 then
raise Constraint_Error with "I cursor has no element";
end if;
@@ -2129,8 +2133,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
return;
end if;
- TC_Check (Container.TC);
-
pragma Assert (Vet (I), "bad I cursor in Swap_Links");
pragma Assert (Vet (J), "bad J cursor in Swap_Links");
diff --git a/gcc/ada/libgnat/a-cbdlli.ads b/gcc/ada/libgnat/a-cbdlli.ads
index ca58c70..74639cf 100644
--- a/gcc/ada/libgnat/a-cbdlli.ads
+++ b/gcc/ada/libgnat/a-cbdlli.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -43,7 +43,9 @@ generic
with function "=" (Left, Right : Element_Type)
return Boolean is <>;
-package Ada.Containers.Bounded_Doubly_Linked_Lists is
+package Ada.Containers.Bounded_Doubly_Linked_Lists with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Pure;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-cbhama.adb b/gcc/ada/libgnat/a-cbhama.adb
index d5cc820..1881db2 100644
--- a/gcc/ada/libgnat/a-cbhama.adb
+++ b/gcc/ada/libgnat/a-cbhama.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -39,7 +39,9 @@ with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
with System; use type System.Address;
-package body Ada.Containers.Bounded_Hashed_Maps is
+package body Ada.Containers.Bounded_Hashed_Maps with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -311,6 +313,8 @@ package body Ada.Containers.Bounded_Hashed_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
+ TC_Check (Container.TC);
+
if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of Delete equals No_Element";
@@ -322,8 +326,6 @@ package body Ada.Containers.Bounded_Hashed_Maps is
"Position cursor of Delete designates wrong map";
end if;
- TC_Check (Container.TC);
-
pragma Assert (Vet (Position), "bad cursor in Delete");
HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
@@ -1029,13 +1031,13 @@ package body Ada.Containers.Bounded_Hashed_Maps is
Node : constant Count_Type := Key_Ops.Find (Container, Key);
begin
+ TE_Check (Container.TC);
+
if Checks and then Node = 0 then
raise Constraint_Error with
"attempt to replace key not in map";
end if;
- TE_Check (Container.TC);
-
declare
N : Node_Type renames Container.Nodes (Node);
begin
@@ -1054,6 +1056,8 @@ package body Ada.Containers.Bounded_Hashed_Maps is
New_Item : Element_Type)
is
begin
+ TE_Check (Position.Container.TC);
+
if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
@@ -1065,8 +1069,6 @@ package body Ada.Containers.Bounded_Hashed_Maps is
"Position cursor of Replace_Element designates wrong map";
end if;
- TE_Check (Position.Container.TC);
-
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
Container.Nodes (Position.Node).Element := New_Item;
diff --git a/gcc/ada/libgnat/a-cbhama.ads b/gcc/ada/libgnat/a-cbhama.ads
index 0238548..86fed4e 100644
--- a/gcc/ada/libgnat/a-cbhama.ads
+++ b/gcc/ada/libgnat/a-cbhama.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -45,7 +45,9 @@ generic
with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Bounded_Hashed_Maps is
+package Ada.Containers.Bounded_Hashed_Maps with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Pure;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-cbhase.adb b/gcc/ada/libgnat/a-cbhase.adb
index 1fa2c21..a332bd7 100644
--- a/gcc/ada/libgnat/a-cbhase.adb
+++ b/gcc/ada/libgnat/a-cbhase.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -39,7 +39,9 @@ with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
with System; use type System.Address;
-package body Ada.Containers.Bounded_Hashed_Sets is
+package body Ada.Containers.Bounded_Hashed_Sets with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -309,6 +311,8 @@ package body Ada.Containers.Bounded_Hashed_Sets is
Position : in out Cursor)
is
begin
+ TC_Check (Container.TC);
+
if Checks and then Position.Node = 0 then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
@@ -318,8 +322,6 @@ package body Ada.Containers.Bounded_Hashed_Sets is
raise Program_Error with "Position cursor designates wrong set";
end if;
- TC_Check (Container.TC);
-
pragma Assert (Vet (Position), "bad cursor in Delete");
HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
@@ -1179,13 +1181,13 @@ package body Ada.Containers.Bounded_Hashed_Sets is
Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
begin
+ TE_Check (Container.TC);
+
if Checks and then Node = 0 then
raise Constraint_Error with
"attempt to replace element not in set";
end if;
- TE_Check (Container.TC);
-
Container.Nodes (Node).Element := New_Item;
end Replace;
diff --git a/gcc/ada/libgnat/a-cbhase.ads b/gcc/ada/libgnat/a-cbhase.ads
index cb9150b..01903c7 100644
--- a/gcc/ada/libgnat/a-cbhase.ads
+++ b/gcc/ada/libgnat/a-cbhase.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -48,7 +48,9 @@ generic
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Bounded_Hashed_Sets is
+package Ada.Containers.Bounded_Hashed_Sets with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Pure;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-cbmutr.adb b/gcc/ada/libgnat/a-cbmutr.adb
index ad9edaa..58db8cf 100644
--- a/gcc/ada/libgnat/a-cbmutr.adb
+++ b/gcc/ada/libgnat/a-cbmutr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,7 +30,9 @@
with Ada.Finalization;
with System; use type System.Address;
-package body Ada.Containers.Bounded_Multiway_Trees is
+package body Ada.Containers.Bounded_Multiway_Trees with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -366,6 +368,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
First, Last : Count_Type;
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -383,8 +387,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
with "requested count exceeds available storage";
end if;
- TC_Check (Container.TC);
-
if Container.Count = 0 then
Initialize_Root (Container);
end if;
@@ -985,6 +987,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Count : Count_Type;
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -993,8 +997,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
raise Program_Error with "Parent cursor not in container";
end if;
- TC_Check (Container.TC);
-
if Container.Count = 0 then
pragma Assert (Is_Root (Parent));
return;
@@ -1024,6 +1026,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
X : Count_Type;
begin
+ TC_Check (Container.TC);
+
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@@ -1041,8 +1045,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
raise Constraint_Error with "Position cursor does not designate leaf";
end if;
- TC_Check (Container.TC);
-
X := Position.Node;
Position := No_Element;
@@ -1064,6 +1066,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Count : Count_Type;
begin
+ TC_Check (Container.TC);
+
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@@ -1077,8 +1081,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
raise Program_Error with "Position cursor designates root";
end if;
- TC_Check (Container.TC);
-
X := Position.Node;
Position := No_Element;
@@ -1506,6 +1508,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Last : Count_Type;
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -1537,8 +1541,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
with "requested count exceeds available storage";
end if;
- TC_Check (Container.TC);
-
if Container.Count = 0 then
Initialize_Root (Container);
end if;
@@ -1584,6 +1586,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
-- OK to reference, see below
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -1615,8 +1619,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
with "requested count exceeds available storage";
end if;
- TC_Check (Container.TC);
-
if Container.Count = 0 then
Initialize_Root (Container);
end if;
@@ -2181,6 +2183,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
First, Last : Count_Type;
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -2198,8 +2202,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
with "requested count exceeds available storage";
end if;
- TC_Check (Container.TC);
-
if Container.Count = 0 then
Initialize_Root (Container);
end if;
@@ -2545,6 +2547,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
New_Item : Element_Type)
is
begin
+ TE_Check (Container.TC);
+
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@@ -2558,8 +2562,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
raise Program_Error with "Position cursor designates root";
end if;
- TE_Check (Container.TC);
-
Container.Elements (Position.Node) := New_Item;
end Replace_Element;
@@ -2627,6 +2629,9 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Source_Parent : Cursor)
is
begin
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
+
if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
@@ -2671,8 +2676,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
return;
end if;
- TC_Check (Target.TC);
-
if Checks and then Is_Reachable (Container => Target,
From => Target_Parent.Node,
To => Source_Parent.Node)
@@ -2690,9 +2693,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
return;
end if;
- TC_Check (Target.TC);
- TC_Check (Source.TC);
-
if Target.Count = 0 then
Initialize_Root (Target);
end if;
@@ -2712,6 +2712,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Source_Parent : Cursor)
is
begin
+ TC_Check (Container.TC);
+
if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
@@ -2755,8 +2757,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
pragma Assert (Container.Count > 0);
- TC_Check (Container.TC);
-
if Checks and then Is_Reachable (Container => Container,
From => Target_Parent.Node,
To => Source_Parent.Node)
@@ -2911,6 +2911,9 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Position : in out Cursor)
is
begin
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -2957,8 +2960,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
end if;
end if;
- TC_Check (Target.TC);
-
if Checks and then Is_Reachable (Container => Target,
From => Parent.Node,
To => Position.Node)
@@ -2974,9 +2975,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
return;
end if;
- TC_Check (Target.TC);
- TC_Check (Source.TC);
-
if Target.Count = 0 then
Initialize_Root (Target);
end if;
@@ -2998,6 +2996,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Position : Cursor)
is
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -3048,8 +3048,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
end if;
end if;
- TC_Check (Container.TC);
-
if Checks and then Is_Reachable (Container => Container,
From => Parent.Node,
To => Position.Node)
@@ -3176,6 +3174,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
I, J : Cursor)
is
begin
+ TE_Check (Container.TC);
+
if Checks and then I = No_Element then
raise Constraint_Error with "I cursor has no element";
end if;
@@ -3204,8 +3204,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
raise Program_Error with "J cursor designates root";
end if;
- TE_Check (Container.TC);
-
declare
EE : Element_Array renames Container.Elements;
EI : constant Element_Type := EE (I.Node);
diff --git a/gcc/ada/libgnat/a-cbmutr.ads b/gcc/ada/libgnat/a-cbmutr.ads
index f491ad4..653407b 100644
--- a/gcc/ada/libgnat/a-cbmutr.ads
+++ b/gcc/ada/libgnat/a-cbmutr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -41,7 +41,9 @@ generic
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Bounded_Multiway_Trees is
+package Ada.Containers.Bounded_Multiway_Trees with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Pure;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-cborma.adb b/gcc/ada/libgnat/a-cborma.adb
index 005bca5..6f59471 100644
--- a/gcc/ada/libgnat/a-cborma.adb
+++ b/gcc/ada/libgnat/a-cborma.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -39,7 +39,9 @@ pragma Elaborate_All
with System; use type System.Address;
-package body Ada.Containers.Bounded_Ordered_Maps is
+package body Ada.Containers.Bounded_Ordered_Maps with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -1418,12 +1420,12 @@ package body Ada.Containers.Bounded_Ordered_Maps is
Node : constant Count_Type := Key_Ops.Find (Container, Key);
begin
+ TE_Check (Container.TC);
+
if Checks and then Node = 0 then
raise Constraint_Error with "key not in map";
end if;
- TE_Check (Container.TC);
-
declare
N : Node_Type renames Container.Nodes (Node);
@@ -1443,6 +1445,8 @@ package body Ada.Containers.Bounded_Ordered_Maps is
New_Item : Element_Type)
is
begin
+ TE_Check (Container.TC);
+
if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
@@ -1454,8 +1458,6 @@ package body Ada.Containers.Bounded_Ordered_Maps is
"Position cursor of Replace_Element designates wrong map";
end if;
- TE_Check (Container.TC);
-
pragma Assert (Vet (Container, Position.Node),
"Position cursor of Replace_Element is bad");
diff --git a/gcc/ada/libgnat/a-cborma.ads b/gcc/ada/libgnat/a-cborma.ads
index ba5d4fe..c199a09 100644
--- a/gcc/ada/libgnat/a-cborma.ads
+++ b/gcc/ada/libgnat/a-cborma.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -44,7 +44,9 @@ generic
with function "<" (Left, Right : Key_Type) return Boolean is <>;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Bounded_Ordered_Maps is
+package Ada.Containers.Bounded_Ordered_Maps with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Pure;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-cborse.adb b/gcc/ada/libgnat/a-cborse.adb
index b553048..af4f87f 100644
--- a/gcc/ada/libgnat/a-cborse.adb
+++ b/gcc/ada/libgnat/a-cborse.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,7 +42,9 @@ pragma Elaborate_All
with System; use type System.Address;
-package body Ada.Containers.Bounded_Ordered_Sets is
+package body Ada.Containers.Bounded_Ordered_Sets with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -461,6 +463,8 @@ package body Ada.Containers.Bounded_Ordered_Sets is
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
+ TC_Check (Container.TC);
+
if Checks and then Position.Node = 0 then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
@@ -470,8 +474,6 @@ package body Ada.Containers.Bounded_Ordered_Sets is
raise Program_Error with "Position cursor designates wrong set";
end if;
- TC_Check (Container.TC);
-
pragma Assert (Vet (Container, Position.Node),
"bad cursor in Delete");
@@ -933,7 +935,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is
Control =>
(Controlled with
Container.TC'Unrestricted_Access,
- Container => Container'Access,
+ Container => Container'Unchecked_Access,
Pos => Position,
Old_Key => new Key_Type'(Key (Position))))
do
@@ -961,7 +963,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is
Control =>
(Controlled with
Container.TC'Unrestricted_Access,
- Container => Container'Access,
+ Container => Container'Unchecked_Access,
Pos => Find (Container, Key),
Old_Key => new Key_Type'(Key)))
do
@@ -1682,13 +1684,13 @@ package body Ada.Containers.Bounded_Ordered_Sets is
Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
begin
+ TE_Check (Container.TC);
+
if Checks and then Node = 0 then
raise Constraint_Error with
"attempt to replace element not in set";
end if;
- TE_Check (Container.TC);
-
Container.Nodes (Node).Element := New_Item;
end Replace;
diff --git a/gcc/ada/libgnat/a-cborse.ads b/gcc/ada/libgnat/a-cborse.ads
index fd4d12d..52b8786 100644
--- a/gcc/ada/libgnat/a-cborse.ads
+++ b/gcc/ada/libgnat/a-cborse.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -44,7 +44,9 @@ generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Bounded_Ordered_Sets is
+package Ada.Containers.Bounded_Ordered_Sets with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Pure;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-cbprqu.adb b/gcc/ada/libgnat/a-cbprqu.adb
index c714b76..2e97291 100644
--- a/gcc/ada/libgnat/a-cbprqu.adb
+++ b/gcc/ada/libgnat/a-cbprqu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,9 @@
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-package body Ada.Containers.Bounded_Priority_Queues is
+package body Ada.Containers.Bounded_Priority_Queues with
+ SPARK_Mode => Off
+is
package body Implementation is
diff --git a/gcc/ada/libgnat/a-cbprqu.ads b/gcc/ada/libgnat/a-cbprqu.ads
index 1eb2674..6259a47 100644
--- a/gcc/ada/libgnat/a-cbprqu.ads
+++ b/gcc/ada/libgnat/a-cbprqu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -51,7 +51,9 @@ generic
Default_Capacity : Count_Type;
Default_Ceiling : System.Any_Priority := System.Priority'Last;
-package Ada.Containers.Bounded_Priority_Queues is
+package Ada.Containers.Bounded_Priority_Queues with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
diff --git a/gcc/ada/libgnat/a-cbsyqu.adb b/gcc/ada/libgnat/a-cbsyqu.adb
index 4de9f25..abb0e79 100644
--- a/gcc/ada/libgnat/a-cbsyqu.adb
+++ b/gcc/ada/libgnat/a-cbsyqu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,9 @@
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-package body Ada.Containers.Bounded_Synchronized_Queues is
+package body Ada.Containers.Bounded_Synchronized_Queues with
+ SPARK_Mode => Off
+is
package body Implementation is
diff --git a/gcc/ada/libgnat/a-cbsyqu.ads b/gcc/ada/libgnat/a-cbsyqu.ads
index e457e4c..61504fa 100644
--- a/gcc/ada/libgnat/a-cbsyqu.ads
+++ b/gcc/ada/libgnat/a-cbsyqu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -41,7 +41,9 @@ generic
Default_Capacity : Count_Type;
Default_Ceiling : System.Any_Priority := System.Priority'Last;
-package Ada.Containers.Bounded_Synchronized_Queues is
+package Ada.Containers.Bounded_Synchronized_Queues with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
diff --git a/gcc/ada/libgnat/a-cdlili.adb b/gcc/ada/libgnat/a-cdlili.adb
index 949fb0f..a668db1 100644
--- a/gcc/ada/libgnat/a-cdlili.adb
+++ b/gcc/ada/libgnat/a-cdlili.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,7 +31,9 @@ with Ada.Unchecked_Deallocation;
with System; use type System.Address;
-package body Ada.Containers.Doubly_Linked_Lists is
+package body Ada.Containers.Doubly_Linked_Lists with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -295,6 +297,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
X : Node_Access;
begin
+ TC_Check (Container.TC);
+
if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor has no element";
@@ -319,8 +323,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
return;
end if;
- TC_Check (Container.TC);
-
for Index in 1 .. Count loop
X := Position.Node;
Container.Length := Container.Length - 1;
@@ -604,6 +606,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
Source : in out List)
is
begin
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
+
-- The semantics of Merge changed slightly per AI05-0021. It was
-- originally the case that if Target and Source denoted the same
-- container object, then the GNAT implementation of Merge did
@@ -626,9 +631,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
raise Constraint_Error with "new length exceeds maximum";
end if;
- TC_Check (Target.TC);
- TC_Check (Source.TC);
-
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
@@ -796,6 +798,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
New_Node : Node_Access;
begin
+ TC_Check (Container.TC);
+
if Before.Container /= null then
if Checks and then Before.Container /= Container'Unrestricted_Access
then
@@ -815,8 +819,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
raise Constraint_Error with "new length exceeds maximum";
end if;
- TC_Check (Container.TC);
-
New_Node := new Node_Type'(New_Item, null, null);
First_Node := New_Node;
Insert_Internal (Container, Before.Node, New_Node);
@@ -851,6 +853,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
New_Node : Node_Access;
begin
+ TC_Check (Container.TC);
+
if Before.Container /= null then
if Checks and then Before.Container /= Container'Unrestricted_Access
then
@@ -870,8 +874,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
raise Constraint_Error with "new length exceeds maximum";
end if;
- TC_Check (Container.TC);
-
New_Node := new Node_Type;
First_Node := New_Node;
Insert_Internal (Container, Before.Node, New_Node);
@@ -1372,6 +1374,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
New_Item : Element_Type)
is
begin
+ TE_Check (Container.TC);
+
if Checks and then Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
@@ -1381,8 +1385,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
"Position cursor designates wrong container";
end if;
- TE_Check (Container.TC);
-
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
Position.Node.Element := New_Item;
@@ -1543,6 +1545,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
Source : in out List)
is
begin
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
+
if Before.Container /= null then
if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
@@ -1560,9 +1565,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
raise Constraint_Error with "new length exceeds maximum";
end if;
- TC_Check (Target.TC);
- TC_Check (Source.TC);
-
Splice_Internal (Target, Before.Node, Source);
end Splice;
@@ -1572,6 +1574,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
Position : Cursor)
is
begin
+ TC_Check (Container.TC);
+
if Before.Container /= null then
if Checks and then Before.Container /= Container'Unchecked_Access then
raise Program_Error with
@@ -1601,8 +1605,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
pragma Assert (Container.Length >= 2);
- TC_Check (Container.TC);
-
if Before.Node = null then
pragma Assert (Position.Node /= Container.Last);
@@ -1678,6 +1680,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
return;
end if;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
+
if Before.Container /= null then
if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
@@ -1702,9 +1707,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
raise Constraint_Error with "Target is full";
end if;
- TC_Check (Target.TC);
- TC_Check (Source.TC);
-
Splice_Internal (Target, Before.Node, Source, Position.Node);
Position.Container := Target'Unchecked_Access;
end Splice;
@@ -1862,6 +1864,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
I, J : Cursor)
is
begin
+ TE_Check (Container.TC);
+
if Checks and then I.Node = null then
raise Constraint_Error with "I cursor has no element";
end if;
@@ -1882,8 +1886,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
return;
end if;
- TE_Check (Container.TC);
-
pragma Assert (Vet (I), "bad I cursor in Swap");
pragma Assert (Vet (J), "bad J cursor in Swap");
@@ -1908,6 +1910,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
I, J : Cursor)
is
begin
+ TC_Check (Container.TC);
+
if Checks and then I.Node = null then
raise Constraint_Error with "I cursor has no element";
end if;
@@ -1928,8 +1932,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
return;
end if;
- TC_Check (Container.TC);
-
pragma Assert (Vet (I), "bad I cursor in Swap_Links");
pragma Assert (Vet (J), "bad J cursor in Swap_Links");
diff --git a/gcc/ada/libgnat/a-cdlili.ads b/gcc/ada/libgnat/a-cdlili.ads
index e7f40b1..89216e0 100644
--- a/gcc/ada/libgnat/a-cdlili.ads
+++ b/gcc/ada/libgnat/a-cdlili.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -43,7 +43,9 @@ generic
with function "=" (Left, Right : Element_Type)
return Boolean is <>;
-package Ada.Containers.Doubly_Linked_Lists is
+package Ada.Containers.Doubly_Linked_Lists with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-cfdlli.adb b/gcc/ada/libgnat/a-cfdlli.adb
index 1f23f4b..9713f4c 100644
--- a/gcc/ada/libgnat/a-cfdlli.adb
+++ b/gcc/ada/libgnat/a-cfdlli.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-cfdlli.ads b/gcc/ada/libgnat/a-cfdlli.ads
index b8df023..6131239 100644
--- a/gcc/ada/libgnat/a-cfdlli.ads
+++ b/gcc/ada/libgnat/a-cfdlli.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -789,9 +789,10 @@ is
Count => Count);
procedure Delete (Container : in out List; Position : in out Cursor) with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
+ Global => null,
+ Depends => (Container =>+ Position, Position => null),
+ Pre => Has_Element (Container, Position),
+ Post =>
Length (Container) = Length (Container)'Old - 1
-- Position is set to No_Element
diff --git a/gcc/ada/libgnat/a-cfhama.adb b/gcc/ada/libgnat/a-cfhama.adb
index 580ca12..b5c37d2 100644
--- a/gcc/ada/libgnat/a-cfhama.adb
+++ b/gcc/ada/libgnat/a-cfhama.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-cfhama.ads b/gcc/ada/libgnat/a-cfhama.ads
index c4e8221..8a73508 100644
--- a/gcc/ada/libgnat/a-cfhama.ads
+++ b/gcc/ada/libgnat/a-cfhama.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -669,9 +669,10 @@ is
Find (Container, Key)'Old);
procedure Delete (Container : in out Map; Position : in out Cursor) with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
+ Global => null,
+ Depends => (Container =>+ Position, Position => null),
+ Pre => Has_Element (Container, Position),
+ Post =>
Position = No_Element
and Length (Container) = Length (Container)'Old - 1
diff --git a/gcc/ada/libgnat/a-cfhase.adb b/gcc/ada/libgnat/a-cfhase.adb
index 8cc220c..121708c 100644
--- a/gcc/ada/libgnat/a-cfhase.adb
+++ b/gcc/ada/libgnat/a-cfhase.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-cfhase.ads b/gcc/ada/libgnat/a-cfhase.ads
index 3e72aef..37022ca 100644
--- a/gcc/ada/libgnat/a-cfhase.ads
+++ b/gcc/ada/libgnat/a-cfhase.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -801,9 +801,10 @@ is
-- already in the set.)
procedure Delete (Container : in out Set; Position : in out Cursor) with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
+ Global => null,
+ Depends => (Container =>+ Position, Position => null),
+ Pre => Has_Element (Container, Position),
+ Post =>
Position = No_Element
and Length (Container) = Length (Container)'Old - 1
diff --git a/gcc/ada/libgnat/a-cfinve.adb b/gcc/ada/libgnat/a-cfinve.adb
index b5c318b..28e31d1 100644
--- a/gcc/ada/libgnat/a-cfinve.adb
+++ b/gcc/ada/libgnat/a-cfinve.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-cfinve.ads b/gcc/ada/libgnat/a-cfinve.ads
index 87940d2..3e2e350 100644
--- a/gcc/ada/libgnat/a-cfinve.ads
+++ b/gcc/ada/libgnat/a-cfinve.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-cforma.adb b/gcc/ada/libgnat/a-cforma.adb
index 15d142d..004b31e 100644
--- a/gcc/ada/libgnat/a-cforma.adb
+++ b/gcc/ada/libgnat/a-cforma.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-cforma.ads b/gcc/ada/libgnat/a-cforma.ads
index a13bce4..99b02a5 100644
--- a/gcc/ada/libgnat/a-cforma.ads
+++ b/gcc/ada/libgnat/a-cforma.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -733,9 +733,10 @@ is
Cut => Find (Keys (Container), Key)'Old);
procedure Delete (Container : in out Map; Position : in out Cursor) with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
+ Global => null,
+ Depends => (Container =>+ Position, Position => null),
+ Pre => Has_Element (Container, Position),
+ Post =>
Position = No_Element
and Length (Container) = Length (Container)'Old - 1
diff --git a/gcc/ada/libgnat/a-cforse.adb b/gcc/ada/libgnat/a-cforse.adb
index 71d9b47..991d1dc 100644
--- a/gcc/ada/libgnat/a-cforse.adb
+++ b/gcc/ada/libgnat/a-cforse.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-cforse.ads b/gcc/ada/libgnat/a-cforse.ads
index 3cd62af..a818726 100644
--- a/gcc/ada/libgnat/a-cforse.ads
+++ b/gcc/ada/libgnat/a-cforse.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -858,9 +858,10 @@ is
(Container : in out Set;
Position : in out Cursor)
with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
+ Global => null,
+ Depends => (Container =>+ Position, Position => null),
+ Pre => Has_Element (Container, Position),
+ Post =>
Position = No_Element
and Length (Container) = Length (Container)'Old - 1
diff --git a/gcc/ada/libgnat/a-cgaaso.adb b/gcc/ada/libgnat/a-cgaaso.adb
index 0169c9b..6d0049a 100644
--- a/gcc/ada/libgnat/a-cgaaso.adb
+++ b/gcc/ada/libgnat/a-cgaaso.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-cgaaso.ads b/gcc/ada/libgnat/a-cgaaso.ads
index 3622702..c809b65 100644
--- a/gcc/ada/libgnat/a-cgaaso.ads
+++ b/gcc/ada/libgnat/a-cgaaso.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-cgarso.adb b/gcc/ada/libgnat/a-cgarso.adb
index 9117fd4..5f4e594 100644
--- a/gcc/ada/libgnat/a-cgarso.adb
+++ b/gcc/ada/libgnat/a-cgarso.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-cgcaso.adb b/gcc/ada/libgnat/a-cgcaso.adb
index 25508fd..877abab 100644
--- a/gcc/ada/libgnat/a-cgcaso.adb
+++ b/gcc/ada/libgnat/a-cgcaso.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-chacon.adb b/gcc/ada/libgnat/a-chacon.adb
index 2415103..638dcc4 100644
--- a/gcc/ada/libgnat/a-chacon.adb
+++ b/gcc/ada/libgnat/a-chacon.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-chacon.ads b/gcc/ada/libgnat/a-chacon.ads
index fe8d5e2..df2e276 100644
--- a/gcc/ada/libgnat/a-chacon.ads
+++ b/gcc/ada/libgnat/a-chacon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-chahan.adb b/gcc/ada/libgnat/a-chahan.adb
index e4827a1..de66846 100644
--- a/gcc/ada/libgnat/a-chahan.adb
+++ b/gcc/ada/libgnat/a-chahan.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -399,6 +399,17 @@ package body Ada.Characters.Handling is
return False;
end Is_Mark;
+ -------------
+ -- Is_NFKC --
+ -------------
+
+ function Is_NFKC (Item : Character) return Boolean is
+ begin
+ return Character'Pos (Item) not in
+ 160 | 168 | 170 | 175 | 178 | 179 | 180 | 181 | 184 | 185 | 186 |
+ 188 | 189 | 190;
+ end Is_NFKC;
+
---------------------
-- Is_Other_Format --
---------------------
diff --git a/gcc/ada/libgnat/a-chahan.ads b/gcc/ada/libgnat/a-chahan.ads
index 867c893..04f975c 100644
--- a/gcc/ada/libgnat/a-chahan.ads
+++ b/gcc/ada/libgnat/a-chahan.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -58,6 +58,7 @@ package Ada.Characters.Handling is
function Is_Other_Format (Item : Character) return Boolean;
function Is_Punctuation_Connector (Item : Character) return Boolean;
function Is_Space (Item : Character) return Boolean;
+ function Is_NFKC (Item : Character) return Boolean;
---------------------------------------------------
-- Conversion Functions for Character and String --
diff --git a/gcc/ada/libgnat/a-chlat9.ads b/gcc/ada/libgnat/a-chlat9.ads
index b58585c..de9b54e 100644
--- a/gcc/ada/libgnat/a-chlat9.ads
+++ b/gcc/ada/libgnat/a-chlat9.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-chtgbk.adb b/gcc/ada/libgnat/a-chtgbk.adb
index f567cd5..89358e4 100644
--- a/gcc/ada/libgnat/a-chtgbk.adb
+++ b/gcc/ada/libgnat/a-chtgbk.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -228,6 +228,8 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is
N, M : Count_Type;
begin
+ TC_Check (HT.TC);
+
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
@@ -250,8 +252,6 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is
-- hash table as this one, a key is mapped to exactly one node.)
if Checked_Equivalent_Keys (HT, Key, Node) then
- TE_Check (HT.TC);
-
-- The new Key value is mapped to this same Node, so Node
-- stays in the same bucket.
@@ -292,10 +292,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is
return;
end if;
- -- The node is a bucket different from the bucket implied by Key
-
- TC_Check (HT.TC);
-
+ -- The node is in a bucket different from the bucket implied by Key.
-- Do the assignment first, before moving the node, so that if Assign
-- propagates an exception, then the hash table will not have been
-- modified (except for any possible side-effect Assign had on Node).
diff --git a/gcc/ada/libgnat/a-chtgbk.ads b/gcc/ada/libgnat/a-chtgbk.ads
index 6b46903..43ad208 100644
--- a/gcc/ada/libgnat/a-chtgbk.ads
+++ b/gcc/ada/libgnat/a-chtgbk.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-chtgbo.adb b/gcc/ada/libgnat/a-chtgbo.adb
index ace096d..9fec5c4 100644
--- a/gcc/ada/libgnat/a-chtgbo.adb
+++ b/gcc/ada/libgnat/a-chtgbo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-chtgbo.ads b/gcc/ada/libgnat/a-chtgbo.ads
index 8dfe3aa..5fc852d 100644
--- a/gcc/ada/libgnat/a-chtgbo.ads
+++ b/gcc/ada/libgnat/a-chtgbo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-chtgke.adb b/gcc/ada/libgnat/a-chtgke.adb
index 3c5fff3..fdd62b7 100644
--- a/gcc/ada/libgnat/a-chtgke.adb
+++ b/gcc/ada/libgnat/a-chtgke.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -91,7 +91,6 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is
end if;
if Checked_Equivalent_Keys (HT, Key, X) then
- TC_Check (HT.TC);
HT.Buckets (Indx) := Next (X);
HT.Length := HT.Length - 1;
return;
@@ -106,7 +105,6 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is
end if;
if Checked_Equivalent_Keys (HT, Key, X) then
- TC_Check (HT.TC);
Set_Next (Node => Prev, Next => Next (X));
HT.Length := HT.Length - 1;
return;
diff --git a/gcc/ada/libgnat/a-chtgke.ads b/gcc/ada/libgnat/a-chtgke.ads
index 43b0275b..375ddf6 100644
--- a/gcc/ada/libgnat/a-chtgke.ads
+++ b/gcc/ada/libgnat/a-chtgke.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-chtgop.adb b/gcc/ada/libgnat/a-chtgop.adb
index 7eba2b8..6e7511f 100644
--- a/gcc/ada/libgnat/a-chtgop.adb
+++ b/gcc/ada/libgnat/a-chtgop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-chtgop.ads b/gcc/ada/libgnat/a-chtgop.ads
index 6ebb9e5..9073d57 100644
--- a/gcc/ada/libgnat/a-chtgop.ads
+++ b/gcc/ada/libgnat/a-chtgop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-chzla1.ads b/gcc/ada/libgnat/a-chzla1.ads
index 724a36e..8afca7d 100644
--- a/gcc/ada/libgnat/a-chzla1.ads
+++ b/gcc/ada/libgnat/a-chzla1.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-chzla9.ads b/gcc/ada/libgnat/a-chzla9.ads
index d61e62c..389bccf 100644
--- a/gcc/ada/libgnat/a-chzla9.ads
+++ b/gcc/ada/libgnat/a-chzla9.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-cidlli.adb b/gcc/ada/libgnat/a-cidlli.adb
index 65e4c10..0898db8 100644
--- a/gcc/ada/libgnat/a-cidlli.adb
+++ b/gcc/ada/libgnat/a-cidlli.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,7 +31,9 @@ with Ada.Unchecked_Deallocation;
with System; use type System.Address;
-package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
+package body Ada.Containers.Indefinite_Doubly_Linked_Lists with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -320,6 +322,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
X : Node_Access;
begin
+ TC_Check (Container.TC);
+
if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor has no element";
@@ -349,8 +353,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
return;
end if;
- TC_Check (Container.TC);
-
for Index in 1 .. Count loop
X := Position.Node;
Container.Length := Container.Length - 1;
@@ -667,6 +669,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
return;
end if;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
+
if Checks and then Target'Address = Source'Address then
raise Program_Error with
"Target and Source denote same non-empty container";
@@ -677,9 +682,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
raise Constraint_Error with "new length exceeds maximum";
end if;
- TC_Check (Target.TC);
- TC_Check (Source.TC);
-
declare
Lock_Target : With_Lock (Target.TC'Unchecked_Access);
Lock_Source : With_Lock (Source.TC'Unchecked_Access);
@@ -847,6 +849,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
New_Node : Node_Access;
begin
+ TC_Check (Container.TC);
+
if Before.Container /= null then
if Checks and then Before.Container /= Container'Unrestricted_Access
then
@@ -873,8 +877,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
raise Constraint_Error with "new length exceeds maximum";
end if;
- TC_Check (Container.TC);
-
declare
-- The element allocator may need an accessibility check in the case
-- the actual type is class-wide or has access discriminants (see
@@ -1420,6 +1422,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
New_Item : Element_Type)
is
begin
+ TE_Check (Container.TC);
+
if Checks and then Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
@@ -1429,8 +1433,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
"Position cursor designates wrong container";
end if;
- TE_Check (Container.TC);
-
if Checks and then Position.Node.Element = null then
raise Program_Error with
"Position cursor has no element";
@@ -1612,6 +1614,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Source : in out List)
is
begin
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
+
if Before.Container /= null then
if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
@@ -1636,9 +1641,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
raise Constraint_Error with "new length exceeds maximum";
end if;
- TC_Check (Target.TC);
- TC_Check (Source.TC);
-
Splice_Internal (Target, Before.Node, Source);
end Splice;
@@ -1648,6 +1650,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Position : Cursor)
is
begin
+ TC_Check (Container.TC);
+
if Before.Container /= null then
if Checks and then Before.Container /= Container'Unchecked_Access then
raise Program_Error with
@@ -1688,8 +1692,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Assert (Container.Length >= 2);
- TC_Check (Container.TC);
-
if Before.Node = null then
pragma Assert (Position.Node /= Container.Last);
@@ -1765,6 +1767,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
return;
end if;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
+
if Before.Container /= null then
if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
@@ -1801,9 +1806,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
raise Constraint_Error with "Target is full";
end if;
- TC_Check (Target.TC);
- TC_Check (Source.TC);
-
Splice_Internal (Target, Before.Node, Source, Position.Node);
Position.Container := Target'Unchecked_Access;
end Splice;
@@ -1960,6 +1962,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
I, J : Cursor)
is
begin
+ TE_Check (Container.TC);
+
if Checks and then I.Node = null then
raise Constraint_Error with "I cursor has no element";
end if;
@@ -1980,8 +1984,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
return;
end if;
- TE_Check (Container.TC);
-
pragma Assert (Vet (I), "bad I cursor in Swap");
pragma Assert (Vet (J), "bad J cursor in Swap");
@@ -2003,6 +2005,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
I, J : Cursor)
is
begin
+ TC_Check (Container.TC);
+
if Checks and then I.Node = null then
raise Constraint_Error with "I cursor has no element";
end if;
@@ -2023,8 +2027,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
return;
end if;
- TC_Check (Container.TC);
-
pragma Assert (Vet (I), "bad I cursor in Swap_Links");
pragma Assert (Vet (J), "bad J cursor in Swap_Links");
diff --git a/gcc/ada/libgnat/a-cidlli.ads b/gcc/ada/libgnat/a-cidlli.ads
index 14d1065..e9220a6 100644
--- a/gcc/ada/libgnat/a-cidlli.ads
+++ b/gcc/ada/libgnat/a-cidlli.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -43,7 +43,9 @@ generic
with function "=" (Left, Right : Element_Type)
return Boolean is <>;
-package Ada.Containers.Indefinite_Doubly_Linked_Lists is
+package Ada.Containers.Indefinite_Doubly_Linked_Lists with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-cihama.adb b/gcc/ada/libgnat/a-cihama.adb
index b33246d..9f5aed7 100644
--- a/gcc/ada/libgnat/a-cihama.adb
+++ b/gcc/ada/libgnat/a-cihama.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -39,7 +39,9 @@ with Ada.Unchecked_Deallocation;
with System; use type System.Address;
-package body Ada.Containers.Indefinite_Hashed_Maps is
+package body Ada.Containers.Indefinite_Hashed_Maps with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -327,6 +329,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
+ TC_Check (Container.HT.TC);
+
if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Delete equals No_Element";
@@ -338,8 +342,6 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
"Position cursor of Delete designates wrong map";
end if;
- TC_Check (Container.HT.TC);
-
pragma Assert (Vet (Position), "bad cursor in Delete");
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
@@ -1106,13 +1108,13 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
E : Element_Access;
begin
+ TE_Check (Container.HT.TC);
+
if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace key not in map";
end if;
- TE_Check (Container.HT.TC);
-
K := Node.Key;
E := Node.Element;
@@ -1148,6 +1150,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
New_Item : Element_Type)
is
begin
+ TE_Check (Position.Container.HT.TC);
+
if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
@@ -1166,8 +1170,6 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
"Position cursor of Replace_Element designates wrong map";
end if;
- TE_Check (Position.Container.HT.TC);
-
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
declare
diff --git a/gcc/ada/libgnat/a-cihama.ads b/gcc/ada/libgnat/a-cihama.ads
index 97a78b2..fb6f4e0 100644
--- a/gcc/ada/libgnat/a-cihama.ads
+++ b/gcc/ada/libgnat/a-cihama.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -45,7 +45,9 @@ generic
with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Indefinite_Hashed_Maps is
+package Ada.Containers.Indefinite_Hashed_Maps with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-cihase.adb b/gcc/ada/libgnat/a-cihase.adb
index bec48d0..b91532d 100644
--- a/gcc/ada/libgnat/a-cihase.adb
+++ b/gcc/ada/libgnat/a-cihase.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -41,7 +41,9 @@ with Ada.Containers.Prime_Numbers;
with System; use type System.Address;
-package body Ada.Containers.Indefinite_Hashed_Sets is
+package body Ada.Containers.Indefinite_Hashed_Sets with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -320,6 +322,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Position : in out Cursor)
is
begin
+ TC_Check (Container.HT.TC);
+
if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
@@ -333,8 +337,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
raise Program_Error with "Position cursor designates wrong set";
end if;
- TC_Check (Container.HT.TC);
-
pragma Assert (Vet (Position), "Position cursor is bad");
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
@@ -1321,13 +1323,13 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
pragma Warnings (Off, X);
begin
+ TE_Check (Container.HT.TC);
+
if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace element not in set";
end if;
- TE_Check (Container.HT.TC);
-
X := Node.Element;
declare
@@ -2227,7 +2229,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Control =>
(Controlled with
HT.TC'Unrestricted_Access,
- Container => Container'Access,
+ Container => Container'Unchecked_Access,
Index => HT_Ops.Index (HT, Position.Node),
Old_Pos => Position,
Old_Hash => Hash (Key (Position))))
@@ -2261,7 +2263,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Control =>
(Controlled with
HT.TC'Unrestricted_Access,
- Container => Container'Access,
+ Container => Container'Unchecked_Access,
Index => HT_Ops.Index (HT, P.Node),
Old_Pos => P,
Old_Hash => Hash (Key)))
diff --git a/gcc/ada/libgnat/a-cihase.ads b/gcc/ada/libgnat/a-cihase.ads
index ed62c01..926e07f 100644
--- a/gcc/ada/libgnat/a-cihase.ads
+++ b/gcc/ada/libgnat/a-cihase.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -48,7 +48,9 @@ generic
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Indefinite_Hashed_Sets is
+package Ada.Containers.Indefinite_Hashed_Sets with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-cimutr.adb b/gcc/ada/libgnat/a-cimutr.adb
index c5cf221..293275a 100644
--- a/gcc/ada/libgnat/a-cimutr.adb
+++ b/gcc/ada/libgnat/a-cimutr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,7 +31,9 @@ with Ada.Unchecked_Deallocation;
with System; use type System.Address;
-package body Ada.Containers.Indefinite_Multiway_Trees is
+package body Ada.Containers.Indefinite_Multiway_Trees with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -261,6 +263,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Element : Element_Access;
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -273,8 +277,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
return;
end if;
- TC_Check (Container.TC);
-
declare
-- The element allocator may need an accessibility check in the case
-- the actual type is class-wide or has access discriminants (see
@@ -738,6 +740,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Count : Count_Type;
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -746,8 +750,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
raise Program_Error with "Parent cursor not in container";
end if;
- TC_Check (Container.TC);
-
-- Deallocate_Children returns a count of the number of nodes
-- that it deallocates, but it works by incrementing the
-- value that is passed in. We must therefore initialize
@@ -772,6 +774,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
X : Tree_Node_Access;
begin
+ TC_Check (Container.TC);
+
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@@ -789,8 +793,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
raise Constraint_Error with "Position cursor does not designate leaf";
end if;
- TC_Check (Container.TC);
-
X := Position.Node;
Position := No_Element;
@@ -819,6 +821,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Count : Count_Type;
begin
+ TC_Check (Container.TC);
+
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@@ -832,8 +836,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
raise Program_Error with "Position cursor designates root";
end if;
- TC_Check (Container.TC);
-
X := Position.Node;
Position := No_Element;
@@ -1191,6 +1193,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Element : Element_Access;
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -1215,8 +1219,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
return;
end if;
- TC_Check (Container.TC);
-
declare
-- The element allocator may need an accessibility check in the case
-- the actual type is class-wide or has access discriminants (see
@@ -1735,6 +1737,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Element : Element_Access;
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -1747,8 +1751,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
return;
end if;
- TC_Check (Container.TC);
-
declare
-- The element allocator may need an accessibility check in the case
-- the actual type is class-wide or has access discriminants (see
@@ -2096,6 +2098,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
E, X : Element_Access;
begin
+ TE_Check (Container.TC);
+
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@@ -2109,8 +2113,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
raise Program_Error with "Position cursor designates root";
end if;
- TE_Check (Container.TC);
-
declare
-- The element allocator may need an accessibility check in the case
-- the actual type is class-wide or has access discriminants (see
@@ -2182,6 +2184,9 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Count : Count_Type;
begin
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
+
if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
@@ -2219,8 +2224,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
return;
end if;
- TC_Check (Target.TC);
-
if Checks and then Is_Reachable (From => Target_Parent.Node,
To => Source_Parent.Node)
then
@@ -2236,9 +2239,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
return;
end if;
- TC_Check (Target.TC);
- TC_Check (Source.TC);
-
-- We cache the count of the nodes we have allocated, so that operation
-- Node_Count can execute in O(1) time. But that means we must count the
-- nodes in the subtree we remove from Source and insert into Target, in
@@ -2265,6 +2265,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Source_Parent : Cursor)
is
begin
+ TC_Check (Container.TC);
+
if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
@@ -2304,8 +2306,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
return;
end if;
- TC_Check (Container.TC);
-
if Checks and then Is_Reachable (From => Target_Parent.Node,
To => Source_Parent.Node)
then
@@ -2363,6 +2363,9 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Subtree_Count : Count_Type;
begin
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -2404,8 +2407,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
end if;
end if;
- TC_Check (Target.TC);
-
if Checks and then
Is_Reachable (From => Parent.Node, To => Position.Node)
then
@@ -2420,9 +2421,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
return;
end if;
- TC_Check (Target.TC);
- TC_Check (Source.TC);
-
-- This is an unfortunate feature of this API: we must count the nodes
-- in the subtree that we remove from the source tree, which is an O(n)
-- operation. It would have been better if the Tree container did not
@@ -2455,6 +2453,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Position : Cursor)
is
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -2500,8 +2500,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
end if;
end if;
- TC_Check (Container.TC);
-
if Checks and then
Is_Reachable (From => Parent.Node, To => Position.Node)
then
@@ -2553,6 +2551,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
I, J : Cursor)
is
begin
+ TE_Check (Container.TC);
+
if Checks and then I = No_Element then
raise Constraint_Error with "I cursor has no element";
end if;
@@ -2581,8 +2581,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
raise Program_Error with "J cursor designates root";
end if;
- TE_Check (Container.TC);
-
declare
EI : constant Element_Access := I.Node.Element;
diff --git a/gcc/ada/libgnat/a-cimutr.ads b/gcc/ada/libgnat/a-cimutr.ads
index 6441aeb..474a1b5 100644
--- a/gcc/ada/libgnat/a-cimutr.ads
+++ b/gcc/ada/libgnat/a-cimutr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -42,7 +42,9 @@ generic
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Indefinite_Multiway_Trees is
+package Ada.Containers.Indefinite_Multiway_Trees with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-ciorma.adb b/gcc/ada/libgnat/a-ciorma.adb
index 818a2ae..86cd01f 100644
--- a/gcc/ada/libgnat/a-ciorma.adb
+++ b/gcc/ada/libgnat/a-ciorma.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -39,7 +39,9 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
with System; use type System.Address;
-package body Ada.Containers.Indefinite_Ordered_Maps is
+package body Ada.Containers.Indefinite_Ordered_Maps with
+ SPARK_Mode => Off
+is
pragma Suppress (All_Checks);
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
@@ -1435,12 +1437,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
E : Element_Access;
begin
+ TE_Check (Container.Tree.TC);
+
if Checks and then Node = null then
raise Constraint_Error with "key not in map";
end if;
- TE_Check (Container.Tree.TC);
-
K := Node.Key;
E := Node.Element;
@@ -1476,6 +1478,8 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
New_Item : Element_Type)
is
begin
+ TE_Check (Container.Tree.TC);
+
if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
@@ -1494,8 +1498,6 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
"Position cursor of Replace_Element designates wrong map";
end if;
- TE_Check (Container.Tree.TC);
-
pragma Assert (Vet (Container.Tree, Position.Node),
"Position cursor of Replace_Element is bad");
diff --git a/gcc/ada/libgnat/a-ciorma.ads b/gcc/ada/libgnat/a-ciorma.ads
index 5a872dd..a7799a6 100644
--- a/gcc/ada/libgnat/a-ciorma.ads
+++ b/gcc/ada/libgnat/a-ciorma.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -44,7 +44,9 @@ generic
with function "<" (Left, Right : Key_Type) return Boolean is <>;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Indefinite_Ordered_Maps is
+package Ada.Containers.Indefinite_Ordered_Maps with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-ciormu.adb b/gcc/ada/libgnat/a-ciormu.adb
index 70fb4cf..110d734 100644
--- a/gcc/ada/libgnat/a-ciormu.adb
+++ b/gcc/ada/libgnat/a-ciormu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -40,7 +40,9 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
with System; use type System.Address;
-package body Ada.Containers.Indefinite_Ordered_Multisets is
+package body Ada.Containers.Indefinite_Ordered_Multisets with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
diff --git a/gcc/ada/libgnat/a-ciormu.ads b/gcc/ada/libgnat/a-ciormu.ads
index f8f4991..474ccc7 100644
--- a/gcc/ada/libgnat/a-ciormu.ads
+++ b/gcc/ada/libgnat/a-ciormu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -43,7 +43,9 @@ generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Indefinite_Ordered_Multisets is
+package Ada.Containers.Indefinite_Ordered_Multisets with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-ciorse.adb b/gcc/ada/libgnat/a-ciorse.adb
index 7cc7dca..772061d 100644
--- a/gcc/ada/libgnat/a-ciorse.adb
+++ b/gcc/ada/libgnat/a-ciorse.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,7 +42,9 @@ with Ada.Unchecked_Deallocation;
with System; use type System.Address;
-package body Ada.Containers.Indefinite_Ordered_Sets is
+package body Ada.Containers.Indefinite_Ordered_Sets with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -1013,7 +1015,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Control =>
(Controlled with
Tree.TC'Unrestricted_Access,
- Container => Container'Access,
+ Container => Container'Unchecked_Access,
Pos => Position,
Old_Key => new Key_Type'(Key (Position))))
do
@@ -1045,7 +1047,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Control =>
(Controlled with
Tree.TC'Unrestricted_Access,
- Container => Container'Access,
+ Container => Container'Unchecked_Access,
Pos => Find (Container, Key),
Old_Key => new Key_Type'(Key)))
do
@@ -1788,12 +1790,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
pragma Warnings (Off, X);
begin
+ TE_Check (Container.Tree.TC);
+
if Checks and then Node = null then
raise Constraint_Error with "attempt to replace element not in set";
end if;
- TE_Check (Container.Tree.TC);
-
declare
-- The element allocator may need an accessibility check in the case
-- the actual type is class-wide or has access discriminants (see
diff --git a/gcc/ada/libgnat/a-ciorse.ads b/gcc/ada/libgnat/a-ciorse.ads
index 0a98d18..1eb8135 100644
--- a/gcc/ada/libgnat/a-ciorse.ads
+++ b/gcc/ada/libgnat/a-ciorse.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -44,7 +44,9 @@ generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Indefinite_Ordered_Sets is
+package Ada.Containers.Indefinite_Ordered_Sets with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-clrefi.adb b/gcc/ada/libgnat/a-clrefi.adb
index 51d1a84..2d2c78c 100644
--- a/gcc/ada/libgnat/a-clrefi.adb
+++ b/gcc/ada/libgnat/a-clrefi.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-clrefi.ads b/gcc/ada/libgnat/a-clrefi.ads
index 27e9c39..4aace2d 100644
--- a/gcc/ada/libgnat/a-clrefi.ads
+++ b/gcc/ada/libgnat/a-clrefi.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-coboho.adb b/gcc/ada/libgnat/a-coboho.adb
index 45b2210..eefb106 100644
--- a/gcc/ada/libgnat/a-coboho.adb
+++ b/gcc/ada/libgnat/a-coboho.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2015-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-coboho.ads b/gcc/ada/libgnat/a-coboho.ads
index 036569c..cb24c89 100644
--- a/gcc/ada/libgnat/a-coboho.ads
+++ b/gcc/ada/libgnat/a-coboho.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2015-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-cobove.adb b/gcc/ada/libgnat/a-cobove.adb
index 7508794..fe94ea5 100644
--- a/gcc/ada/libgnat/a-cobove.adb
+++ b/gcc/ada/libgnat/a-cobove.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -483,6 +483,8 @@ package body Ada.Containers.Bounded_Vectors is
Off : Count_Type'Base; -- Index expressed as offset from IT'First
begin
+ TC_Check (Container.TC);
+
-- Delete removes items from the vector, the number of which is the
-- minimum of the specified Count and the items (if any) that exist from
-- Index to Container.Last. There are no constraints on the specified
@@ -532,8 +534,6 @@ package body Ada.Containers.Bounded_Vectors is
-- the count on exit. Delete checks the count to determine whether it is
-- being called while the associated callback procedure is executing.
- TC_Check (Container.TC);
-
-- We first calculate what's available for deletion starting at
-- Index. Here and elsewhere we use the wider of Index_Type'Base and
-- Count_Type'Base as the type for intermediate values. (See function
@@ -636,15 +636,6 @@ package body Ada.Containers.Bounded_Vectors is
Count : Count_Type := 1)
is
begin
- -- It is not permitted to delete items while the container is busy (for
- -- example, we're in the middle of a passive iteration). However, we
- -- always treat deleting 0 items as a no-op, even when we're busy, so we
- -- simply return without checking.
-
- if Count = 0 then
- return;
- end if;
-
-- The tampering bits exist to prevent an item from being deleted (or
-- otherwise harmfully manipulated) while it is being visited. Query,
-- Update, and Iterate increment the busy count on entry, and decrement
@@ -654,6 +645,10 @@ package body Ada.Containers.Bounded_Vectors is
TC_Check (Container.TC);
+ if Count = 0 then
+ return;
+ end if;
+
-- There is no restriction on how large Count can be when deleting
-- items. If it is equal or greater than the current length, then this
-- is equivalent to clearing the vector. (In particular, there's no need
@@ -882,6 +877,8 @@ package body Ada.Containers.Bounded_Vectors is
return;
end if;
+ TC_Check (Source.TC);
+
if Checks and then Target'Address = Source'Address then
raise Program_Error with
"Target and Source denote same non-empty container";
@@ -892,8 +889,6 @@ package body Ada.Containers.Bounded_Vectors is
return;
end if;
- TC_Check (Source.TC);
-
I := Target.Length;
Target.Set_Length (I + Source.Length);
@@ -1021,6 +1016,14 @@ package body Ada.Containers.Bounded_Vectors is
J : Count_Type'Base; -- scratch
begin
+ -- The tampering bits exist to prevent an item from being harmfully
+ -- manipulated while it is being visited. Query, Update, and Iterate
+ -- increment the busy count on entry, and decrement the count on
+ -- exit. Insert checks the count to determine whether it is being called
+ -- while the associated callback procedure is executing.
+
+ TC_Check (Container.TC);
+
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
-- that Container.Last assumes when the vector is empty. However, we do
@@ -1176,14 +1179,6 @@ package body Ada.Containers.Bounded_Vectors is
raise Constraint_Error with "Count is out of range";
end if;
- -- The tampering bits exist to prevent an item from being harmfully
- -- manipulated while it is being visited. Query, Update, and Iterate
- -- increment the busy count on entry, and decrement the count on
- -- exit. Insert checks the count to determine whether it is being called
- -- while the associated callback procedure is executing.
-
- TC_Check (Container.TC);
-
if Checks and then New_Length > Container.Capacity then
raise Capacity_Error with "New length is larger than capacity";
end if;
@@ -1491,6 +1486,14 @@ package body Ada.Containers.Bounded_Vectors is
J : Count_Type'Base; -- scratch
begin
+ -- The tampering bits exist to prevent an item from being harmfully
+ -- manipulated while it is being visited. Query, Update, and Iterate
+ -- increment the busy count on entry, and decrement the count on
+ -- exit. Insert checks the count to determine whether it is being called
+ -- while the associated callback procedure is executing.
+
+ TC_Check (Container.TC);
+
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
-- that Container.Last assumes when the vector is empty. However, we do
@@ -1646,14 +1649,6 @@ package body Ada.Containers.Bounded_Vectors is
raise Constraint_Error with "Count is out of range";
end if;
- -- The tampering bits exist to prevent an item from being harmfully
- -- manipulated while it is being visited. Query, Update, and Iterate
- -- increment the busy count on entry, and decrement the count on
- -- exit. Insert checks the count to determine whether it is being called
- -- while the associated callback procedure is executing.
-
- TC_Check (Container.TC);
-
-- An internal array has already been allocated, so we need to check
-- whether there is enough unused storage for the new items.
@@ -1937,14 +1932,14 @@ package body Ada.Containers.Bounded_Vectors is
return;
end if;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
+
if Checks and then Target.Capacity < Source.Length then
raise Capacity_Error -- ???
with "Target capacity is less than Source length";
end if;
- TC_Check (Target.TC);
- TC_Check (Source.TC);
-
-- Clear Target now, in case element assignment fails
Target.Last := No_Index;
@@ -2222,12 +2217,12 @@ package body Ada.Containers.Bounded_Vectors is
New_Item : Element_Type)
is
begin
+ TE_Check (Container.TC);
+
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
- TE_Check (Container.TC);
-
Container.Elements (To_Array_Index (Index)) := New_Item;
end Replace_Element;
@@ -2237,6 +2232,8 @@ package body Ada.Containers.Bounded_Vectors is
New_Item : Element_Type)
is
begin
+ TE_Check (Container.TC);
+
if Checks and then Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
@@ -2250,8 +2247,6 @@ package body Ada.Containers.Bounded_Vectors is
raise Constraint_Error with "Position cursor is out of range";
end if;
- TE_Check (Container.TC);
-
Container.Elements (To_Array_Index (Position.Index)) := New_Item;
end Replace_Element;
@@ -2425,6 +2420,8 @@ package body Ada.Containers.Bounded_Vectors is
E : Elements_Array renames Container.Elements;
begin
+ TE_Check (Container.TC);
+
if Checks and then I > Container.Last then
raise Constraint_Error with "I index is out of range";
end if;
@@ -2437,8 +2434,6 @@ package body Ada.Containers.Bounded_Vectors is
return;
end if;
- TE_Check (Container.TC);
-
declare
EI_Copy : constant Element_Type := E (To_Array_Index (I));
begin
diff --git a/gcc/ada/libgnat/a-cobove.ads b/gcc/ada/libgnat/a-cobove.ads
index 34a1fc00..72da498 100644
--- a/gcc/ada/libgnat/a-cobove.ads
+++ b/gcc/ada/libgnat/a-cobove.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-cofove.adb b/gcc/ada/libgnat/a-cofove.adb
index 1240a50..41c69a8 100644
--- a/gcc/ada/libgnat/a-cofove.adb
+++ b/gcc/ada/libgnat/a-cofove.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -868,7 +868,11 @@ is
-- less than 0, so it is safe to compute the following sum without
-- fear of overflow.
+ pragma Warnings
+ (Off, "value not in range of type ""T"" defined at line 4");
Index := No_Index + Index_Type'Base (Count_Type'Last);
+ pragma Warnings
+ (On, "value not in range of type ""T"" defined at line 4");
if Index <= Index_Type'Last then
diff --git a/gcc/ada/libgnat/a-cofove.ads b/gcc/ada/libgnat/a-cofove.ads
index 5fb3bc9..5712e63 100644
--- a/gcc/ada/libgnat/a-cofove.ads
+++ b/gcc/ada/libgnat/a-cofove.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-cofuba.adb b/gcc/ada/libgnat/a-cofuba.adb
index 5c5f488..6f2b1f3 100644
--- a/gcc/ada/libgnat/a-cofuba.adb
+++ b/gcc/ada/libgnat/a-cofuba.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2016-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2016-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-cofuba.ads b/gcc/ada/libgnat/a-cofuba.ads
index b693baa..7865342 100644
--- a/gcc/ada/libgnat/a-cofuba.ads
+++ b/gcc/ada/libgnat/a-cofuba.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2016-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2016-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-cofuma.adb b/gcc/ada/libgnat/a-cofuma.adb
index e8da187..4defdf2 100644
--- a/gcc/ada/libgnat/a-cofuma.adb
+++ b/gcc/ada/libgnat/a-cofuma.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2016-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2016-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-cofuma.ads b/gcc/ada/libgnat/a-cofuma.ads
index e458b06..d50d5de 100644
--- a/gcc/ada/libgnat/a-cofuma.ads
+++ b/gcc/ada/libgnat/a-cofuma.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2016-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2016-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-cofuse.adb b/gcc/ada/libgnat/a-cofuse.adb
index e087d64..668c6d0 100644
--- a/gcc/ada/libgnat/a-cofuse.adb
+++ b/gcc/ada/libgnat/a-cofuse.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2016-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2016-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-cofuse.ads b/gcc/ada/libgnat/a-cofuse.ads
index c91a1d1..4209e74 100644
--- a/gcc/ada/libgnat/a-cofuse.ads
+++ b/gcc/ada/libgnat/a-cofuse.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2016-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2016-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-cofuve.adb b/gcc/ada/libgnat/a-cofuve.adb
index 026a32c..0ff2204 100644
--- a/gcc/ada/libgnat/a-cofuve.adb
+++ b/gcc/ada/libgnat/a-cofuve.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2016-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2016-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-cofuve.ads b/gcc/ada/libgnat/a-cofuve.ads
index 804d7b0..cfccf1d 100644
--- a/gcc/ada/libgnat/a-cofuve.ads
+++ b/gcc/ada/libgnat/a-cofuve.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2016-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2016-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -92,7 +92,8 @@ package Ada.Containers.Functional_Vectors with SPARK_Mode is
Length (Container));
pragma Annotate (GNATprove, Inline_For_Proof, Last);
- function First return Extended_Index is (Index_Type'First);
+ function First return Extended_Index is (Index_Type'First) with
+ Global => null;
-- First index of a sequence
------------------------
diff --git a/gcc/ada/libgnat/a-cogeso.adb b/gcc/ada/libgnat/a-cogeso.adb
index 447b03d..7a71772 100644
--- a/gcc/ada/libgnat/a-cogeso.adb
+++ b/gcc/ada/libgnat/a-cogeso.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-cogeso.ads b/gcc/ada/libgnat/a-cogeso.ads
index e77558f..6457e64 100644
--- a/gcc/ada/libgnat/a-cogeso.ads
+++ b/gcc/ada/libgnat/a-cogeso.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-cohama.adb b/gcc/ada/libgnat/a-cohama.adb
index e7da020..7f2d8e1 100644
--- a/gcc/ada/libgnat/a-cohama.adb
+++ b/gcc/ada/libgnat/a-cohama.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -39,7 +39,9 @@ with Ada.Containers.Helpers; use Ada.Containers.Helpers;
with System; use type System.Address;
-package body Ada.Containers.Hashed_Maps is
+package body Ada.Containers.Hashed_Maps with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -314,6 +316,8 @@ package body Ada.Containers.Hashed_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
+ TC_Check (Container.HT.TC);
+
if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Delete equals No_Element";
@@ -325,8 +329,6 @@ package body Ada.Containers.Hashed_Maps is
"Position cursor of Delete designates wrong map";
end if;
- TC_Check (Container.HT.TC);
-
pragma Assert (Vet (Position), "bad cursor in Delete");
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
@@ -999,13 +1001,13 @@ package body Ada.Containers.Hashed_Maps is
Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
begin
+ TE_Check (Container.HT.TC);
+
if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace key not in map";
end if;
- TE_Check (Container.HT.TC);
-
Node.Key := Key;
Node.Element := New_Item;
end Replace;
@@ -1020,6 +1022,8 @@ package body Ada.Containers.Hashed_Maps is
New_Item : Element_Type)
is
begin
+ TE_Check (Position.Container.HT.TC);
+
if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
@@ -1031,8 +1035,6 @@ package body Ada.Containers.Hashed_Maps is
"Position cursor of Replace_Element designates wrong map";
end if;
- TE_Check (Position.Container.HT.TC);
-
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
Position.Node.Element := New_Item;
diff --git a/gcc/ada/libgnat/a-cohama.ads b/gcc/ada/libgnat/a-cohama.ads
index d16e246..9d927bd 100644
--- a/gcc/ada/libgnat/a-cohama.ads
+++ b/gcc/ada/libgnat/a-cohama.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -88,7 +88,9 @@ generic
-- map values returns an unspecified value. The exact arguments and number
-- of calls of this generic formal function by the function "=" on map
-- values are unspecified.
-package Ada.Containers.Hashed_Maps is
+package Ada.Containers.Hashed_Maps with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-cohase.adb b/gcc/ada/libgnat/a-cohase.adb
index 61ebf87..bc4e53f 100644
--- a/gcc/ada/libgnat/a-cohase.adb
+++ b/gcc/ada/libgnat/a-cohase.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -41,7 +41,9 @@ with Ada.Containers.Prime_Numbers;
with System; use type System.Address;
-package body Ada.Containers.Hashed_Sets is
+package body Ada.Containers.Hashed_Sets with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -299,6 +301,8 @@ package body Ada.Containers.Hashed_Sets is
Position : in out Cursor)
is
begin
+ TC_Check (Container.HT.TC);
+
if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
@@ -308,8 +312,6 @@ package body Ada.Containers.Hashed_Sets is
raise Program_Error with "Position cursor designates wrong set";
end if;
- TC_Check (Container.HT.TC);
-
pragma Assert (Vet (Position), "bad cursor in Delete");
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
@@ -1204,13 +1206,13 @@ package body Ada.Containers.Hashed_Sets is
Element_Keys.Find (Container.HT, New_Item);
begin
+ TE_Check (Container.HT.TC);
+
if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace element not in set";
end if;
- TE_Check (Container.HT.TC);
-
Node.Element := New_Item;
end Replace;
diff --git a/gcc/ada/libgnat/a-cohase.ads b/gcc/ada/libgnat/a-cohase.ads
index 7cfd1a3..3645ed0 100644
--- a/gcc/ada/libgnat/a-cohase.ads
+++ b/gcc/ada/libgnat/a-cohase.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -48,7 +48,9 @@ generic
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Hashed_Sets is
+package Ada.Containers.Hashed_Sets with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-cohata.ads b/gcc/ada/libgnat/a-cohata.ads
index cf209bd..9033c52 100644
--- a/gcc/ada/libgnat/a-cohata.ads
+++ b/gcc/ada/libgnat/a-cohata.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-coinho.adb b/gcc/ada/libgnat/a-coinho.adb
index bc06ffb..c5da943 100644
--- a/gcc/ada/libgnat/a-coinho.adb
+++ b/gcc/ada/libgnat/a-coinho.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2012-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -304,6 +304,30 @@ package body Ada.Containers.Indefinite_Holders is
end;
end Replace_Element;
+ ----------
+ -- Swap --
+ ----------
+
+ procedure Swap (Left, Right : in out Holder) is
+ begin
+ if Left.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+
+ if Right.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+
+ if Left.Element /= Right.Element then
+ declare
+ Tmp : constant Element_Access := Left.Element;
+ begin
+ Left.Element := Right.Element;
+ Right.Element := Tmp;
+ end;
+ end if;
+ end Swap;
+
---------------
-- To_Holder --
---------------
diff --git a/gcc/ada/libgnat/a-coinho.ads b/gcc/ada/libgnat/a-coinho.ads
index c9035cd..bf6165e 100644
--- a/gcc/ada/libgnat/a-coinho.ads
+++ b/gcc/ada/libgnat/a-coinho.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -92,6 +92,8 @@ package Ada.Containers.Indefinite_Holders is
procedure Move (Target : in out Holder; Source : in out Holder);
+ procedure Swap (Left, Right : in out Holder);
+
private
use Ada.Finalization;
diff --git a/gcc/ada/libgnat/a-coinho__shared.adb b/gcc/ada/libgnat/a-coinho__shared.adb
index d96069f..43f5d52 100644
--- a/gcc/ada/libgnat/a-coinho__shared.adb
+++ b/gcc/ada/libgnat/a-coinho__shared.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2013-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -426,6 +426,30 @@ package body Ada.Containers.Indefinite_Holders is
end if;
end Replace_Element;
+ ----------
+ -- Swap --
+ ----------
+
+ procedure Swap (Left, Right : in out Holder) is
+ begin
+ if Left.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+
+ if Right.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+
+ if Left.Reference /= Right.Reference then
+ declare
+ Tmp : constant Shared_Holder_Access := Left.Reference;
+ begin
+ Left.Reference := Right.Reference;
+ Right.Reference := Tmp;
+ end;
+ end if;
+ end Swap;
+
---------------
-- To_Holder --
---------------
diff --git a/gcc/ada/libgnat/a-coinho__shared.ads b/gcc/ada/libgnat/a-coinho__shared.ads
index e29e5d0..0345b5e 100644
--- a/gcc/ada/libgnat/a-coinho__shared.ads
+++ b/gcc/ada/libgnat/a-coinho__shared.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2013-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -96,6 +96,8 @@ package Ada.Containers.Indefinite_Holders is
procedure Move (Target : in out Holder; Source : in out Holder);
+ procedure Swap (Left, Right : in out Holder);
+
private
use Ada.Finalization;
diff --git a/gcc/ada/libgnat/a-coinve.adb b/gcc/ada/libgnat/a-coinve.adb
index 0dfe1c6..79e36ae 100644
--- a/gcc/ada/libgnat/a-coinve.adb
+++ b/gcc/ada/libgnat/a-coinve.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,7 +32,9 @@ with Ada.Unchecked_Deallocation;
with System; use type System.Address;
-package body Ada.Containers.Indefinite_Vectors is
+package body Ada.Containers.Indefinite_Vectors with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -408,6 +410,14 @@ package body Ada.Containers.Indefinite_Vectors is
J : Index_Type'Base; -- first index of items that slide down
begin
+ -- The tampering bits exist to prevent an item from being deleted (or
+ -- otherwise harmfully manipulated) while it is being visited. Query,
+ -- Update, and Iterate increment the busy count on entry, and decrement
+ -- the count on exit. Delete checks the count to determine whether it is
+ -- being called while the associated callback procedure is executing.
+
+ TC_Check (Container.TC);
+
-- Delete removes items from the vector, the number of which is the
-- minimum of the specified Count and the items (if any) that exist from
-- Index to Container.Last. There are no constraints on the specified
@@ -460,14 +470,6 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
- -- The tampering bits exist to prevent an item from being deleted (or
- -- otherwise harmfully manipulated) while it is being visited. Query,
- -- Update, and Iterate increment the busy count on entry, and decrement
- -- the count on exit. Delete checks the count to determine whether it is
- -- being called while the associated callback procedure is executing.
-
- TC_Check (Container.TC);
-
-- We first calculate what's available for deletion starting at
-- Index. Here and elsewhere we use the wider of Index_Type'Base and
-- Count_Type'Base as the type for intermediate values. (See function
@@ -942,6 +944,8 @@ package body Ada.Containers.Indefinite_Vectors is
I, J : Index_Type'Base;
begin
+ TC_Check (Source.TC);
+
-- The semantics of Merge changed slightly per AI05-0021. It was
-- originally the case that if Target and Source denoted the same
-- container object, then the GNAT implementation of Merge did
@@ -964,8 +968,6 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
- TC_Check (Source.TC);
-
I := Target.Last; -- original value (before Set_Length)
Target.Set_Length (Length (Target) + Length (Source));
@@ -1128,6 +1130,14 @@ package body Ada.Containers.Indefinite_Vectors is
Dst : Elements_Access; -- new, expanded internal array
begin
+ -- The tampering bits exist to prevent an item from being harmfully
+ -- manipulated while it is being visited. Query, Update, and Iterate
+ -- increment the busy count on entry, and decrement the count on
+ -- exit. Insert checks the count to determine whether it is being called
+ -- while the associated callback procedure is executing.
+
+ TC_Check (Container.TC);
+
if Checks then
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
@@ -1335,14 +1345,6 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
- -- The tampering bits exist to prevent an item from being harmfully
- -- manipulated while it is being visited. Query, Update, and Iterate
- -- increment the busy count on entry, and decrement the count on
- -- exit. Insert checks the count to determine whether it is being called
- -- while the associated callback procedure is executing.
-
- TC_Check (Container.TC);
-
if New_Length <= Container.Elements.EA'Length then
-- In this case, we're inserting elements into a vector that has
@@ -1908,6 +1910,14 @@ package body Ada.Containers.Indefinite_Vectors is
Dst : Elements_Access; -- new, expanded internal array
begin
+ -- The tampering bits exist to prevent an item from being harmfully
+ -- manipulated while it is being visited. Query, Update, and Iterate
+ -- increment the busy count on entry, and decrement the count on exit.
+ -- Insert checks the count to determine whether it is being called while
+ -- the associated callback procedure is executing.
+
+ TC_Check (Container.TC);
+
if Checks then
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
@@ -2090,14 +2100,6 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
- -- The tampering bits exist to prevent an item from being harmfully
- -- manipulated while it is being visited. Query, Update, and Iterate
- -- increment the busy count on entry, and decrement the count on exit.
- -- Insert checks the count to determine whether it is being called while
- -- the associated callback procedure is executing.
-
- TC_Check (Container.TC);
-
if New_Length <= Container.Elements.EA'Length then
-- In this case, we are inserting elements into a vector that has
@@ -2757,12 +2759,12 @@ package body Ada.Containers.Indefinite_Vectors is
New_Item : Element_Type)
is
begin
+ TE_Check (Container.TC);
+
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
- TE_Check (Container.TC);
-
declare
X : Element_Access := Container.Elements.EA (Index);
@@ -2784,6 +2786,8 @@ package body Ada.Containers.Indefinite_Vectors is
New_Item : Element_Type)
is
begin
+ TE_Check (Container.TC);
+
if Checks then
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
@@ -2798,8 +2802,6 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
end if;
- TE_Check (Container.TC);
-
declare
X : Element_Access := Container.Elements.EA (Position.Index);
@@ -3258,6 +3260,8 @@ package body Ada.Containers.Indefinite_Vectors is
procedure Swap (Container : in out Vector; I, J : Index_Type) is
begin
+ TE_Check (Container.TC);
+
if Checks then
if I > Container.Last then
raise Constraint_Error with "I index is out of range";
@@ -3272,8 +3276,6 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
- TE_Check (Container.TC);
-
declare
EI : Element_Access renames Container.Elements.EA (I);
EJ : Element_Access renames Container.Elements.EA (J);
diff --git a/gcc/ada/libgnat/a-coinve.ads b/gcc/ada/libgnat/a-coinve.ads
index 9ca73ce..075a184 100644
--- a/gcc/ada/libgnat/a-coinve.ads
+++ b/gcc/ada/libgnat/a-coinve.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -43,7 +43,9 @@ generic
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Indefinite_Vectors is
+package Ada.Containers.Indefinite_Vectors with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-colien.adb b/gcc/ada/libgnat/a-colien.adb
index 7211c5e..9ea536d 100644
--- a/gcc/ada/libgnat/a-colien.adb
+++ b/gcc/ada/libgnat/a-colien.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-colien.ads b/gcc/ada/libgnat/a-colien.ads
index 87de37b..cdcb842 100644
--- a/gcc/ada/libgnat/a-colien.ads
+++ b/gcc/ada/libgnat/a-colien.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-colire.adb b/gcc/ada/libgnat/a-colire.adb
index 32d78df..c341773 100644
--- a/gcc/ada/libgnat/a-colire.adb
+++ b/gcc/ada/libgnat/a-colire.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-colire.ads b/gcc/ada/libgnat/a-colire.ads
index cf04606..975c0db 100644
--- a/gcc/ada/libgnat/a-colire.ads
+++ b/gcc/ada/libgnat/a-colire.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-comlin.adb b/gcc/ada/libgnat/a-comlin.adb
index 1471282..e6e6174 100644
--- a/gcc/ada/libgnat/a-comlin.adb
+++ b/gcc/ada/libgnat/a-comlin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-comlin.ads b/gcc/ada/libgnat/a-comlin.ads
index 4191fd3..8dbbb07 100644
--- a/gcc/ada/libgnat/a-comlin.ads
+++ b/gcc/ada/libgnat/a-comlin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-comutr.adb b/gcc/ada/libgnat/a-comutr.adb
index 9e6a00e..76ff751 100644
--- a/gcc/ada/libgnat/a-comutr.adb
+++ b/gcc/ada/libgnat/a-comutr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,7 +32,9 @@ with Ada.Unchecked_Deallocation;
with System; use type System.Address;
-package body Ada.Containers.Multiway_Trees is
+package body Ada.Containers.Multiway_Trees with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -263,6 +265,8 @@ package body Ada.Containers.Multiway_Trees is
Last : Tree_Node_Access;
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -275,8 +279,6 @@ package body Ada.Containers.Multiway_Trees is
return;
end if;
- TC_Check (Container.TC);
-
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => New_Item,
others => <>);
@@ -699,6 +701,8 @@ package body Ada.Containers.Multiway_Trees is
Count : Count_Type;
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -707,8 +711,6 @@ package body Ada.Containers.Multiway_Trees is
raise Program_Error with "Parent cursor not in container";
end if;
- TC_Check (Container.TC);
-
-- Deallocate_Children returns a count of the number of nodes that it
-- deallocates, but it works by incrementing the value that is passed
-- in. We must therefore initialize the count value before calling
@@ -733,6 +735,8 @@ package body Ada.Containers.Multiway_Trees is
X : Tree_Node_Access;
begin
+ TC_Check (Container.TC);
+
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@@ -750,8 +754,6 @@ package body Ada.Containers.Multiway_Trees is
raise Constraint_Error with "Position cursor does not designate leaf";
end if;
- TC_Check (Container.TC);
-
X := Position.Node;
Position := No_Element;
@@ -780,6 +782,8 @@ package body Ada.Containers.Multiway_Trees is
Count : Count_Type;
begin
+ TC_Check (Container.TC);
+
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@@ -793,8 +797,6 @@ package body Ada.Containers.Multiway_Trees is
raise Program_Error with "Position cursor designates root";
end if;
- TC_Check (Container.TC);
-
X := Position.Node;
Position := No_Element;
@@ -1145,6 +1147,8 @@ package body Ada.Containers.Multiway_Trees is
Last : Tree_Node_Access;
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -1169,8 +1173,6 @@ package body Ada.Containers.Multiway_Trees is
return;
end if;
- TC_Check (Container.TC);
-
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => New_Item,
others => <>);
@@ -1214,6 +1216,8 @@ package body Ada.Containers.Multiway_Trees is
Last : Tree_Node_Access;
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -1238,8 +1242,6 @@ package body Ada.Containers.Multiway_Trees is
return;
end if;
- TC_Check (Container.TC);
-
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => <>,
others => <>);
@@ -1737,6 +1739,8 @@ package body Ada.Containers.Multiway_Trees is
First, Last : Tree_Node_Access;
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -1749,8 +1753,6 @@ package body Ada.Containers.Multiway_Trees is
return;
end if;
- TC_Check (Container.TC);
-
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => New_Item,
others => <>);
@@ -2073,6 +2075,8 @@ package body Ada.Containers.Multiway_Trees is
New_Item : Element_Type)
is
begin
+ TE_Check (Container.TC);
+
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@@ -2086,8 +2090,6 @@ package body Ada.Containers.Multiway_Trees is
raise Program_Error with "Position cursor designates root";
end if;
- TE_Check (Container.TC);
-
Position.Node.Element := New_Item;
end Replace_Element;
@@ -2160,6 +2162,9 @@ package body Ada.Containers.Multiway_Trees is
Count : Count_Type;
begin
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
+
if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
@@ -2197,8 +2202,6 @@ package body Ada.Containers.Multiway_Trees is
return;
end if;
- TC_Check (Target.TC);
-
if Checks and then Is_Reachable (From => Target_Parent.Node,
To => Source_Parent.Node)
then
@@ -2214,9 +2217,6 @@ package body Ada.Containers.Multiway_Trees is
return;
end if;
- TC_Check (Target.TC);
- TC_Check (Source.TC);
-
-- We cache the count of the nodes we have allocated, so that operation
-- Node_Count can execute in O(1) time. But that means we must count the
-- nodes in the subtree we remove from Source and insert into Target, in
@@ -2243,6 +2243,8 @@ package body Ada.Containers.Multiway_Trees is
Source_Parent : Cursor)
is
begin
+ TC_Check (Container.TC);
+
if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
@@ -2282,8 +2284,6 @@ package body Ada.Containers.Multiway_Trees is
return;
end if;
- TC_Check (Container.TC);
-
if Checks and then Is_Reachable (From => Target_Parent.Node,
To => Source_Parent.Node)
then
@@ -2341,6 +2341,9 @@ package body Ada.Containers.Multiway_Trees is
Subtree_Count : Count_Type;
begin
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -2382,8 +2385,6 @@ package body Ada.Containers.Multiway_Trees is
end if;
end if;
- TC_Check (Target.TC);
-
if Checks and then
Is_Reachable (From => Parent.Node, To => Position.Node)
then
@@ -2398,9 +2399,6 @@ package body Ada.Containers.Multiway_Trees is
return;
end if;
- TC_Check (Target.TC);
- TC_Check (Source.TC);
-
-- This is an unfortunate feature of this API: we must count the nodes
-- in the subtree that we remove from the source tree, which is an O(n)
-- operation. It would have been better if the Tree container did not
@@ -2433,6 +2431,8 @@ package body Ada.Containers.Multiway_Trees is
Position : Cursor)
is
begin
+ TC_Check (Container.TC);
+
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@@ -2478,8 +2478,6 @@ package body Ada.Containers.Multiway_Trees is
end if;
end if;
- TC_Check (Container.TC);
-
if Checks and then
Is_Reachable (From => Parent.Node, To => Position.Node)
then
@@ -2531,6 +2529,8 @@ package body Ada.Containers.Multiway_Trees is
I, J : Cursor)
is
begin
+ TE_Check (Container.TC);
+
if Checks and then I = No_Element then
raise Constraint_Error with "I cursor has no element";
end if;
@@ -2559,8 +2559,6 @@ package body Ada.Containers.Multiway_Trees is
raise Program_Error with "J cursor designates root";
end if;
- TE_Check (Container.TC);
-
declare
EI : constant Element_Type := I.Node.Element;
diff --git a/gcc/ada/libgnat/a-comutr.ads b/gcc/ada/libgnat/a-comutr.ads
index e6a8dbd..46934a1 100644
--- a/gcc/ada/libgnat/a-comutr.ads
+++ b/gcc/ada/libgnat/a-comutr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -42,7 +42,9 @@ generic
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Multiway_Trees is
+package Ada.Containers.Multiway_Trees with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-conhel.adb b/gcc/ada/libgnat/a-conhel.adb
index 06af0da..1a30b53 100644
--- a/gcc/ada/libgnat/a-conhel.adb
+++ b/gcc/ada/libgnat/a-conhel.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2015-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-conhel.ads b/gcc/ada/libgnat/a-conhel.ads
index b76f519..80ae980 100644
--- a/gcc/ada/libgnat/a-conhel.ads
+++ b/gcc/ada/libgnat/a-conhel.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2015-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-convec.adb b/gcc/ada/libgnat/a-convec.adb
index f5e2eb4..c2a0a83 100644
--- a/gcc/ada/libgnat/a-convec.adb
+++ b/gcc/ada/libgnat/a-convec.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,8 +31,11 @@ with Ada.Containers.Generic_Array_Sort;
with Ada.Unchecked_Deallocation;
with System; use type System.Address;
+with System.Put_Images;
-package body Ada.Containers.Vectors is
+package body Ada.Containers.Vectors with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -377,6 +380,14 @@ package body Ada.Containers.Vectors is
J : Index_Type'Base; -- first index of items that slide down
begin
+ -- The tampering bits exist to prevent an item from being deleted (or
+ -- otherwise harmfully manipulated) while it is being visited. Query,
+ -- Update, and Iterate increment the busy count on entry, and decrement
+ -- the count on exit. Delete checks the count to determine whether it is
+ -- being called while the associated callback procedure is executing.
+
+ TC_Check (Container.TC);
+
-- Delete removes items from the vector, the number of which is the
-- minimum of the specified Count and the items (if any) that exist from
-- Index to Container.Last. There are no constraints on the specified
@@ -420,14 +431,6 @@ package body Ada.Containers.Vectors is
return;
end if;
- -- The tampering bits exist to prevent an item from being deleted (or
- -- otherwise harmfully manipulated) while it is being visited. Query,
- -- Update, and Iterate increment the busy count on entry, and decrement
- -- the count on exit. Delete checks the count to determine whether it is
- -- being called while the associated callback procedure is executing.
-
- TC_Check (Container.TC);
-
-- We first calculate what's available for deletion starting at
-- Index. Here and elsewhere we use the wider of Index_Type'Base and
-- Count_Type'Base as the type for intermediate values. (See function
@@ -781,6 +784,8 @@ package body Ada.Containers.Vectors is
J : Index_Type'Base;
begin
+ TC_Check (Source.TC);
+
-- The semantics of Merge changed slightly per AI05-0021. It was
-- originally the case that if Target and Source denoted the same
-- container object, then the GNAT implementation of Merge did
@@ -803,8 +808,6 @@ package body Ada.Containers.Vectors is
return;
end if;
- TC_Check (Source.TC);
-
Target.Set_Length (Length (Target) + Length (Source));
-- Per AI05-0022, the container implementation is required to detect
@@ -861,10 +864,6 @@ package body Ada.Containers.Vectors is
"<" => "<");
begin
- if Container.Last <= Index_Type'First then
- return;
- end if;
-
-- The exception behavior for the vector container must match that
-- for the list container, so we check for cursor tampering here
-- (which will catch more things) instead of for element tampering
@@ -878,6 +877,10 @@ package body Ada.Containers.Vectors is
TC_Check (Container.TC);
+ if Container.Last <= Index_Type'First then
+ return;
+ end if;
+
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
@@ -933,6 +936,14 @@ package body Ada.Containers.Vectors is
Dst : Elements_Access; -- new, expanded internal array
begin
+ -- The tampering bits exist to prevent an item from being harmfully
+ -- manipulated while it is being visited. Query, Update, and Iterate
+ -- increment the busy count on entry, and decrement the count on
+ -- exit. Insert checks the count to determine whether it is being called
+ -- while the associated callback procedure is executing.
+
+ TC_Check (Container.TC);
+
if Checks then
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
@@ -1124,14 +1135,6 @@ package body Ada.Containers.Vectors is
return;
end if;
- -- The tampering bits exist to prevent an item from being harmfully
- -- manipulated while it is being visited. Query, Update, and Iterate
- -- increment the busy count on entry, and decrement the count on
- -- exit. Insert checks the count to determine whether it is being called
- -- while the associated callback procedure is executing.
-
- TC_Check (Container.TC);
-
-- An internal array has already been allocated, so we must determine
-- whether there is enough unused storage for the new items.
@@ -1595,6 +1598,14 @@ package body Ada.Containers.Vectors is
Dst : Elements_Access; -- new, expanded internal array
begin
+ -- The tampering bits exist to prevent an item from being harmfully
+ -- manipulated while it is being visited. Query, Update, and Iterate
+ -- increment the busy count on entry, and decrement the count on
+ -- exit. Insert checks the count to determine whether it is being called
+ -- while the associated callback procedure is executing.
+
+ TC_Check (Container.TC);
+
if Checks then
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
@@ -1784,14 +1795,6 @@ package body Ada.Containers.Vectors is
return;
end if;
- -- The tampering bits exist to prevent an item from being harmfully
- -- manipulated while it is being visited. Query, Update, and Iterate
- -- increment the busy count on entry, and decrement the count on
- -- exit. Insert checks the count to determine whether it is being called
- -- while the associated callback procedure is executing.
-
- TC_Check (Container.TC);
-
-- An internal array has already been allocated, so we must determine
-- whether there is enough unused storage for the new items.
@@ -2297,6 +2300,31 @@ package body Ada.Containers.Vectors is
end return;
end Pseudo_Reference;
+ ---------------
+ -- Put_Image --
+ ---------------
+
+ procedure Put_Image
+ (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector)
+ is
+ First_Time : Boolean := True;
+ use System.Put_Images;
+ begin
+ Array_Before (S);
+
+ for X of V loop
+ if First_Time then
+ First_Time := False;
+ else
+ Simple_Array_Between (S);
+ end if;
+
+ Element_Type'Put_Image (S, X);
+ end loop;
+
+ Array_After (S);
+ end Put_Image;
+
-------------------
-- Query_Element --
-------------------
@@ -2446,11 +2474,12 @@ package body Ada.Containers.Vectors is
New_Item : Element_Type)
is
begin
+ TE_Check (Container.TC);
+
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
- TE_Check (Container.TC);
Container.Elements.EA (Index) := New_Item;
end Replace_Element;
@@ -2460,6 +2489,8 @@ package body Ada.Containers.Vectors is
New_Item : Element_Type)
is
begin
+ TE_Check (Container.TC);
+
if Checks then
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
@@ -2472,7 +2503,6 @@ package body Ada.Containers.Vectors is
end if;
end if;
- TE_Check (Container.TC);
Container.Elements.EA (Position.Index) := New_Item;
end Replace_Element;
@@ -2940,6 +2970,8 @@ package body Ada.Containers.Vectors is
procedure Swap (Container : in out Vector; I, J : Index_Type) is
begin
+ TE_Check (Container.TC);
+
if Checks then
if I > Container.Last then
raise Constraint_Error with "I index is out of range";
@@ -2954,8 +2986,6 @@ package body Ada.Containers.Vectors is
return;
end if;
- TE_Check (Container.TC);
-
declare
EI_Copy : constant Element_Type := Container.Elements.EA (I);
begin
diff --git a/gcc/ada/libgnat/a-convec.ads b/gcc/ada/libgnat/a-convec.ads
index 8109f8a..a12e456 100644
--- a/gcc/ada/libgnat/a-convec.ads
+++ b/gcc/ada/libgnat/a-convec.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -36,6 +36,7 @@ with Ada.Iterator_Interfaces;
with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
+private with Ada.Strings.Text_Output;
-- The language-defined generic package Containers.Vectors provides private
-- types Vector and Cursor, and a set of operations for each type. A vector
@@ -70,7 +71,9 @@ generic
-- number of calls of this generic formal function by the functions defined
-- to use it are unspecified.
-package Ada.Containers.Vectors is
+package Ada.Containers.Vectors with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
pragma Remote_Types;
@@ -694,7 +697,10 @@ private
Elements : Elements_Access := null;
Last : Extended_Index := No_Index;
TC : aliased Tamper_Counts;
- end record;
+ end record with Put_Image => Put_Image;
+
+ procedure Put_Image
+ (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector);
overriding procedure Adjust (Container : in out Vector);
overriding procedure Finalize (Container : in out Vector);
diff --git a/gcc/ada/libgnat/a-coorma.adb b/gcc/ada/libgnat/a-coorma.adb
index e49ae90..4106d58 100644
--- a/gcc/ada/libgnat/a-coorma.adb
+++ b/gcc/ada/libgnat/a-coorma.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -39,7 +39,9 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
with System; use type System.Address;
-package body Ada.Containers.Ordered_Maps is
+package body Ada.Containers.Ordered_Maps with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -1349,12 +1351,12 @@ package body Ada.Containers.Ordered_Maps is
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
+ TE_Check (Container.Tree.TC);
+
if Checks and then Node = null then
raise Constraint_Error with "key not in map";
end if;
- TE_Check (Container.Tree.TC);
-
Node.Key := Key;
Node.Element := New_Item;
end Replace;
@@ -1369,6 +1371,8 @@ package body Ada.Containers.Ordered_Maps is
New_Item : Element_Type)
is
begin
+ TE_Check (Container.Tree.TC);
+
if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
@@ -1380,8 +1384,6 @@ package body Ada.Containers.Ordered_Maps is
"Position cursor of Replace_Element designates wrong map";
end if;
- TE_Check (Container.Tree.TC);
-
pragma Assert (Vet (Container.Tree, Position.Node),
"Position cursor of Replace_Element is bad");
diff --git a/gcc/ada/libgnat/a-coorma.ads b/gcc/ada/libgnat/a-coorma.ads
index 7599750..e2d5e1e 100644
--- a/gcc/ada/libgnat/a-coorma.ads
+++ b/gcc/ada/libgnat/a-coorma.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -44,7 +44,9 @@ generic
with function "<" (Left, Right : Key_Type) return Boolean is <>;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Ordered_Maps is
+package Ada.Containers.Ordered_Maps with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-coormu.adb b/gcc/ada/libgnat/a-coormu.adb
index 52db05d..c02a9f1 100644
--- a/gcc/ada/libgnat/a-coormu.adb
+++ b/gcc/ada/libgnat/a-coormu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -40,7 +40,9 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
with System; use type System.Address;
-package body Ada.Containers.Ordered_Multisets is
+package body Ada.Containers.Ordered_Multisets with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
diff --git a/gcc/ada/libgnat/a-coormu.ads b/gcc/ada/libgnat/a-coormu.ads
index a3d7631..9c6c3ae 100644
--- a/gcc/ada/libgnat/a-coormu.ads
+++ b/gcc/ada/libgnat/a-coormu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,7 +42,9 @@ generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Ordered_Multisets is
+package Ada.Containers.Ordered_Multisets with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-coorse.adb b/gcc/ada/libgnat/a-coorse.adb
index d2f8a58..15b59dd 100644
--- a/gcc/ada/libgnat/a-coorse.adb
+++ b/gcc/ada/libgnat/a-coorse.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,7 +42,9 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
with System; use type System.Address;
-package body Ada.Containers.Ordered_Sets is
+package body Ada.Containers.Ordered_Sets with
+ SPARK_Mode => Off
+is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
@@ -899,7 +901,7 @@ package body Ada.Containers.Ordered_Sets is
Control =>
(Controlled with
Tree.TC'Unrestricted_Access,
- Container => Container'Access,
+ Container => Container'Unchecked_Access,
Pos => Position,
Old_Key => new Key_Type'(Key (Position))))
do
@@ -927,7 +929,7 @@ package body Ada.Containers.Ordered_Sets is
Control =>
(Controlled with
Tree.TC'Unrestricted_Access,
- Container => Container'Access,
+ Container => Container'Unchecked_Access,
Pos => Find (Container, Key),
Old_Key => new Key_Type'(Key)))
do
@@ -1641,13 +1643,13 @@ package body Ada.Containers.Ordered_Sets is
Element_Keys.Find (Container.Tree, New_Item);
begin
+ TE_Check (Container.Tree.TC);
+
if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace element not in set";
end if;
- TE_Check (Container.Tree.TC);
-
Node.Element := New_Item;
end Replace;
diff --git a/gcc/ada/libgnat/a-coorse.ads b/gcc/ada/libgnat/a-coorse.ads
index 5586e4c..42e5b49 100644
--- a/gcc/ada/libgnat/a-coorse.ads
+++ b/gcc/ada/libgnat/a-coorse.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -44,7 +44,9 @@ generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
-package Ada.Containers.Ordered_Sets is
+package Ada.Containers.Ordered_Sets with
+ SPARK_Mode => Off
+is
pragma Annotate (CodePeer, Skip_Analysis);
pragma Preelaborate;
pragma Remote_Types;
diff --git a/gcc/ada/libgnat/a-coprnu.adb b/gcc/ada/libgnat/a-coprnu.adb
index 891cd59..25f04e6 100644
--- a/gcc/ada/libgnat/a-coprnu.adb
+++ b/gcc/ada/libgnat/a-coprnu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-coprnu.ads b/gcc/ada/libgnat/a-coprnu.ads
index c944f8c..5afb474 100644
--- a/gcc/ada/libgnat/a-coprnu.ads
+++ b/gcc/ada/libgnat/a-coprnu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-crbltr.ads b/gcc/ada/libgnat/a-crbltr.ads
index ecc1dca..0ae2abd 100644
--- a/gcc/ada/libgnat/a-crbltr.ads
+++ b/gcc/ada/libgnat/a-crbltr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-crbtgk.adb b/gcc/ada/libgnat/a-crbtgk.adb
index be78f03..a41fcbb 100644
--- a/gcc/ada/libgnat/a-crbtgk.adb
+++ b/gcc/ada/libgnat/a-crbtgk.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -422,12 +422,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
Z : out Node_Access)
is
begin
+ TC_Check (Tree.TC);
+
if Checks and then Tree.Length = Count_Type'Last then
raise Constraint_Error with "too many elements";
end if;
- TC_Check (Tree.TC);
-
Z := New_Node;
pragma Assert (Z /= null);
pragma Assert (Ops.Color (Z) = Red);
diff --git a/gcc/ada/libgnat/a-crbtgk.ads b/gcc/ada/libgnat/a-crbtgk.ads
index 0077758..4bdcf5c 100644
--- a/gcc/ada/libgnat/a-crbtgk.ads
+++ b/gcc/ada/libgnat/a-crbtgk.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-crbtgo.adb b/gcc/ada/libgnat/a-crbtgo.adb
index cf125f1..35727b0 100644
--- a/gcc/ada/libgnat/a-crbtgo.adb
+++ b/gcc/ada/libgnat/a-crbtgo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -693,12 +693,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
procedure Generic_Move (Target, Source : in out Tree_Type) is
begin
+ TC_Check (Source.TC);
+
if Target'Address = Source'Address then
return;
end if;
- TC_Check (Source.TC);
-
Clear (Target);
Target := Source;
diff --git a/gcc/ada/libgnat/a-crbtgo.ads b/gcc/ada/libgnat/a-crbtgo.ads
index a46f787..5f37221 100644
--- a/gcc/ada/libgnat/a-crbtgo.ads
+++ b/gcc/ada/libgnat/a-crbtgo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-crdlli.adb b/gcc/ada/libgnat/a-crdlli.adb
index f69c5d8..fb92fd4 100644
--- a/gcc/ada/libgnat/a-crdlli.adb
+++ b/gcc/ada/libgnat/a-crdlli.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-crdlli.ads b/gcc/ada/libgnat/a-crdlli.ads
index d4ad46e..7f27497 100644
--- a/gcc/ada/libgnat/a-crdlli.ads
+++ b/gcc/ada/libgnat/a-crdlli.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-csquin.ads b/gcc/ada/libgnat/a-csquin.ads
index 68d20c8..df65ba4 100644
--- a/gcc/ada/libgnat/a-csquin.ads
+++ b/gcc/ada/libgnat/a-csquin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-cuprqu.adb b/gcc/ada/libgnat/a-cuprqu.adb
index 843c9a9..deae9a7 100644
--- a/gcc/ada/libgnat/a-cuprqu.adb
+++ b/gcc/ada/libgnat/a-cuprqu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-cuprqu.ads b/gcc/ada/libgnat/a-cuprqu.ads
index 81ae16b..a70e5e0 100644
--- a/gcc/ada/libgnat/a-cuprqu.ads
+++ b/gcc/ada/libgnat/a-cuprqu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-cusyqu.adb b/gcc/ada/libgnat/a-cusyqu.adb
index c92ca5e..295711c 100644
--- a/gcc/ada/libgnat/a-cusyqu.adb
+++ b/gcc/ada/libgnat/a-cusyqu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-cusyqu.ads b/gcc/ada/libgnat/a-cusyqu.ads
index 28995c2..cd2af82 100644
--- a/gcc/ada/libgnat/a-cusyqu.ads
+++ b/gcc/ada/libgnat/a-cusyqu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-cwila1.ads b/gcc/ada/libgnat/a-cwila1.ads
index fdf9188..fc28f17 100644
--- a/gcc/ada/libgnat/a-cwila1.ads
+++ b/gcc/ada/libgnat/a-cwila1.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-cwila9.ads b/gcc/ada/libgnat/a-cwila9.ads
index 2016590a..8f44c5b 100644
--- a/gcc/ada/libgnat/a-cwila9.ads
+++ b/gcc/ada/libgnat/a-cwila9.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-decima.adb b/gcc/ada/libgnat/a-decima.adb
index afa9a0d..bf05516 100644
--- a/gcc/ada/libgnat/a-decima.adb
+++ b/gcc/ada/libgnat/a-decima.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-decima.ads b/gcc/ada/libgnat/a-decima.ads
index 07986ce..9b56cc6 100644
--- a/gcc/ada/libgnat/a-decima.ads
+++ b/gcc/ada/libgnat/a-decima.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-dhfina.adb b/gcc/ada/libgnat/a-dhfina.adb
index df7c345..e0ae41fe 100644
--- a/gcc/ada/libgnat/a-dhfina.adb
+++ b/gcc/ada/libgnat/a-dhfina.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-dhfina.ads b/gcc/ada/libgnat/a-dhfina.ads
index fe32d01..cf8697e 100644
--- a/gcc/ada/libgnat/a-dhfina.ads
+++ b/gcc/ada/libgnat/a-dhfina.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-diocst.adb b/gcc/ada/libgnat/a-diocst.adb
index 5f4bf9f..83dc30a 100644
--- a/gcc/ada/libgnat/a-diocst.adb
+++ b/gcc/ada/libgnat/a-diocst.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-diocst.ads b/gcc/ada/libgnat/a-diocst.ads
index eabade9..a6507c1 100644
--- a/gcc/ada/libgnat/a-diocst.ads
+++ b/gcc/ada/libgnat/a-diocst.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-direct.adb b/gcc/ada/libgnat/a-direct.adb
index 1a1b708..b70bf0e 100644
--- a/gcc/ada/libgnat/a-direct.adb
+++ b/gcc/ada/libgnat/a-direct.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-direct.ads b/gcc/ada/libgnat/a-direct.ads
index d36a024..05cb2b6 100644
--- a/gcc/ada/libgnat/a-direct.ads
+++ b/gcc/ada/libgnat/a-direct.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived for use with GNAT from AI-00248, which is --
-- expected to be a part of a future expected revised Ada Reference Manual. --
diff --git a/gcc/ada/libgnat/a-direio.adb b/gcc/ada/libgnat/a-direio.adb
index a144841..48e4f74 100644
--- a/gcc/ada/libgnat/a-direio.adb
+++ b/gcc/ada/libgnat/a-direio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-direio.ads b/gcc/ada/libgnat/a-direio.ads
index 5cf8bff..a293156 100644
--- a/gcc/ada/libgnat/a-direio.ads
+++ b/gcc/ada/libgnat/a-direio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-dirval.adb b/gcc/ada/libgnat/a-dirval.adb
index cd7e96e..38e56c9 100644
--- a/gcc/ada/libgnat/a-dirval.adb
+++ b/gcc/ada/libgnat/a-dirval.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- (POSIX Version) --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-dirval.ads b/gcc/ada/libgnat/a-dirval.ads
index bf67640..0485802 100644
--- a/gcc/ada/libgnat/a-dirval.ads
+++ b/gcc/ada/libgnat/a-dirval.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-dirval__mingw.adb b/gcc/ada/libgnat/a-dirval__mingw.adb
index 4ab9908..27d09ef 100644
--- a/gcc/ada/libgnat/a-dirval__mingw.adb
+++ b/gcc/ada/libgnat/a-dirval__mingw.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- (Windows Version) --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-einuoc.adb b/gcc/ada/libgnat/a-einuoc.adb
index 77d6b8d..bc9211a 100644
--- a/gcc/ada/libgnat/a-einuoc.adb
+++ b/gcc/ada/libgnat/a-einuoc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-einuoc.ads b/gcc/ada/libgnat/a-einuoc.ads
index c78d511..5d1e264 100644
--- a/gcc/ada/libgnat/a-einuoc.ads
+++ b/gcc/ada/libgnat/a-einuoc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-elchha.adb b/gcc/ada/libgnat/a-elchha.adb
index 96f4112..244352d 100644
--- a/gcc/ada/libgnat/a-elchha.adb
+++ b/gcc/ada/libgnat/a-elchha.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-elchha.ads b/gcc/ada/libgnat/a-elchha.ads
index d4352be..5aa7fe2 100644
--- a/gcc/ada/libgnat/a-elchha.ads
+++ b/gcc/ada/libgnat/a-elchha.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-elchha__vxworks-ppc-full.adb b/gcc/ada/libgnat/a-elchha__vxworks-ppc-full.adb
index d184743..25097d6 100644
--- a/gcc/ada/libgnat/a-elchha__vxworks-ppc-full.adb
+++ b/gcc/ada/libgnat/a-elchha__vxworks-ppc-full.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-envvar.adb b/gcc/ada/libgnat/a-envvar.adb
index 09b1af5..0d6e2ed 100644
--- a/gcc/ada/libgnat/a-envvar.adb
+++ b/gcc/ada/libgnat/a-envvar.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-excach.adb b/gcc/ada/libgnat/a-excach.adb
index 84ee98d..f9d6ee0 100644
--- a/gcc/ada/libgnat/a-excach.adb
+++ b/gcc/ada/libgnat/a-excach.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-except.adb b/gcc/ada/libgnat/a-except.adb
index 8b0a31c..17f3db6 100644
--- a/gcc/ada/libgnat/a-except.adb
+++ b/gcc/ada/libgnat/a-except.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1660,10 +1660,10 @@ package body Ada.Exceptions is
---------------
procedure To_Stderr (C : Character) is
- procedure Put_Char_Stderr (C : Character);
+ procedure Put_Char_Stderr (C : Integer);
pragma Import (C, Put_Char_Stderr, "put_char_stderr");
begin
- Put_Char_Stderr (C);
+ Put_Char_Stderr (Character'Pos (C));
end To_Stderr;
procedure To_Stderr (S : String) is
diff --git a/gcc/ada/libgnat/a-except.ads b/gcc/ada/libgnat/a-except.ads
index 4f70769..85bb5bd 100644
--- a/gcc/ada/libgnat/a-except.ads
+++ b/gcc/ada/libgnat/a-except.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-excpol.adb b/gcc/ada/libgnat/a-excpol.adb
index 058dbad..27893c3 100644
--- a/gcc/ada/libgnat/a-excpol.adb
+++ b/gcc/ada/libgnat/a-excpol.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- (dummy version where polling is not used) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-excpol__abort.adb b/gcc/ada/libgnat/a-excpol__abort.adb
index 733abcc..511f58c 100644
--- a/gcc/ada/libgnat/a-excpol__abort.adb
+++ b/gcc/ada/libgnat/a-excpol__abort.adb
@@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-exctra.adb b/gcc/ada/libgnat/a-exctra.adb
index 164e6fd..450af8b 100644
--- a/gcc/ada/libgnat/a-exctra.adb
+++ b/gcc/ada/libgnat/a-exctra.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-exctra.ads b/gcc/ada/libgnat/a-exctra.ads
index 6033a2d..ba90f52 100644
--- a/gcc/ada/libgnat/a-exctra.ads
+++ b/gcc/ada/libgnat/a-exctra.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-exexda.adb b/gcc/ada/libgnat/a-exexda.adb
index 1f0fb11..31831b6 100644
--- a/gcc/ada/libgnat/a-exexda.adb
+++ b/gcc/ada/libgnat/a-exexda.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-exexpr.adb b/gcc/ada/libgnat/a-exexpr.adb
index 5e72fd6..fb4b545 100644
--- a/gcc/ada/libgnat/a-exexpr.adb
+++ b/gcc/ada/libgnat/a-exexpr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-exextr.adb b/gcc/ada/libgnat/a-exextr.adb
index 6a32b51..da66873 100644
--- a/gcc/ada/libgnat/a-exextr.adb
+++ b/gcc/ada/libgnat/a-exextr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -43,12 +43,23 @@ package body Exception_Traces is
-- Convenient shortcut
type Exception_Action is access procedure (E : Exception_Occurrence);
+ pragma Favor_Top_Level (Exception_Action);
+
Global_Action : Exception_Action := null;
+ pragma Atomic (Global_Action);
pragma Export
(Ada, Global_Action, "__gnat_exception_actions_global_action");
-- Global action, executed whenever an exception is raised. Changing the
-- export name must be coordinated with code in g-excact.adb.
+ Global_Unhandled_Action : Exception_Action := null;
+ pragma Atomic (Global_Unhandled_Action);
+ pragma Export
+ (Ada, Global_Unhandled_Action,
+ "__gnat_exception_actions_global_unhandled_action");
+ -- Global action, executed whenever an unhandled exception is raised.
+ -- Changing the export name must be coordinated with code in g-excact.adb.
+
Raise_Hook_Initialized : Boolean := False;
pragma Export
(Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized");
@@ -77,6 +88,11 @@ package body Exception_Traces is
----------------------
procedure Notify_Exception (Excep : EOA; Is_Unhandled : Boolean) is
+ -- Save actions locally to avoid any race condition that would
+ -- reset them to null.
+ Action : constant Exception_Action := Global_Action;
+ Unhandled_Action : constant Exception_Action := Global_Unhandled_Action;
+
begin
-- Output the exception information required by the Exception_Trace
-- configuration. Take care not to output information about internal
@@ -119,8 +135,12 @@ package body Exception_Traces is
To_Action (Exception_Data_Ptr (Excep.Id).Raise_Hook) (Excep.all);
end if;
- if Global_Action /= null then
- Global_Action (Excep.all);
+ if Is_Unhandled and Unhandled_Action /= null then
+ Unhandled_Action (Excep.all);
+ end if;
+
+ if Action /= null then
+ Action (Excep.all);
end if;
end Notify_Exception;
diff --git a/gcc/ada/libgnat/a-exstat.adb b/gcc/ada/libgnat/a-exstat.adb
index e15ff51..028be1f 100644
--- a/gcc/ada/libgnat/a-exstat.adb
+++ b/gcc/ada/libgnat/a-exstat.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-finali.adb b/gcc/ada/libgnat/a-finali.adb
index b742b27..ba8b7b3 100644
--- a/gcc/ada/libgnat/a-finali.adb
+++ b/gcc/ada/libgnat/a-finali.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-finali.ads b/gcc/ada/libgnat/a-finali.ads
index 4ff5281..2ee4cf8 100644
--- a/gcc/ada/libgnat/a-finali.ads
+++ b/gcc/ada/libgnat/a-finali.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-locale.adb b/gcc/ada/libgnat/a-locale.adb
index aa700dc..ec65938 100644
--- a/gcc/ada/libgnat/a-locale.adb
+++ b/gcc/ada/libgnat/a-locale.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-locale.ads b/gcc/ada/libgnat/a-locale.ads
index 418c41e..be6b0c2 100644
--- a/gcc/ada/libgnat/a-locale.ads
+++ b/gcc/ada/libgnat/a-locale.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
diff --git a/gcc/ada/libgnat/a-nbnbin.adb b/gcc/ada/libgnat/a-nbnbin.adb
index 7d8311d..b919d86 100644
--- a/gcc/ada/libgnat/a-nbnbin.adb
+++ b/gcc/ada/libgnat/a-nbnbin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,20 +30,48 @@
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
-with Ada.Characters.Conversions; use Ada.Characters.Conversions;
+with Ada.Strings.Text_Output.Utils;
with Interfaces; use Interfaces;
with System.Generic_Bignums;
+with System.Shared_Bignums; use System.Shared_Bignums;
package body Ada.Numerics.Big_Numbers.Big_Integers is
- package Bignums is new
- System.Generic_Bignums (Use_Secondary_Stack => False);
- use Bignums, System;
+ function Allocate_Bignum (D : Digit_Vector; Neg : Boolean) return Bignum;
+ -- Allocate Bignum value with the given contents
+
+ procedure Free_Bignum (X : in out Bignum);
+ -- Free memory associated with X
+
+ function To_Bignum (X : aliased in out Bignum) return Bignum is (X);
procedure Free is new Ada.Unchecked_Deallocation (Bignum_Data, Bignum);
+ ---------------------
+ -- Allocate_Bignum --
+ ---------------------
+
+ function Allocate_Bignum (D : Digit_Vector; Neg : Boolean) return Bignum is
+ begin
+ return new Bignum_Data'(D'Length, Neg, D);
+ end Allocate_Bignum;
+
+ -----------------
+ -- Free_Bignum --
+ -----------------
+
+ procedure Free_Bignum (X : in out Bignum) is
+ begin
+ Free (X);
+ end Free_Bignum;
+
+ package Bignums is new System.Generic_Bignums
+ (Bignum, Allocate_Bignum, Free_Bignum, To_Bignum);
+
+ use Bignums, System;
+
function Get_Bignum (Arg : Big_Integer) return Bignum is
(if Arg.Value.C = System.Null_Address
then raise Constraint_Error with "invalid big integer"
@@ -75,7 +103,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "=" --
---------
- function "=" (L, R : Big_Integer) return Boolean is
+ function "=" (L, R : Valid_Big_Integer) return Boolean is
begin
return Big_EQ (Get_Bignum (L), Get_Bignum (R));
end "=";
@@ -84,7 +112,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "<" --
---------
- function "<" (L, R : Big_Integer) return Boolean is
+ function "<" (L, R : Valid_Big_Integer) return Boolean is
begin
return Big_LT (Get_Bignum (L), Get_Bignum (R));
end "<";
@@ -93,7 +121,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "<=" --
----------
- function "<=" (L, R : Big_Integer) return Boolean is
+ function "<=" (L, R : Valid_Big_Integer) return Boolean is
begin
return Big_LE (Get_Bignum (L), Get_Bignum (R));
end "<=";
@@ -102,7 +130,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- ">" --
---------
- function ">" (L, R : Big_Integer) return Boolean is
+ function ">" (L, R : Valid_Big_Integer) return Boolean is
begin
return Big_GT (Get_Bignum (L), Get_Bignum (R));
end ">";
@@ -111,7 +139,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- ">=" --
----------
- function ">=" (L, R : Big_Integer) return Boolean is
+ function ">=" (L, R : Valid_Big_Integer) return Boolean is
begin
return Big_GE (Get_Bignum (L), Get_Bignum (R));
end ">=";
@@ -120,7 +148,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- To_Big_Integer --
--------------------
- function To_Big_Integer (Arg : Integer) return Big_Integer is
+ function To_Big_Integer (Arg : Integer) return Valid_Big_Integer is
Result : Big_Integer;
begin
Set_Bignum (Result, To_Bignum (Long_Long_Integer (Arg)));
@@ -131,7 +159,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- To_Integer --
----------------
- function To_Integer (Arg : Big_Integer) return Integer is
+ function To_Integer (Arg : Valid_Big_Integer) return Integer is
begin
return Integer (From_Bignum (Get_Bignum (Arg)));
end To_Integer;
@@ -146,7 +174,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- To_Big_Integer --
--------------------
- function To_Big_Integer (Arg : Int) return Big_Integer is
+ function To_Big_Integer (Arg : Int) return Valid_Big_Integer is
Result : Big_Integer;
begin
Set_Bignum (Result, To_Bignum (Long_Long_Integer (Arg)));
@@ -157,7 +185,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- From_Big_Integer --
----------------------
- function From_Big_Integer (Arg : Big_Integer) return Int is
+ function From_Big_Integer (Arg : Valid_Big_Integer) return Int is
begin
return Int (From_Bignum (Get_Bignum (Arg)));
end From_Big_Integer;
@@ -174,7 +202,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- To_Big_Integer --
--------------------
- function To_Big_Integer (Arg : Int) return Big_Integer is
+ function To_Big_Integer (Arg : Int) return Valid_Big_Integer is
Result : Big_Integer;
begin
Set_Bignum (Result, To_Bignum (Unsigned_64 (Arg)));
@@ -185,7 +213,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- From_Big_Integer --
----------------------
- function From_Big_Integer (Arg : Big_Integer) return Int is
+ function From_Big_Integer (Arg : Valid_Big_Integer) return Int is
begin
return Int (From_Bignum (Get_Bignum (Arg)));
end From_Big_Integer;
@@ -196,82 +224,11 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- To_String --
---------------
- Hex_Chars : constant array (0 .. 15) of Character := "0123456789ABCDEF";
-
function To_String
- (Arg : Big_Integer; Width : Field := 0; Base : Number_Base := 10)
- return String
- is
- Big_Base : constant Big_Integer := To_Big_Integer (Integer (Base));
-
- function Add_Base (S : String) return String;
- -- Add base information if Base /= 10
-
- function Leading_Padding
- (Str : String;
- Min_Length : Field;
- Char : Character := ' ') return String;
- -- Return padding of Char concatenated with Str so that the resulting
- -- string is at least Min_Length long.
-
- function Image (Arg : Big_Integer) return String;
- -- Return image of Arg, assuming Arg is positive.
-
- function Image (N : Natural) return String;
- -- Return image of N, with no leading space.
-
- --------------
- -- Add_Base --
- --------------
-
- function Add_Base (S : String) return String is
- begin
- if Base = 10 then
- return S;
- else
- return Image (Base) & "#" & S & "#";
- end if;
- end Add_Base;
-
- -----------
- -- Image --
- -----------
-
- function Image (N : Natural) return String is
- S : constant String := Natural'Image (N);
- begin
- return S (2 .. S'Last);
- end Image;
-
- function Image (Arg : Big_Integer) return String is
- begin
- if Arg < Big_Base then
- return (1 => Hex_Chars (To_Integer (Arg)));
- else
- return Image (Arg / Big_Base)
- & Hex_Chars (To_Integer (Arg rem Big_Base));
- end if;
- end Image;
-
- ---------------------
- -- Leading_Padding --
- ---------------------
-
- function Leading_Padding
- (Str : String;
- Min_Length : Field;
- Char : Character := ' ') return String is
- begin
- return (1 .. Integer'Max (Integer (Min_Length) - Str'Length, 0)
- => Char) & Str;
- end Leading_Padding;
-
+ (Arg : Valid_Big_Integer; Width : Field := 0; Base : Number_Base := 10)
+ return String is
begin
- if Arg < To_Big_Integer (0) then
- return Leading_Padding ("-" & Add_Base (Image (-Arg)), Width);
- else
- return Leading_Padding (" " & Add_Base (Image (Arg)), Width);
- end if;
+ return To_String (Get_Bignum (Arg), Natural (Width), Positive (Base));
end To_String;
-----------------
@@ -290,18 +247,19 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- Put_Image --
---------------
- procedure Put_Image
- (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
- Arg : Big_Integer) is
+ procedure Put_Image (S : in out Sink'Class; V : Big_Integer) is
+ -- This is implemented in terms of To_String. It might be more elegant
+ -- and more efficient to do it the other way around, but this is the
+ -- most expedient implementation for now.
begin
- Wide_Wide_String'Write (Stream, To_Wide_Wide_String (To_String (Arg)));
+ Strings.Text_Output.Utils.Put_UTF_8 (S, To_String (V));
end Put_Image;
---------
-- "+" --
---------
- function "+" (L : Big_Integer) return Big_Integer is
+ function "+" (L : Valid_Big_Integer) return Valid_Big_Integer is
Result : Big_Integer;
begin
Set_Bignum (Result, new Bignum_Data'(Get_Bignum (L).all));
@@ -312,7 +270,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "-" --
---------
- function "-" (L : Big_Integer) return Big_Integer is
+ function "-" (L : Valid_Big_Integer) return Valid_Big_Integer is
Result : Big_Integer;
begin
Set_Bignum (Result, Big_Neg (Get_Bignum (L)));
@@ -323,7 +281,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "abs" --
-----------
- function "abs" (L : Big_Integer) return Big_Integer is
+ function "abs" (L : Valid_Big_Integer) return Valid_Big_Integer is
Result : Big_Integer;
begin
Set_Bignum (Result, Big_Abs (Get_Bignum (L)));
@@ -334,7 +292,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "+" --
---------
- function "+" (L, R : Big_Integer) return Big_Integer is
+ function "+" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
Result : Big_Integer;
begin
Set_Bignum (Result, Big_Add (Get_Bignum (L), Get_Bignum (R)));
@@ -345,7 +303,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "-" --
---------
- function "-" (L, R : Big_Integer) return Big_Integer is
+ function "-" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
Result : Big_Integer;
begin
Set_Bignum (Result, Big_Sub (Get_Bignum (L), Get_Bignum (R)));
@@ -356,7 +314,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "*" --
---------
- function "*" (L, R : Big_Integer) return Big_Integer is
+ function "*" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
Result : Big_Integer;
begin
Set_Bignum (Result, Big_Mul (Get_Bignum (L), Get_Bignum (R)));
@@ -367,7 +325,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "/" --
---------
- function "/" (L, R : Big_Integer) return Big_Integer is
+ function "/" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
Result : Big_Integer;
begin
Set_Bignum (Result, Big_Div (Get_Bignum (L), Get_Bignum (R)));
@@ -378,7 +336,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "mod" --
-----------
- function "mod" (L, R : Big_Integer) return Big_Integer is
+ function "mod" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
Result : Big_Integer;
begin
Set_Bignum (Result, Big_Mod (Get_Bignum (L), Get_Bignum (R)));
@@ -389,7 +347,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "rem" --
-----------
- function "rem" (L, R : Big_Integer) return Big_Integer is
+ function "rem" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
Result : Big_Integer;
begin
Set_Bignum (Result, Big_Rem (Get_Bignum (L), Get_Bignum (R)));
@@ -400,16 +358,9 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "**" --
----------
- function "**" (L : Big_Integer; R : Natural) return Big_Integer is
+ function "**"
+ (L : Valid_Big_Integer; R : Natural) return Valid_Big_Integer is
begin
- -- Explicitly check for validity before allocating Exp so that
- -- the call to Get_Bignum below cannot raise an exception before
- -- we get a chance to free Exp.
-
- if not Is_Valid (L) then
- raise Constraint_Error with "invalid big integer";
- end if;
-
declare
Exp : Bignum := To_Bignum (Long_Long_Integer (R));
Result : Big_Integer;
@@ -424,21 +375,23 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- Min --
---------
- function Min (L, R : Big_Integer) return Big_Integer is
+ function Min (L, R : Valid_Big_Integer) return Valid_Big_Integer is
(if L < R then L else R);
---------
-- Max --
---------
- function Max (L, R : Big_Integer) return Big_Integer is
+ function Max (L, R : Valid_Big_Integer) return Valid_Big_Integer is
(if L > R then L else R);
-----------------------------
-- Greatest_Common_Divisor --
-----------------------------
- function Greatest_Common_Divisor (L, R : Big_Integer) return Big_Positive is
+ function Greatest_Common_Divisor
+ (L, R : Valid_Big_Integer) return Big_Positive
+ is
function GCD (A, B : Big_Integer) return Big_Integer;
-- Recursive internal version
diff --git a/gcc/ada/libgnat/a-nbnbin.ads b/gcc/ada/libgnat/a-nbnbin.ads
index a54b09f..7b4974a 100644
--- a/gcc/ada/libgnat/a-nbnbin.ads
+++ b/gcc/ada/libgnat/a-nbnbin.ads
@@ -13,121 +13,153 @@
-- --
------------------------------------------------------------------------------
-with Ada.Finalization;
-with Ada.Streams;
+with Ada.Strings.Text_Output; use Ada.Strings.Text_Output;
+private with Ada.Finalization;
private with System;
--- Note that some Ada 2020 aspects are commented out since they are not
--- supported yet.
-
package Ada.Numerics.Big_Numbers.Big_Integers
with Preelaborate
--- Nonblocking
is
- type Big_Integer is private;
- -- with Integer_Literal => From_String,
- -- Put_Image => Put_Image;
+ type Big_Integer is private
+ with Integer_Literal => From_String,
+ Put_Image => Put_Image;
function Is_Valid (Arg : Big_Integer) return Boolean
- with Convention => Intrinsic;
+ with
+ Convention => Intrinsic,
+ Global => null;
+
+ subtype Valid_Big_Integer is Big_Integer
+ with Dynamic_Predicate => Is_Valid (Valid_Big_Integer),
+ Predicate_Failure => raise Program_Error;
- function "=" (L, R : Big_Integer) return Boolean;
+ function "=" (L, R : Valid_Big_Integer) return Boolean with Global => null;
- function "<" (L, R : Big_Integer) return Boolean;
+ function "<" (L, R : Valid_Big_Integer) return Boolean with Global => null;
- function "<=" (L, R : Big_Integer) return Boolean;
+ function "<=" (L, R : Valid_Big_Integer) return Boolean with Global => null;
- function ">" (L, R : Big_Integer) return Boolean;
+ function ">" (L, R : Valid_Big_Integer) return Boolean with Global => null;
- function ">=" (L, R : Big_Integer) return Boolean;
+ function ">=" (L, R : Valid_Big_Integer) return Boolean with Global => null;
- function To_Big_Integer (Arg : Integer) return Big_Integer;
+ function To_Big_Integer (Arg : Integer) return Valid_Big_Integer
+ with Global => null;
subtype Big_Positive is Big_Integer
- with Dynamic_Predicate => Big_Positive > To_Big_Integer (0),
+ with Dynamic_Predicate =>
+ (if Is_Valid (Big_Positive)
+ then Big_Positive > To_Big_Integer (0)),
Predicate_Failure => (raise Constraint_Error);
subtype Big_Natural is Big_Integer
- with Dynamic_Predicate => Big_Natural >= To_Big_Integer (0),
+ with Dynamic_Predicate =>
+ (if Is_Valid (Big_Natural)
+ then Big_Natural >= To_Big_Integer (0)),
Predicate_Failure => (raise Constraint_Error);
- function In_Range (Arg, Low, High : Big_Integer) return Boolean is
- ((Low <= Arg) and (Arg <= High));
+ function In_Range
+ (Arg : Valid_Big_Integer; Low, High : Big_Integer) return Boolean
+ is (Low <= Arg and Arg <= High)
+ with
+ Global => null;
- function To_Integer (Arg : Big_Integer) return Integer
- with Pre => In_Range (Arg,
- Low => To_Big_Integer (Integer'First),
- High => To_Big_Integer (Integer'Last))
- or else (raise Constraint_Error);
+ function To_Integer (Arg : Valid_Big_Integer) return Integer
+ with
+ Pre => In_Range (Arg,
+ Low => To_Big_Integer (Integer'First),
+ High => To_Big_Integer (Integer'Last))
+ or else (raise Constraint_Error),
+ Global => null;
generic
type Int is range <>;
package Signed_Conversions is
- function To_Big_Integer (Arg : Int) return Big_Integer;
-
- function From_Big_Integer (Arg : Big_Integer) return Int
- with Pre => In_Range (Arg,
- Low => To_Big_Integer (Int'First),
- High => To_Big_Integer (Int'Last))
- or else (raise Constraint_Error);
+ function To_Big_Integer (Arg : Int) return Valid_Big_Integer
+ with Global => null;
+ function From_Big_Integer (Arg : Valid_Big_Integer) return Int
+ with
+ Pre => In_Range (Arg,
+ Low => To_Big_Integer (Int'First),
+ High => To_Big_Integer (Int'Last))
+ or else (raise Constraint_Error),
+ Global => null;
end Signed_Conversions;
generic
type Int is mod <>;
package Unsigned_Conversions is
- function To_Big_Integer (Arg : Int) return Big_Integer;
+ function To_Big_Integer (Arg : Int) return Valid_Big_Integer
+ with Global => null;
- function From_Big_Integer (Arg : Big_Integer) return Int
- with Pre => In_Range (Arg,
- Low => To_Big_Integer (Int'First),
- High => To_Big_Integer (Int'Last))
- or else (raise Constraint_Error);
+ function From_Big_Integer (Arg : Valid_Big_Integer) return Int
+ with
+ Pre => In_Range (Arg,
+ Low => To_Big_Integer (Int'First),
+ High => To_Big_Integer (Int'Last))
+ or else (raise Constraint_Error),
+ Global => null;
end Unsigned_Conversions;
- function To_String (Arg : Big_Integer;
+ function To_String (Arg : Valid_Big_Integer;
Width : Field := 0;
Base : Number_Base := 10) return String
- with Post => To_String'Result'First = 1;
+ with
+ Post => To_String'Result'First = 1,
+ Global => null;
- function From_String (Arg : String) return Big_Integer;
+ function From_String (Arg : String) return Big_Integer
+ with Global => null;
- procedure Put_Image
- (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
- Arg : Big_Integer);
+ procedure Put_Image (S : in out Sink'Class; V : Big_Integer);
- function "+" (L : Big_Integer) return Big_Integer;
+ function "+" (L : Valid_Big_Integer) return Valid_Big_Integer
+ with Global => null;
- function "-" (L : Big_Integer) return Big_Integer;
+ function "-" (L : Valid_Big_Integer) return Valid_Big_Integer
+ with Global => null;
- function "abs" (L : Big_Integer) return Big_Integer;
+ function "abs" (L : Valid_Big_Integer) return Valid_Big_Integer
+ with Global => null;
- function "+" (L, R : Big_Integer) return Big_Integer;
+ function "+" (L, R : Valid_Big_Integer) return Valid_Big_Integer
+ with Global => null;
- function "-" (L, R : Big_Integer) return Big_Integer;
+ function "-" (L, R : Valid_Big_Integer) return Valid_Big_Integer
+ with Global => null;
- function "*" (L, R : Big_Integer) return Big_Integer;
+ function "*" (L, R : Valid_Big_Integer) return Valid_Big_Integer
+ with Global => null;
- function "/" (L, R : Big_Integer) return Big_Integer;
+ function "/" (L, R : Valid_Big_Integer) return Valid_Big_Integer
+ with Global => null;
- function "mod" (L, R : Big_Integer) return Big_Integer;
+ function "mod" (L, R : Valid_Big_Integer) return Valid_Big_Integer
+ with Global => null;
- function "rem" (L, R : Big_Integer) return Big_Integer;
+ function "rem" (L, R : Valid_Big_Integer) return Valid_Big_Integer
+ with Global => null;
- function "**" (L : Big_Integer; R : Natural) return Big_Integer;
+ function "**" (L : Valid_Big_Integer; R : Natural) return Valid_Big_Integer
+ with Global => null;
- function Min (L, R : Big_Integer) return Big_Integer;
+ function Min (L, R : Valid_Big_Integer) return Valid_Big_Integer
+ with Global => null;
- function Max (L, R : Big_Integer) return Big_Integer;
+ function Max (L, R : Valid_Big_Integer) return Valid_Big_Integer
+ with Global => null;
function Greatest_Common_Divisor
- (L, R : Big_Integer) return Big_Positive
- with Pre => (L /= To_Big_Integer (0) and R /= To_Big_Integer (0))
- or else (raise Constraint_Error);
+ (L, R : Valid_Big_Integer) return Big_Positive
+ with
+ Pre => (L /= To_Big_Integer (0) and R /= To_Big_Integer (0))
+ or else (raise Constraint_Error),
+ Global => null;
private
diff --git a/gcc/ada/libgnat/a-nbnbin__gmp.adb b/gcc/ada/libgnat/a-nbnbin__gmp.adb
index 041dfe2..2e8a260 100644
--- a/gcc/ada/libgnat/a-nbnbin__gmp.adb
+++ b/gcc/ada/libgnat/a-nbnbin__gmp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -35,7 +35,7 @@ with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Interfaces.C; use Interfaces.C;
with Interfaces.C.Strings; use Interfaces.C.Strings;
-with Ada.Characters.Conversions; use Ada.Characters.Conversions;
+with Ada.Strings.Text_Output.Utils;
with Ada.Characters.Handling; use Ada.Characters.Handling;
package body Ada.Numerics.Big_Numbers.Big_Integers is
@@ -56,16 +56,16 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
function To_Address is new
Ada.Unchecked_Conversion (mpz_t_ptr, System.Address);
- function Get_Mpz (Arg : Optional_Big_Integer) return mpz_t_ptr is
+ function Get_Mpz (Arg : Big_Integer) return mpz_t_ptr is
(To_Mpz (Arg.Value.C));
-- Return the mpz_t value stored in Arg
- procedure Set_Mpz (Arg : in out Optional_Big_Integer; Value : mpz_t_ptr)
+ procedure Set_Mpz (Arg : in out Big_Integer; Value : mpz_t_ptr)
with Inline;
-- Set the mpz_t value stored in Arg to Value
- procedure Allocate (This : in out Optional_Big_Integer) with Inline;
- -- Allocate an Optional_Big_Integer, including the underlying mpz
+ procedure Allocate (This : in out Big_Integer) with Inline;
+ -- Allocate a Big_Integer, including the underlying mpz
procedure mpz_init_set (ROP : access mpz_t; OP : access constant mpz_t);
pragma Import (C, mpz_init_set, "__gmpz_init_set");
@@ -102,7 +102,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- Set_Mpz --
-------------
- procedure Set_Mpz (Arg : in out Optional_Big_Integer; Value : mpz_t_ptr) is
+ procedure Set_Mpz (Arg : in out Big_Integer; Value : mpz_t_ptr) is
begin
Arg.Value.C := To_Address (Value);
end Set_Mpz;
@@ -111,21 +111,14 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- Is_Valid --
--------------
- function Is_Valid (Arg : Optional_Big_Integer) return Boolean is
+ function Is_Valid (Arg : Big_Integer) return Boolean is
(Arg.Value.C /= System.Null_Address);
- --------------------------
- -- Invalid_Big_Integer --
- --------------------------
-
- function Invalid_Big_Integer return Optional_Big_Integer is
- (Value => (Ada.Finalization.Controlled with C => System.Null_Address));
-
---------
-- "=" --
---------
- function "=" (L, R : Big_Integer) return Boolean is
+ function "=" (L, R : Valid_Big_Integer) return Boolean is
begin
return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) = 0;
end "=";
@@ -134,7 +127,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "<" --
---------
- function "<" (L, R : Big_Integer) return Boolean is
+ function "<" (L, R : Valid_Big_Integer) return Boolean is
begin
return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) < 0;
end "<";
@@ -143,7 +136,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "<=" --
----------
- function "<=" (L, R : Big_Integer) return Boolean is
+ function "<=" (L, R : Valid_Big_Integer) return Boolean is
begin
return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) <= 0;
end "<=";
@@ -152,7 +145,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- ">" --
---------
- function ">" (L, R : Big_Integer) return Boolean is
+ function ">" (L, R : Valid_Big_Integer) return Boolean is
begin
return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) > 0;
end ">";
@@ -161,7 +154,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- ">=" --
----------
- function ">=" (L, R : Big_Integer) return Boolean is
+ function ">=" (L, R : Valid_Big_Integer) return Boolean is
begin
return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) >= 0;
end ">=";
@@ -170,8 +163,8 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- To_Big_Integer --
--------------------
- function To_Big_Integer (Arg : Integer) return Big_Integer is
- Result : Optional_Big_Integer;
+ function To_Big_Integer (Arg : Integer) return Valid_Big_Integer is
+ Result : Big_Integer;
begin
Allocate (Result);
mpz_set_si (Get_Mpz (Result), long (Arg));
@@ -182,7 +175,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- To_Integer --
----------------
- function To_Integer (Arg : Big_Integer) return Integer is
+ function To_Integer (Arg : Valid_Big_Integer) return Integer is
begin
return Integer (mpz_get_si (Get_Mpz (Arg)));
end To_Integer;
@@ -197,8 +190,8 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- To_Big_Integer --
--------------------
- function To_Big_Integer (Arg : Int) return Big_Integer is
- Result : Optional_Big_Integer;
+ function To_Big_Integer (Arg : Int) return Valid_Big_Integer is
+ Result : Big_Integer;
begin
Allocate (Result);
mpz_set_si (Get_Mpz (Result), long (Arg));
@@ -209,7 +202,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- From_Big_Integer --
----------------------
- function From_Big_Integer (Arg : Big_Integer) return Int is
+ function From_Big_Integer (Arg : Valid_Big_Integer) return Int is
begin
return Int (mpz_get_si (Get_Mpz (Arg)));
end From_Big_Integer;
@@ -226,8 +219,8 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- To_Big_Integer --
--------------------
- function To_Big_Integer (Arg : Int) return Big_Integer is
- Result : Optional_Big_Integer;
+ function To_Big_Integer (Arg : Int) return Valid_Big_Integer is
+ Result : Big_Integer;
begin
Allocate (Result);
mpz_set_ui (Get_Mpz (Result), unsigned_long (Arg));
@@ -238,7 +231,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- From_Big_Integer --
----------------------
- function From_Big_Integer (Arg : Big_Integer) return Int is
+ function From_Big_Integer (Arg : Valid_Big_Integer) return Int is
begin
return Int (mpz_get_ui (Get_Mpz (Arg)));
end From_Big_Integer;
@@ -250,7 +243,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
---------------
function To_String
- (Arg : Big_Integer; Width : Field := 0; Base : Number_Base := 10)
+ (Arg : Valid_Big_Integer; Width : Field := 0; Base : Number_Base := 10)
return String
is
function mpz_get_str
@@ -342,7 +335,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
base : Integer := 10) return Integer;
pragma Import (C, mpz_set_str, "__gmpz_set_str");
- Result : Optional_Big_Integer;
+ Result : Big_Integer;
First : Natural;
Last : Natural;
Base : Natural;
@@ -410,19 +403,20 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- Put_Image --
---------------
- procedure Put_Image
- (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
- Arg : Big_Integer) is
+ procedure Put_Image (S : in out Sink'Class; V : Big_Integer) is
+ -- This is implemented in terms of To_String. It might be more elegant
+ -- and more efficient to do it the other way around, but this is the
+ -- most expedient implementation for now.
begin
- Wide_Wide_String'Write (Stream, To_Wide_Wide_String (To_String (Arg)));
+ Strings.Text_Output.Utils.Put_UTF_8 (S, To_String (V));
end Put_Image;
---------
-- "+" --
---------
- function "+" (L : Big_Integer) return Big_Integer is
- Result : Optional_Big_Integer;
+ function "+" (L : Valid_Big_Integer) return Valid_Big_Integer is
+ Result : Big_Integer;
begin
Set_Mpz (Result, new mpz_t);
mpz_init_set (Get_Mpz (Result), Get_Mpz (L));
@@ -433,8 +427,8 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "-" --
---------
- function "-" (L : Big_Integer) return Big_Integer is
- Result : Optional_Big_Integer;
+ function "-" (L : Valid_Big_Integer) return Valid_Big_Integer is
+ Result : Big_Integer;
begin
Allocate (Result);
mpz_neg (Get_Mpz (Result), Get_Mpz (L));
@@ -445,11 +439,11 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "abs" --
-----------
- function "abs" (L : Big_Integer) return Big_Integer is
+ function "abs" (L : Valid_Big_Integer) return Valid_Big_Integer is
procedure mpz_abs (ROP : access mpz_t; OP : access constant mpz_t);
pragma Import (C, mpz_abs, "__gmpz_abs");
- Result : Optional_Big_Integer;
+ Result : Big_Integer;
begin
Allocate (Result);
mpz_abs (Get_Mpz (Result), Get_Mpz (L));
@@ -460,12 +454,12 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "+" --
---------
- function "+" (L, R : Big_Integer) return Big_Integer is
+ function "+" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
procedure mpz_add
(ROP : access mpz_t; OP1, OP2 : access constant mpz_t);
pragma Import (C, mpz_add, "__gmpz_add");
- Result : Optional_Big_Integer;
+ Result : Big_Integer;
begin
Allocate (Result);
@@ -477,8 +471,8 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "-" --
---------
- function "-" (L, R : Big_Integer) return Big_Integer is
- Result : Optional_Big_Integer;
+ function "-" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
+ Result : Big_Integer;
begin
Allocate (Result);
mpz_sub (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R));
@@ -489,12 +483,12 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "*" --
---------
- function "*" (L, R : Big_Integer) return Big_Integer is
+ function "*" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
procedure mpz_mul
(ROP : access mpz_t; OP1, OP2 : access constant mpz_t);
pragma Import (C, mpz_mul, "__gmpz_mul");
- Result : Optional_Big_Integer;
+ Result : Big_Integer;
begin
Allocate (Result);
@@ -506,7 +500,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "/" --
---------
- function "/" (L, R : Big_Integer) return Big_Integer is
+ function "/" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
procedure mpz_tdiv_q (Q : access mpz_t; N, D : access constant mpz_t);
pragma Import (C, mpz_tdiv_q, "__gmpz_tdiv_q");
begin
@@ -515,7 +509,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
end if;
declare
- Result : Optional_Big_Integer;
+ Result : Big_Integer;
begin
Allocate (Result);
mpz_tdiv_q (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R));
@@ -527,7 +521,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "mod" --
-----------
- function "mod" (L, R : Big_Integer) return Big_Integer is
+ function "mod" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
procedure mpz_mod (R : access mpz_t; N, D : access constant mpz_t);
pragma Import (C, mpz_mod, "__gmpz_mod");
-- result is always non-negative
@@ -540,7 +534,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
end if;
declare
- Result : Optional_Big_Integer;
+ Result : Big_Integer;
begin
Allocate (Result);
L_Negative := mpz_cmp_ui (Get_Mpz (L), 0) < 0;
@@ -609,7 +603,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "rem" --
-----------
- function "rem" (L, R : Big_Integer) return Big_Integer is
+ function "rem" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
procedure mpz_tdiv_r (R : access mpz_t; N, D : access constant mpz_t);
pragma Import (C, mpz_tdiv_r, "__gmpz_tdiv_r");
-- R will have the same sign as N.
@@ -620,7 +614,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
end if;
declare
- Result : Optional_Big_Integer;
+ Result : Big_Integer;
begin
Allocate (Result);
mpz_tdiv_r (R => Get_Mpz (Result),
@@ -636,13 +630,15 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- "**" --
----------
- function "**" (L : Big_Integer; R : Natural) return Big_Integer is
+ function "**"
+ (L : Valid_Big_Integer; R : Natural) return Valid_Big_Integer
+ is
procedure mpz_pow_ui (ROP : access mpz_t;
BASE : access constant mpz_t;
EXP : unsigned_long);
pragma Import (C, mpz_pow_ui, "__gmpz_pow_ui");
- Result : Optional_Big_Integer;
+ Result : Big_Integer;
begin
Allocate (Result);
@@ -654,26 +650,28 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- Min --
---------
- function Min (L, R : Big_Integer) return Big_Integer is
+ function Min (L, R : Valid_Big_Integer) return Valid_Big_Integer is
(if L < R then L else R);
---------
-- Max --
---------
- function Max (L, R : Big_Integer) return Big_Integer is
+ function Max (L, R : Valid_Big_Integer) return Valid_Big_Integer is
(if L > R then L else R);
-----------------------------
-- Greatest_Common_Divisor --
-----------------------------
- function Greatest_Common_Divisor (L, R : Big_Integer) return Big_Integer is
+ function Greatest_Common_Divisor
+ (L, R : Valid_Big_Integer) return Big_Positive
+ is
procedure mpz_gcd
(ROP : access mpz_t; Op1, Op2 : access constant mpz_t);
pragma Import (C, mpz_gcd, "__gmpz_gcd");
- Result : Optional_Big_Integer;
+ Result : Big_Integer;
begin
Allocate (Result);
@@ -685,7 +683,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- Allocate --
--------------
- procedure Allocate (This : in out Optional_Big_Integer) is
+ procedure Allocate (This : in out Big_Integer) is
procedure mpz_init (this : access mpz_t);
pragma Import (C, mpz_init, "__gmpz_init");
begin
diff --git a/gcc/ada/libgnat/a-nbnbre.adb b/gcc/ada/libgnat/a-nbnbre.adb
index c087f49..d61668d 100644
--- a/gcc/ada/libgnat/a-nbnbre.adb
+++ b/gcc/ada/libgnat/a-nbnbre.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,7 +31,7 @@
-- This is the default version of this package, based on Big_Integers only.
-with Ada.Characters.Conversions; use Ada.Characters.Conversions;
+with Ada.Strings.Text_Output.Utils;
package body Ada.Numerics.Big_Numbers.Big_Reals is
@@ -46,13 +46,13 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
--------------
function Is_Valid (Arg : Big_Real) return Boolean is
- (Is_Valid (Arg.Num) and then Is_Valid (Arg.Den));
+ (Is_Valid (Arg.Num) and Is_Valid (Arg.Den));
---------
-- "/" --
---------
- function "/" (Num, Den : Big_Integer) return Big_Real is
+ function "/" (Num, Den : Valid_Big_Integer) return Valid_Big_Real is
Result : Big_Real;
begin
if Den = To_Big_Integer (0) then
@@ -69,45 +69,47 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
-- Numerator --
---------------
- function Numerator (Arg : Big_Real) return Big_Integer is (Arg.Num);
+ function Numerator (Arg : Valid_Big_Real) return Valid_Big_Integer is
+ (Arg.Num);
-----------------
-- Denominator --
-----------------
- function Denominator (Arg : Big_Real) return Big_Positive is (Arg.Den);
+ function Denominator (Arg : Valid_Big_Real) return Big_Positive is
+ (Arg.Den);
---------
-- "=" --
---------
- function "=" (L, R : Big_Real) return Boolean is
+ function "=" (L, R : Valid_Big_Real) return Boolean is
(abs L.Num = abs R.Num and then L.Den = R.Den);
---------
-- "<" --
---------
- function "<" (L, R : Big_Real) return Boolean is
+ function "<" (L, R : Valid_Big_Real) return Boolean is
(abs L.Num * R.Den < abs R.Num * L.Den);
----------
-- "<=" --
----------
- function "<=" (L, R : Big_Real) return Boolean is (not (R < L));
+ function "<=" (L, R : Valid_Big_Real) return Boolean is (not (R < L));
---------
-- ">" --
---------
- function ">" (L, R : Big_Real) return Boolean is (R < L);
+ function ">" (L, R : Valid_Big_Real) return Boolean is (R < L);
----------
-- ">=" --
----------
- function ">=" (L, R : Big_Real) return Boolean is (not (L < R));
+ function ">=" (L, R : Valid_Big_Real) return Boolean is (not (L < R));
-----------------------
-- Float_Conversions --
@@ -119,7 +121,7 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
-- To_Big_Real --
-----------------
- function To_Big_Real (Arg : Num) return Big_Real is
+ function To_Big_Real (Arg : Num) return Valid_Big_Real is
begin
return From_String (Arg'Image);
end To_Big_Real;
@@ -145,7 +147,7 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
-- To_Big_Real --
-----------------
- function To_Big_Real (Arg : Num) return Big_Real is
+ function To_Big_Real (Arg : Num) return Valid_Big_Real is
begin
return From_String (Arg'Image);
end To_Big_Real;
@@ -166,8 +168,10 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
---------------
function To_String
- (Arg : Big_Real; Fore : Field := 2; Aft : Field := 3; Exp : Field := 0)
- return String
+ (Arg : Valid_Big_Real;
+ Fore : Field := 2;
+ Aft : Field := 3;
+ Exp : Field := 0) return String
is
Zero : constant Big_Integer := To_Big_Integer (0);
Ten : constant Big_Integer := To_Big_Integer (10);
@@ -373,7 +377,7 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
-- From_Quotient_String --
--------------------------
- function From_Quotient_String (Arg : String) return Big_Real is
+ function From_Quotient_String (Arg : String) return Valid_Big_Real is
Index : Natural := 0;
begin
for J in Arg'First + 1 .. Arg'Last - 1 loop
@@ -395,18 +399,19 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
-- Put_Image --
---------------
- procedure Put_Image
- (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
- Arg : Big_Real) is
+ procedure Put_Image (S : in out Sink'Class; V : Big_Real) is
+ -- This is implemented in terms of To_String. It might be more elegant
+ -- and more efficient to do it the other way around, but this is the
+ -- most expedient implementation for now.
begin
- Wide_Wide_String'Write (Stream, To_Wide_Wide_String (To_String (Arg)));
+ Strings.Text_Output.Utils.Put_UTF_8 (S, To_String (V));
end Put_Image;
---------
-- "+" --
---------
- function "+" (L : Big_Real) return Big_Real is
+ function "+" (L : Valid_Big_Real) return Valid_Big_Real is
Result : Big_Real;
begin
Result.Num := L.Num;
@@ -418,21 +423,21 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
-- "-" --
---------
- function "-" (L : Big_Real) return Big_Real is
+ function "-" (L : Valid_Big_Real) return Valid_Big_Real is
(Num => -L.Num, Den => L.Den);
-----------
-- "abs" --
-----------
- function "abs" (L : Big_Real) return Big_Real is
+ function "abs" (L : Valid_Big_Real) return Valid_Big_Real is
(Num => abs L.Num, Den => L.Den);
---------
-- "+" --
---------
- function "+" (L, R : Big_Real) return Big_Real is
+ function "+" (L, R : Valid_Big_Real) return Valid_Big_Real is
Result : Big_Real;
begin
Result.Num := L.Num * R.Den + R.Num * L.Den;
@@ -445,7 +450,7 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
-- "-" --
---------
- function "-" (L, R : Big_Real) return Big_Real is
+ function "-" (L, R : Valid_Big_Real) return Valid_Big_Real is
Result : Big_Real;
begin
Result.Num := L.Num * R.Den - R.Num * L.Den;
@@ -458,7 +463,7 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
-- "*" --
---------
- function "*" (L, R : Big_Real) return Big_Real is
+ function "*" (L, R : Valid_Big_Real) return Valid_Big_Real is
Result : Big_Real;
begin
Result.Num := L.Num * R.Num;
@@ -471,7 +476,7 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
-- "/" --
---------
- function "/" (L, R : Big_Real) return Big_Real is
+ function "/" (L, R : Valid_Big_Real) return Valid_Big_Real is
Result : Big_Real;
begin
Result.Num := L.Num * R.Den;
@@ -484,7 +489,7 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
-- "**" --
----------
- function "**" (L : Big_Real; R : Integer) return Big_Real is
+ function "**" (L : Valid_Big_Real; R : Integer) return Valid_Big_Real is
Result : Big_Real;
begin
if R = 0 then
@@ -509,32 +514,39 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
-- Min --
---------
- function Min (L, R : Big_Real) return Big_Real is (if L < R then L else R);
+ function Min (L, R : Valid_Big_Real) return Valid_Big_Real is
+ (if L < R then L else R);
---------
-- Max --
---------
- function Max (L, R : Big_Real) return Big_Real is (if L > R then L else R);
+ function Max (L, R : Valid_Big_Real) return Valid_Big_Real is
+ (if L > R then L else R);
---------------
-- Normalize --
---------------
procedure Normalize (Arg : in out Big_Real) is
+ Zero : constant Big_Integer := To_Big_Integer (0);
begin
- if Arg.Den < To_Big_Integer (0) then
+ if Arg.Den < Zero then
Arg.Num := -Arg.Num;
Arg.Den := -Arg.Den;
end if;
- declare
- GCD : constant Big_Integer :=
- Greatest_Common_Divisor (Arg.Num, Arg.Den);
- begin
- Arg.Num := Arg.Num / GCD;
- Arg.Den := Arg.Den / GCD;
- end;
+ if Arg.Num = Zero then
+ Arg.Den := To_Big_Integer (1);
+ else
+ declare
+ GCD : constant Big_Integer :=
+ Greatest_Common_Divisor (Arg.Num, Arg.Den);
+ begin
+ Arg.Num := Arg.Num / GCD;
+ Arg.Den := Arg.Den / GCD;
+ end;
+ end if;
end Normalize;
end Ada.Numerics.Big_Numbers.Big_Reals;
diff --git a/gcc/ada/libgnat/a-nbnbre.ads b/gcc/ada/libgnat/a-nbnbre.ads
index 4827caa..5a8ebb9 100644
--- a/gcc/ada/libgnat/a-nbnbre.ads
+++ b/gcc/ada/libgnat/a-nbnbre.ads
@@ -14,66 +14,84 @@
------------------------------------------------------------------------------
with Ada.Numerics.Big_Numbers.Big_Integers;
-with Ada.Streams;
--- Note that some Ada 2020 aspects are commented out since they are not
--- supported yet.
+with Ada.Strings.Text_Output; use Ada.Strings.Text_Output;
package Ada.Numerics.Big_Numbers.Big_Reals
with Preelaborate
--- Nonblocking, Global => in out synchronized Big_Reals
is
- type Big_Real is private;
--- with Real_Literal => From_String,
--- Put_Image => Put_Image;
-
- function Is_Valid (Arg : Big_Real) return Boolean;
-
- function "/" (Num, Den : Big_Integers.Big_Integer) return Big_Real;
--- with Pre => (if Big_Integers."=" (Den, Big_Integers.To_Big_Integer (0))
--- then raise Constraint_Error);
-
- function Numerator (Arg : Big_Real) return Big_Integers.Big_Integer;
-
- function Denominator (Arg : Big_Real) return Big_Integers.Big_Positive
- with Post =>
- (Arg = To_Real (0)) or else
- (Big_Integers."="
- (Big_Integers.Greatest_Common_Divisor
- (Numerator (Arg), Denominator'Result),
- Big_Integers.To_Big_Integer (1)));
+ type Big_Real is private with
+ Real_Literal => From_String,
+ Put_Image => Put_Image;
+
+ function Is_Valid (Arg : Big_Real) return Boolean
+ with
+ Convention => Intrinsic,
+ Global => null;
+
+ subtype Valid_Big_Real is Big_Real
+ with Dynamic_Predicate => Is_Valid (Valid_Big_Real),
+ Predicate_Failure => raise Program_Error;
+
+ function "/"
+ (Num, Den : Big_Integers.Valid_Big_Integer) return Valid_Big_Real
+ with Global => null;
+-- with Pre => (Big_Integers."/=" (Den, Big_Integers.To_Big_Integer (0))
+-- or else Constraint_Error);
+
+ function Numerator
+ (Arg : Valid_Big_Real) return Big_Integers.Valid_Big_Integer
+ with Global => null;
+
+ function Denominator (Arg : Valid_Big_Real) return Big_Integers.Big_Positive
+ with
+ Post =>
+ (if Arg = To_Real (0)
+ then Big_Integers."=" (Denominator'Result,
+ Big_Integers.To_Big_Integer (1))
+ else Big_Integers."="
+ (Big_Integers.Greatest_Common_Divisor
+ (Numerator (Arg), Denominator'Result),
+ Big_Integers.To_Big_Integer (1))),
+ Global => null;
function To_Big_Real
(Arg : Big_Integers.Big_Integer)
- return Big_Real is (Arg / Big_Integers.To_Big_Integer (1));
+ return Valid_Big_Real is (Arg / Big_Integers.To_Big_Integer (1))
+ with Global => null;
- function To_Real (Arg : Integer) return Big_Real is
- (Big_Integers.To_Big_Integer (Arg) / Big_Integers.To_Big_Integer (1));
+ function To_Real (Arg : Integer) return Valid_Big_Real is
+ (Big_Integers.To_Big_Integer (Arg) / Big_Integers.To_Big_Integer (1))
+ with Global => null;
- function "=" (L, R : Big_Real) return Boolean;
+ function "=" (L, R : Valid_Big_Real) return Boolean with Global => null;
- function "<" (L, R : Big_Real) return Boolean;
+ function "<" (L, R : Valid_Big_Real) return Boolean with Global => null;
- function "<=" (L, R : Big_Real) return Boolean;
+ function "<=" (L, R : Valid_Big_Real) return Boolean with Global => null;
- function ">" (L, R : Big_Real) return Boolean;
+ function ">" (L, R : Valid_Big_Real) return Boolean with Global => null;
- function ">=" (L, R : Big_Real) return Boolean;
+ function ">=" (L, R : Valid_Big_Real) return Boolean with Global => null;
function In_Range (Arg, Low, High : Big_Real) return Boolean is
- (Low <= Arg and then Arg <= High);
+ (Low <= Arg and then Arg <= High)
+ with Global => null;
generic
type Num is digits <>;
package Float_Conversions is
- function To_Big_Real (Arg : Num) return Big_Real;
+ function To_Big_Real (Arg : Num) return Valid_Big_Real
+ with Global => null;
function From_Big_Real (Arg : Big_Real) return Num
- with Pre => In_Range (Arg,
- Low => To_Big_Real (Num'First),
- High => To_Big_Real (Num'Last))
- or else (raise Constraint_Error);
+ with
+ Pre => In_Range (Arg,
+ Low => To_Big_Real (Num'First),
+ High => To_Big_Real (Num'Last))
+ or else (raise Constraint_Error),
+ Global => null;
end Float_Conversions;
@@ -81,53 +99,69 @@ is
type Num is delta <>;
package Fixed_Conversions is
- function To_Big_Real (Arg : Num) return Big_Real;
+ function To_Big_Real (Arg : Num) return Valid_Big_Real
+ with Global => null;
function From_Big_Real (Arg : Big_Real) return Num
- with Pre => In_Range (Arg,
- Low => To_Big_Real (Num'First),
- High => To_Big_Real (Num'Last))
- or else (raise Constraint_Error);
+ with
+ Pre => In_Range (Arg,
+ Low => To_Big_Real (Num'First),
+ High => To_Big_Real (Num'Last))
+ or else (raise Constraint_Error),
+ Global => null;
end Fixed_Conversions;
- function To_String (Arg : Big_Real;
+ function To_String (Arg : Valid_Big_Real;
Fore : Field := 2;
Aft : Field := 3;
Exp : Field := 0) return String
- with Post => To_String'Result'First = 1;
+ with
+ Post => To_String'Result'First = 1,
+ Global => null;
- function From_String (Arg : String) return Big_Real;
+ function From_String (Arg : String) return Big_Real
+ with Global => null;
function To_Quotient_String (Arg : Big_Real) return String is
(Big_Integers.To_String (Numerator (Arg)) & " / "
- & Big_Integers.To_String (Denominator (Arg)));
+ & Big_Integers.To_String (Denominator (Arg)))
+ with Global => null;
- function From_Quotient_String (Arg : String) return Big_Real;
+ function From_Quotient_String (Arg : String) return Valid_Big_Real
+ with Global => null;
- procedure Put_Image
- (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
- Arg : Big_Real);
+ procedure Put_Image (S : in out Sink'Class; V : Big_Real);
- function "+" (L : Big_Real) return Big_Real;
+ function "+" (L : Valid_Big_Real) return Valid_Big_Real
+ with Global => null;
- function "-" (L : Big_Real) return Big_Real;
+ function "-" (L : Valid_Big_Real) return Valid_Big_Real
+ with Global => null;
- function "abs" (L : Big_Real) return Big_Real;
+ function "abs" (L : Valid_Big_Real) return Valid_Big_Real
+ with Global => null;
- function "+" (L, R : Big_Real) return Big_Real;
+ function "+" (L, R : Valid_Big_Real) return Valid_Big_Real
+ with Global => null;
- function "-" (L, R : Big_Real) return Big_Real;
+ function "-" (L, R : Valid_Big_Real) return Valid_Big_Real
+ with Global => null;
- function "*" (L, R : Big_Real) return Big_Real;
+ function "*" (L, R : Valid_Big_Real) return Valid_Big_Real
+ with Global => null;
- function "/" (L, R : Big_Real) return Big_Real;
+ function "/" (L, R : Valid_Big_Real) return Valid_Big_Real
+ with Global => null;
- function "**" (L : Big_Real; R : Integer) return Big_Real;
+ function "**" (L : Valid_Big_Real; R : Integer) return Valid_Big_Real
+ with Global => null;
- function Min (L, R : Big_Real) return Big_Real;
+ function Min (L, R : Valid_Big_Real) return Valid_Big_Real
+ with Global => null;
- function Max (L, R : Big_Real) return Big_Real;
+ function Max (L, R : Valid_Big_Real) return Valid_Big_Real
+ with Global => null;
private
diff --git a/gcc/ada/libgnat/a-ngcefu.adb b/gcc/ada/libgnat/a-ngcefu.adb
index 390f42b..46af6f8 100644
--- a/gcc/ada/libgnat/a-ngcefu.adb
+++ b/gcc/ada/libgnat/a-ngcefu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ngcoar.adb b/gcc/ada/libgnat/a-ngcoar.adb
index a464a32..3a7cede 100644
--- a/gcc/ada/libgnat/a-ngcoar.adb
+++ b/gcc/ada/libgnat/a-ngcoar.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2006-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ngcoty.adb b/gcc/ada/libgnat/a-ngcoty.adb
index bece703..6785ccf 100644
--- a/gcc/ada/libgnat/a-ngcoty.adb
+++ b/gcc/ada/libgnat/a-ngcoty.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -66,11 +66,19 @@ package body Ada.Numerics.Generic_Complex_Types is
-- return false, the test can only be written thus.
if not (abs (X) <= R'Last) then
+ pragma Annotate
+ (CodePeer, Intentional,
+ "test always false", "test for infinity");
+
X := Scale**2 * ((Left.Re / Scale) * (Right.Re / Scale) -
(Left.Im / Scale) * (Right.Im / Scale));
end if;
if not (abs (Y) <= R'Last) then
+ pragma Annotate
+ (CodePeer, Intentional,
+ "test always false", "test for infinity");
+
Y := Scale**2 * ((Left.Re / Scale) * (Right.Im / Scale)
+ (Left.Im / Scale) * (Right.Re / Scale));
end if;
@@ -588,6 +596,7 @@ package body Ada.Numerics.Generic_Complex_Types is
exception
when Constraint_Error =>
+ pragma Assert (X.Re /= 0.0);
return R (Double (abs (X.Re))
* Sqrt (1.0 + (Double (X.Im) / Double (X.Re)) ** 2));
end;
@@ -602,6 +611,7 @@ package body Ada.Numerics.Generic_Complex_Types is
exception
when Constraint_Error =>
+ pragma Assert (X.Im /= 0.0);
return R (Double (abs (X.Im))
* Sqrt (1.0 + (Double (X.Re) / Double (X.Im)) ** 2));
end;
diff --git a/gcc/ada/libgnat/a-ngcoty.ads b/gcc/ada/libgnat/a-ngcoty.ads
index f775120..a5534cd 100644
--- a/gcc/ada/libgnat/a-ngcoty.ads
+++ b/gcc/ada/libgnat/a-ngcoty.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-ngelfu.adb b/gcc/ada/libgnat/a-ngelfu.adb
index 71cd47b..7e7c662 100644
--- a/gcc/ada/libgnat/a-ngelfu.adb
+++ b/gcc/ada/libgnat/a-ngelfu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -680,6 +680,8 @@ is
Z := G * G;
P := G * ((P2 * Z + P1) * Z + P0);
Q := ((Q3 * Z + Q2) * Z + Q1) * Z + Q0;
+
+ pragma Assert (Q /= P);
R := 0.5 + P / (Q - P);
R := Float_Type'Base'Scaling (R, Integer (XN) + 1);
diff --git a/gcc/ada/libgnat/a-ngelfu.ads b/gcc/ada/libgnat/a-ngelfu.ads
index cb6137c..1a8e176 100644
--- a/gcc/ada/libgnat/a-ngelfu.ads
+++ b/gcc/ada/libgnat/a-ngelfu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2012-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-ngrear.adb b/gcc/ada/libgnat/a-ngrear.adb
index 8418ec1..1115cd3 100644
--- a/gcc/ada/libgnat/a-ngrear.adb
+++ b/gcc/ada/libgnat/a-ngrear.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2006-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -560,6 +560,8 @@ package body Ada.Numerics.Generic_Real_Arrays is
function Compute_Tan (P, H : Real) return Real is
(if Is_Tiny (P, Compared_To => H) then P / H
else Compute_Tan (Theta => H / (2.0 * P)));
+ pragma Annotate
+ (CodePeer, False_Positive, "divide by zero", "H, P /= 0");
function Sum_Strict_Upper (M : Square_Matrix) return Real;
-- Return the sum of all elements in the strict upper triangle of M
diff --git a/gcc/ada/libgnat/a-ngrear.ads b/gcc/ada/libgnat/a-ngrear.ads
index aa97af5..748d6b7 100644
--- a/gcc/ada/libgnat/a-ngrear.ads
+++ b/gcc/ada/libgnat/a-ngrear.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-nubinu.ads b/gcc/ada/libgnat/a-nubinu.ads
index a25e39c..c2b95d8 100644
--- a/gcc/ada/libgnat/a-nubinu.ads
+++ b/gcc/ada/libgnat/a-nubinu.ads
@@ -13,11 +13,7 @@
-- --
------------------------------------------------------------------------------
--- Note that some Ada 2020 aspects are commented out since they are not
--- supported yet.
-
package Ada.Numerics.Big_Numbers
- -- with Pure, Nonblocking, Global => null
with Pure
is
subtype Field is Integer range 0 .. 255;
diff --git a/gcc/ada/libgnat/a-nudira.adb b/gcc/ada/libgnat/a-nudira.adb
index 23c8e72..e18403c 100644
--- a/gcc/ada/libgnat/a-nudira.adb
+++ b/gcc/ada/libgnat/a-nudira.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -56,6 +56,17 @@ is
return Random (SRN.Generator (Gen));
end Random;
+ function Random
+ (Gen : Generator;
+ First : Result_Subtype;
+ Last : Result_Subtype) return Result_Subtype
+ is
+ subtype Local_Subtype is Result_Subtype range First .. Last;
+ function Random is new SRN.Random_Discrete (Local_Subtype, First);
+ begin
+ return Random (SRN.Generator (Gen));
+ end Random;
+
-----------
-- Reset --
-----------
diff --git a/gcc/ada/libgnat/a-nudira.ads b/gcc/ada/libgnat/a-nudira.ads
index 8a6b6c2..35b7dc6 100644
--- a/gcc/ada/libgnat/a-nudira.ads
+++ b/gcc/ada/libgnat/a-nudira.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -51,6 +51,12 @@ is
function Random (Gen : Generator) return Result_Subtype;
+ function Random
+ (Gen : Generator;
+ First : Result_Subtype;
+ Last : Result_Subtype) return Result_Subtype
+ with Post => Random'Result in First .. Last;
+
procedure Reset (Gen : Generator; Initiator : Integer);
procedure Reset (Gen : Generator);
diff --git a/gcc/ada/libgnat/a-nuflra.adb b/gcc/ada/libgnat/a-nuflra.adb
index 19d202b..8621006 100644
--- a/gcc/ada/libgnat/a-nuflra.adb
+++ b/gcc/ada/libgnat/a-nuflra.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-nuflra.ads b/gcc/ada/libgnat/a-nuflra.ads
index e1f8704..ff7ab88 100644
--- a/gcc/ada/libgnat/a-nuflra.ads
+++ b/gcc/ada/libgnat/a-nuflra.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-numaux.ads b/gcc/ada/libgnat/a-numaux.ads
index 01c5224..3ad7067 100644
--- a/gcc/ada/libgnat/a-numaux.ads
+++ b/gcc/ada/libgnat/a-numaux.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (C Library Version, non-x86) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-numaux__darwin.adb b/gcc/ada/libgnat/a-numaux__darwin.adb
index 0e57128..85fdd24 100644
--- a/gcc/ada/libgnat/a-numaux__darwin.adb
+++ b/gcc/ada/libgnat/a-numaux__darwin.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- (Apple OS X Version) --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-numaux__darwin.ads b/gcc/ada/libgnat/a-numaux__darwin.ads
index a699e85..f2a4428 100644
--- a/gcc/ada/libgnat/a-numaux__darwin.ads
+++ b/gcc/ada/libgnat/a-numaux__darwin.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Apple OS X Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-numaux__dummy.adb b/gcc/ada/libgnat/a-numaux__dummy.adb
new file mode 100644
index 0000000..f5d72ec
--- /dev/null
+++ b/gcc/ada/libgnat/a-numaux__dummy.adb
@@ -0,0 +1,32 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . N U M E R I C S . A U X --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+pragma No_Body;
diff --git a/gcc/ada/libgnat/a-numaux__libc-x86.ads b/gcc/ada/libgnat/a-numaux__libc-x86.ads
index db71671..c4647fd 100644
--- a/gcc/ada/libgnat/a-numaux__libc-x86.ads
+++ b/gcc/ada/libgnat/a-numaux__libc-x86.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (C Library Version for x86) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-numaux__vxworks.ads b/gcc/ada/libgnat/a-numaux__vxworks.ads
index ace578c..c291334 100644
--- a/gcc/ada/libgnat/a-numaux__vxworks.ads
+++ b/gcc/ada/libgnat/a-numaux__vxworks.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (C Library Version, VxWorks) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-numaux__x86.adb b/gcc/ada/libgnat/a-numaux__x86.adb
deleted file mode 100644
index 2a849a6..0000000
--- a/gcc/ada/libgnat/a-numaux__x86.adb
+++ /dev/null
@@ -1,577 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . N U M E R I C S . A U X --
--- --
--- B o d y --
--- (Machine Version for x86) --
--- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with System.Machine_Code; use System.Machine_Code;
-
-package body Ada.Numerics.Aux is
-
- NL : constant String := ASCII.LF & ASCII.HT;
-
- -----------------------
- -- Local subprograms --
- -----------------------
-
- function Is_Nan (X : Double) return Boolean;
- -- Return True iff X is a IEEE NaN value
-
- function Logarithmic_Pow (X, Y : Double) return Double;
- -- Implementation of X**Y using Exp and Log functions (binary base)
- -- to calculate the exponentiation. This is used by Pow for values
- -- for values of Y in the open interval (-0.25, 0.25)
-
- procedure Reduce (X : in out Double; Q : out Natural);
- -- Implement reduction of X by Pi/2. Q is the quadrant of the final
- -- result in the range 0..3. The absolute value of X is at most Pi/4.
- -- It is needed to avoid a loss of accuracy for sin near Pi and cos
- -- near Pi/2 due to the use of an insufficiently precise value of Pi
- -- in the range reduction.
-
- pragma Inline (Is_Nan);
- pragma Inline (Reduce);
-
- --------------------------------
- -- Basic Elementary Functions --
- --------------------------------
-
- -- This section implements a few elementary functions that are used to
- -- build the more complex ones. This ordering enables better inlining.
-
- ----------
- -- Atan --
- ----------
-
- function Atan (X : Double) return Double is
- Result : Double;
-
- begin
- Asm (Template =>
- "fld1" & NL
- & "fpatan",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", X));
-
- -- The result value is NaN iff input was invalid
-
- if not (Result = Result) then
- raise Argument_Error;
- end if;
-
- return Result;
- end Atan;
-
- ---------
- -- Exp --
- ---------
-
- function Exp (X : Double) return Double is
- Result : Double;
- begin
- Asm (Template =>
- "fldl2e " & NL
- & "fmulp %%st, %%st(1)" & NL -- X * log2 (E)
- & "fld %%st(0) " & NL
- & "frndint " & NL -- Integer (X * Log2 (E))
- & "fsubr %%st, %%st(1)" & NL -- Fraction (X * Log2 (E))
- & "fxch " & NL
- & "f2xm1 " & NL -- 2**(...) - 1
- & "fld1 " & NL
- & "faddp %%st, %%st(1)" & NL -- 2**(Fraction (X * Log2 (E)))
- & "fscale " & NL -- E ** X
- & "fstp %%st(1) ",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", X));
- return Result;
- end Exp;
-
- ------------
- -- Is_Nan --
- ------------
-
- function Is_Nan (X : Double) return Boolean is
- begin
- -- The IEEE NaN values are the only ones that do not equal themselves
-
- return X /= X;
- end Is_Nan;
-
- ---------
- -- Log --
- ---------
-
- function Log (X : Double) return Double is
- Result : Double;
-
- begin
- Asm (Template =>
- "fldln2 " & NL
- & "fxch " & NL
- & "fyl2x " & NL,
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", X));
- return Result;
- end Log;
-
- ------------
- -- Reduce --
- ------------
-
- procedure Reduce (X : in out Double; Q : out Natural) is
- Half_Pi : constant := Pi / 2.0;
- Two_Over_Pi : constant := 2.0 / Pi;
-
- HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size);
- M : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant
- P1 : constant Double := Double'Leading_Part (Half_Pi, HM);
- P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM);
- P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM);
- P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM);
- P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3
- - P4, HM);
- P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5);
- K : Double;
- R : Integer;
-
- begin
- -- For X < 2.0**HM, all products below are computed exactly.
- -- Due to cancellation effects all subtractions are exact as well.
- -- As no double extended floating-point number has more than 75
- -- zeros after the binary point, the result will be the correctly
- -- rounded result of X - K * (Pi / 2.0).
-
- K := X * Two_Over_Pi;
- while abs K >= 2.0**HM loop
- K := K * M - (K * M - K);
- X :=
- (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6;
- K := X * Two_Over_Pi;
- end loop;
-
- -- If K is not a number (because X was not finite) raise exception
-
- if Is_Nan (K) then
- raise Constraint_Error;
- end if;
-
- -- Go through an integer temporary so as to use machine instructions
-
- R := Integer (Double'Rounding (K));
- Q := R mod 4;
- K := Double (R);
- X := (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6;
- end Reduce;
-
- ----------
- -- Sqrt --
- ----------
-
- function Sqrt (X : Double) return Double is
- Result : Double;
-
- begin
- if X < 0.0 then
- raise Argument_Error;
- end if;
-
- Asm (Template => "fsqrt",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", X));
-
- return Result;
- end Sqrt;
-
- --------------------------------
- -- Other Elementary Functions --
- --------------------------------
-
- -- These are built using the previously implemented basic functions
-
- ----------
- -- Acos --
- ----------
-
- function Acos (X : Double) return Double is
- Result : Double;
-
- begin
- Result := 2.0 * Atan (Sqrt ((1.0 - X) / (1.0 + X)));
-
- -- The result value is NaN iff input was invalid
-
- if Is_Nan (Result) then
- raise Argument_Error;
- end if;
-
- return Result;
- end Acos;
-
- ----------
- -- Asin --
- ----------
-
- function Asin (X : Double) return Double is
- Result : Double;
-
- begin
- Result := Atan (X / Sqrt ((1.0 - X) * (1.0 + X)));
-
- -- The result value is NaN iff input was invalid
-
- if Is_Nan (Result) then
- raise Argument_Error;
- end if;
-
- return Result;
- end Asin;
-
- ---------
- -- Cos --
- ---------
-
- function Cos (X : Double) return Double is
- Reduced_X : Double := abs X;
- Result : Double;
- Quadrant : Natural range 0 .. 3;
-
- begin
- if Reduced_X > Pi / 4.0 then
- Reduce (Reduced_X, Quadrant);
-
- case Quadrant is
- when 0 =>
- Asm (Template => "fcos",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
-
- when 1 =>
- Asm (Template => "fsin",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", -Reduced_X));
-
- when 2 =>
- Asm (Template => "fcos ; fchs",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
-
- when 3 =>
- Asm (Template => "fsin",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
- end case;
-
- else
- Asm (Template => "fcos",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
- end if;
-
- return Result;
- end Cos;
-
- ---------------------
- -- Logarithmic_Pow --
- ---------------------
-
- function Logarithmic_Pow (X, Y : Double) return Double is
- Result : Double;
- begin
- Asm (Template => "" -- X : Y
- & "fyl2x " & NL -- Y * Log2 (X)
- & "fld %%st(0) " & NL -- Y * Log2 (X) : Y * Log2 (X)
- & "frndint " & NL -- Int (...) : Y * Log2 (X)
- & "fsubr %%st, %%st(1)" & NL -- Int (...) : Fract (...)
- & "fxch " & NL -- Fract (...) : Int (...)
- & "f2xm1 " & NL -- 2**Fract (...) - 1 : Int (...)
- & "fld1 " & NL -- 1 : 2**Fract (...) - 1 : Int (...)
- & "faddp %%st, %%st(1)" & NL -- 2**Fract (...) : Int (...)
- & "fscale ", -- 2**(Fract (...) + Int (...))
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs =>
- (Double'Asm_Input ("0", X),
- Double'Asm_Input ("u", Y)));
- return Result;
- end Logarithmic_Pow;
-
- ---------
- -- Pow --
- ---------
-
- function Pow (X, Y : Double) return Double is
- type Mantissa_Type is mod 2**Double'Machine_Mantissa;
- -- Modular type that can hold all bits of the mantissa of Double
-
- -- For negative exponents, do divide at the end of the processing
-
- Negative_Y : constant Boolean := Y < 0.0;
- Abs_Y : constant Double := abs Y;
-
- -- During this function the following invariant is kept:
- -- X ** (abs Y) = Base**(Exp_High + Exp_Mid + Exp_Low) * Factor
-
- Base : Double := X;
-
- Exp_High : Double := Double'Floor (Abs_Y);
- Exp_Mid : Double;
- Exp_Low : Double;
- Exp_Int : Mantissa_Type;
-
- Factor : Double := 1.0;
-
- begin
- -- Select algorithm for calculating Pow (integer cases fall through)
-
- if Exp_High >= 2.0**Double'Machine_Mantissa then
-
- -- In case of Y that is IEEE infinity, just raise constraint error
-
- if Exp_High > Double'Safe_Last then
- raise Constraint_Error;
- end if;
-
- -- Large values of Y are even integers and will stay integer
- -- after division by two.
-
- loop
- -- Exp_Mid and Exp_Low are zero, so
- -- X**(abs Y) = Base ** Exp_High = (Base**2) ** (Exp_High / 2)
-
- Exp_High := Exp_High / 2.0;
- Base := Base * Base;
- exit when Exp_High < 2.0**Double'Machine_Mantissa;
- end loop;
-
- elsif Exp_High /= Abs_Y then
- Exp_Low := Abs_Y - Exp_High;
- Factor := 1.0;
-
- if Exp_Low /= 0.0 then
-
- -- Exp_Low now is in interval (0.0, 1.0)
- -- Exp_Mid := Double'Floor (Exp_Low * 4.0) / 4.0;
-
- Exp_Mid := 0.0;
- Exp_Low := Exp_Low - Exp_Mid;
-
- if Exp_Low >= 0.5 then
- Factor := Sqrt (X);
- Exp_Low := Exp_Low - 0.5; -- exact
-
- if Exp_Low >= 0.25 then
- Factor := Factor * Sqrt (Factor);
- Exp_Low := Exp_Low - 0.25; -- exact
- end if;
-
- elsif Exp_Low >= 0.25 then
- Factor := Sqrt (Sqrt (X));
- Exp_Low := Exp_Low - 0.25; -- exact
- end if;
-
- -- Exp_Low now is in interval (0.0, 0.25)
-
- -- This means it is safe to call Logarithmic_Pow
- -- for the remaining part.
-
- Factor := Factor * Logarithmic_Pow (X, Exp_Low);
- end if;
-
- elsif X = 0.0 then
- return 0.0;
- end if;
-
- -- Exp_High is non-zero integer smaller than 2**Double'Machine_Mantissa
-
- Exp_Int := Mantissa_Type (Exp_High);
-
- -- Standard way for processing integer powers > 0
-
- while Exp_Int > 1 loop
- if (Exp_Int and 1) = 1 then
-
- -- Base**Y = Base**(Exp_Int - 1) * Exp_Int for Exp_Int > 0
-
- Factor := Factor * Base;
- end if;
-
- -- Exp_Int is even and Exp_Int > 0, so
- -- Base**Y = (Base**2)**(Exp_Int / 2)
-
- Base := Base * Base;
- Exp_Int := Exp_Int / 2;
- end loop;
-
- -- Exp_Int = 1 or Exp_Int = 0
-
- if Exp_Int = 1 then
- Factor := Base * Factor;
- end if;
-
- if Negative_Y then
- Factor := 1.0 / Factor;
- end if;
-
- return Factor;
- end Pow;
-
- ---------
- -- Sin --
- ---------
-
- function Sin (X : Double) return Double is
- Reduced_X : Double := X;
- Result : Double;
- Quadrant : Natural range 0 .. 3;
-
- begin
- if abs X > Pi / 4.0 then
- Reduce (Reduced_X, Quadrant);
-
- case Quadrant is
- when 0 =>
- Asm (Template => "fsin",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
-
- when 1 =>
- Asm (Template => "fcos",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
-
- when 2 =>
- Asm (Template => "fsin",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", -Reduced_X));
-
- when 3 =>
- Asm (Template => "fcos ; fchs",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
- end case;
-
- else
- Asm (Template => "fsin",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
- end if;
-
- return Result;
- end Sin;
-
- ---------
- -- Tan --
- ---------
-
- function Tan (X : Double) return Double is
- Reduced_X : Double := X;
- Result : Double;
- Quadrant : Natural range 0 .. 3;
-
- begin
- if abs X > Pi / 4.0 then
- Reduce (Reduced_X, Quadrant);
-
- if Quadrant mod 2 = 0 then
- Asm (Template => "fptan" & NL
- & "ffree %%st(0)" & NL
- & "fincstp",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
- else
- Asm (Template => "fsincos" & NL
- & "fdivp %%st, %%st(1)" & NL
- & "fchs",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
- end if;
-
- else
- Asm (Template =>
- "fptan " & NL
- & "ffree %%st(0) " & NL
- & "fincstp ",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
- end if;
-
- return Result;
- end Tan;
-
- ----------
- -- Sinh --
- ----------
-
- function Sinh (X : Double) return Double is
- begin
- -- Mathematically Sinh (x) is defined to be (Exp (X) - Exp (-X)) / 2.0
-
- if abs X < 25.0 then
- return (Exp (X) - Exp (-X)) / 2.0;
- else
- return Exp (X) / 2.0;
- end if;
- end Sinh;
-
- ----------
- -- Cosh --
- ----------
-
- function Cosh (X : Double) return Double is
- begin
- -- Mathematically Cosh (X) is defined to be (Exp (X) + Exp (-X)) / 2.0
-
- if abs X < 22.0 then
- return (Exp (X) + Exp (-X)) / 2.0;
- else
- return Exp (X) / 2.0;
- end if;
- end Cosh;
-
- ----------
- -- Tanh --
- ----------
-
- function Tanh (X : Double) return Double is
- begin
- -- Return the Hyperbolic Tangent of x
-
- -- x -x
- -- e - e Sinh (X)
- -- Tanh (X) is defined to be ----------- = --------
- -- x -x Cosh (X)
- -- e + e
-
- if abs X > 23.0 then
- return Double'Copy_Sign (1.0, X);
- end if;
-
- return 1.0 / (1.0 + Exp (-(2.0 * X))) - 1.0 / (1.0 + Exp (2.0 * X));
- end Tanh;
-
-end Ada.Numerics.Aux;
diff --git a/gcc/ada/libgnat/a-rbtgbk.adb b/gcc/ada/libgnat/a-rbtgbk.adb
index d959de5..40a792f 100644
--- a/gcc/ada/libgnat/a-rbtgbk.adb
+++ b/gcc/ada/libgnat/a-rbtgbk.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-rbtgbk.ads b/gcc/ada/libgnat/a-rbtgbk.ads
index 36c4783..22f6c22 100644
--- a/gcc/ada/libgnat/a-rbtgbk.ads
+++ b/gcc/ada/libgnat/a-rbtgbk.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-rbtgbo.adb b/gcc/ada/libgnat/a-rbtgbo.adb
index 679030d..a2775ea 100644
--- a/gcc/ada/libgnat/a-rbtgbo.adb
+++ b/gcc/ada/libgnat/a-rbtgbo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-rbtgbo.ads b/gcc/ada/libgnat/a-rbtgbo.ads
index 73ee0de..968c2f2 100644
--- a/gcc/ada/libgnat/a-rbtgbo.ads
+++ b/gcc/ada/libgnat/a-rbtgbo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-rbtgso.adb b/gcc/ada/libgnat/a-rbtgso.adb
index 5dbee70..fcb254d 100644
--- a/gcc/ada/libgnat/a-rbtgso.adb
+++ b/gcc/ada/libgnat/a-rbtgso.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -94,9 +94,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
Compare : Integer;
begin
- if Target'Address = Source'Address then
- TC_Check (Target.TC);
+ TC_Check (Target.TC);
+ if Target'Address = Source'Address then
Clear (Target);
return;
end if;
@@ -105,8 +105,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
return;
end if;
- TC_Check (Target.TC);
-
Tgt := Target.First;
Src := Source.First;
loop
diff --git a/gcc/ada/libgnat/a-rbtgso.ads b/gcc/ada/libgnat/a-rbtgso.ads
index 5970f45..e6eeb33 100644
--- a/gcc/ada/libgnat/a-rbtgso.ads
+++ b/gcc/ada/libgnat/a-rbtgso.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-sbecin.adb b/gcc/ada/libgnat/a-sbecin.adb
index 4673236..d9bef56 100644
--- a/gcc/ada/libgnat/a-sbecin.adb
+++ b/gcc/ada/libgnat/a-sbecin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-sbecin.ads b/gcc/ada/libgnat/a-sbecin.ads
index 66e682b..9144e9e 100644
--- a/gcc/ada/libgnat/a-sbecin.ads
+++ b/gcc/ada/libgnat/a-sbecin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-sbhcin.adb b/gcc/ada/libgnat/a-sbhcin.adb
index 2efd5d8..5062756 100644
--- a/gcc/ada/libgnat/a-sbhcin.adb
+++ b/gcc/ada/libgnat/a-sbhcin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-sbhcin.ads b/gcc/ada/libgnat/a-sbhcin.ads
index 64de2ca..ec1d97c 100644
--- a/gcc/ada/libgnat/a-sbhcin.ads
+++ b/gcc/ada/libgnat/a-sbhcin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-sblcin.adb b/gcc/ada/libgnat/a-sblcin.adb
index 386a1a0..c21050d 100644
--- a/gcc/ada/libgnat/a-sblcin.adb
+++ b/gcc/ada/libgnat/a-sblcin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-sblcin.ads b/gcc/ada/libgnat/a-sblcin.ads
index f50c6df..8915631 100644
--- a/gcc/ada/libgnat/a-sblcin.ads
+++ b/gcc/ada/libgnat/a-sblcin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-secain.adb b/gcc/ada/libgnat/a-secain.adb
index b06387f..6c042f1 100644
--- a/gcc/ada/libgnat/a-secain.adb
+++ b/gcc/ada/libgnat/a-secain.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-secain.ads b/gcc/ada/libgnat/a-secain.ads
index 4d985e1..3e77231 100644
--- a/gcc/ada/libgnat/a-secain.ads
+++ b/gcc/ada/libgnat/a-secain.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-sequio.adb b/gcc/ada/libgnat/a-sequio.adb
index 9519a87..0b5aa61 100644
--- a/gcc/ada/libgnat/a-sequio.adb
+++ b/gcc/ada/libgnat/a-sequio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -73,7 +73,7 @@ package body Ada.Sequential_IO is
procedure Byte_Swap (Siz : in out size_t) is
use System.Byte_Swapping;
begin
- case Siz'Size is
+ case size_t'Size is
when 32 => Siz := size_t (Bswap_32 (U32 (Siz)));
when 64 => Siz := size_t (Bswap_64 (U64 (Siz)));
when others => raise Program_Error;
diff --git a/gcc/ada/libgnat/a-sequio.ads b/gcc/ada/libgnat/a-sequio.ads
index 4a2e803..dcaa3f0 100644
--- a/gcc/ada/libgnat/a-sequio.ads
+++ b/gcc/ada/libgnat/a-sequio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-sfecin.ads b/gcc/ada/libgnat/a-sfecin.ads
index 0aaf97b..0c1b0a7 100644
--- a/gcc/ada/libgnat/a-sfecin.ads
+++ b/gcc/ada/libgnat/a-sfecin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-sfhcin.ads b/gcc/ada/libgnat/a-sfhcin.ads
index be7e5c2..8da6f43 100644
--- a/gcc/ada/libgnat/a-sfhcin.ads
+++ b/gcc/ada/libgnat/a-sfhcin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-sflcin.ads b/gcc/ada/libgnat/a-sflcin.ads
index a40c3aa..8fb7ac1 100644
--- a/gcc/ada/libgnat/a-sflcin.ads
+++ b/gcc/ada/libgnat/a-sflcin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-shcain.adb b/gcc/ada/libgnat/a-shcain.adb
index 5908614..35a346e 100644
--- a/gcc/ada/libgnat/a-shcain.adb
+++ b/gcc/ada/libgnat/a-shcain.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-shcain.ads b/gcc/ada/libgnat/a-shcain.ads
index efe0e2c..4d2975c 100644
--- a/gcc/ada/libgnat/a-shcain.ads
+++ b/gcc/ada/libgnat/a-shcain.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-siocst.adb b/gcc/ada/libgnat/a-siocst.adb
index a912eee..5501486 100644
--- a/gcc/ada/libgnat/a-siocst.adb
+++ b/gcc/ada/libgnat/a-siocst.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-siocst.ads b/gcc/ada/libgnat/a-siocst.ads
index a4dcfba..3a37f7bb 100644
--- a/gcc/ada/libgnat/a-siocst.ads
+++ b/gcc/ada/libgnat/a-siocst.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-slcain.adb b/gcc/ada/libgnat/a-slcain.adb
index 72c9192..732e103 100644
--- a/gcc/ada/libgnat/a-slcain.adb
+++ b/gcc/ada/libgnat/a-slcain.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-slcain.ads b/gcc/ada/libgnat/a-slcain.ads
index 84ca194..8efa651 100644
--- a/gcc/ada/libgnat/a-slcain.ads
+++ b/gcc/ada/libgnat/a-slcain.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ssicst.adb b/gcc/ada/libgnat/a-ssicst.adb
index 90b48bd..2293136 100644
--- a/gcc/ada/libgnat/a-ssicst.adb
+++ b/gcc/ada/libgnat/a-ssicst.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ssicst.ads b/gcc/ada/libgnat/a-ssicst.ads
index c488536..7cf18cb 100644
--- a/gcc/ada/libgnat/a-ssicst.ads
+++ b/gcc/ada/libgnat/a-ssicst.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stboha.adb b/gcc/ada/libgnat/a-stboha.adb
index adf0330..a960dc3 100644
--- a/gcc/ada/libgnat/a-stboha.adb
+++ b/gcc/ada/libgnat/a-stboha.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stmaco.ads b/gcc/ada/libgnat/a-stmaco.ads
index 3bd60f6..8493bb3 100644
--- a/gcc/ada/libgnat/a-stmaco.ads
+++ b/gcc/ada/libgnat/a-stmaco.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-stobbu.adb b/gcc/ada/libgnat/a-stobbu.adb
new file mode 100644
index 0000000..fba591d
--- /dev/null
+++ b/gcc/ada/libgnat/a-stobbu.adb
@@ -0,0 +1,53 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_OUTPUT.BIT_BUCKETS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body Ada.Strings.Text_Output.Bit_Buckets is
+
+ type Bit_Bucket_Type is new Sink with null record;
+ overriding procedure Full_Method (S : in out Bit_Bucket_Type);
+ overriding procedure Flush_Method (S : in out Bit_Bucket_Type);
+
+ The_Bit_Bucket : aliased Bit_Bucket_Type
+ (Chunk_Length => Default_Chunk_Length);
+ function Bit_Bucket return Sink_Access is (The_Bit_Bucket'Access);
+
+ overriding procedure Full_Method (S : in out Bit_Bucket_Type)
+ renames Flush_Method;
+
+ overriding procedure Flush_Method (S : in out Bit_Bucket_Type) is
+ begin
+ S.Last := 0;
+ end Flush_Method;
+
+begin
+ The_Bit_Bucket.Indent_Amount := 0;
+ The_Bit_Bucket.Cur_Chunk := The_Bit_Bucket.Initial_Chunk'Access;
+end Ada.Strings.Text_Output.Bit_Buckets;
diff --git a/gcc/ada/libgnat/a-stobbu.ads b/gcc/ada/libgnat/a-stobbu.ads
new file mode 100644
index 0000000..027e711
--- /dev/null
+++ b/gcc/ada/libgnat/a-stobbu.ads
@@ -0,0 +1,34 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_OUTPUT.BIT_BUCKETS --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package Ada.Strings.Text_Output.Bit_Buckets is
+ function Bit_Bucket return Sink_Access;
+end Ada.Strings.Text_Output.Bit_Buckets;
diff --git a/gcc/ada/libgnat/a-stobfi.adb b/gcc/ada/libgnat/a-stobfi.adb
new file mode 100644
index 0000000..dd485ba
--- /dev/null
+++ b/gcc/ada/libgnat/a-stobfi.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_OUTPUT.BASIC_FILES --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Text_Output.Utils; use Ada.Strings.Text_Output.Utils;
+package body Ada.Strings.Text_Output.Basic_Files is
+ use type OS.File_Descriptor;
+
+ function Create_From_FD
+ (FD : OS.File_Descriptor;
+ Indent_Amount : Natural;
+ Chunk_Length : Positive) return File;
+ -- Create a file from an OS file descriptor
+
+ function Create_From_FD
+ (FD : OS.File_Descriptor;
+ Indent_Amount : Natural;
+ Chunk_Length : Positive) return File
+ is
+ begin
+ if FD = OS.Invalid_FD then
+ raise Program_Error with OS.Errno_Message;
+ end if;
+ return Result : File (Chunk_Length) do
+ Result.Indent_Amount := Indent_Amount;
+ Result.Cur_Chunk := Result.Initial_Chunk'Unchecked_Access;
+ Result.FD := FD;
+ end return;
+ end Create_From_FD;
+
+ function Create_File
+ (Name : String;
+ Indent_Amount : Natural := Default_Indent_Amount;
+ Chunk_Length : Positive := Default_Chunk_Length) return File
+ is
+ begin
+ return Create_From_FD
+ (OS.Create_File (Name, Fmode => OS.Text),
+ Indent_Amount, Chunk_Length);
+ end Create_File;
+
+ function Create_New_File
+ (Name : String;
+ Indent_Amount : Natural := Default_Indent_Amount;
+ Chunk_Length : Positive := Default_Chunk_Length) return File
+ is
+ begin
+ return Create_From_FD
+ (OS.Create_New_File (Name, Fmode => OS.Text),
+ Indent_Amount, Chunk_Length);
+ end Create_New_File;
+
+ procedure Close (S : in out File'Class) is
+ Status : Boolean;
+ begin
+ Flush (S);
+
+ if S.FD not in OS.Standout | OS.Standerr then -- Don't close these
+ OS.Close (S.FD, Status);
+ if not Status then
+ raise Program_Error with OS.Errno_Message;
+ end if;
+ end if;
+ end Close;
+
+ overriding procedure Full_Method (S : in out File) renames Flush_Method;
+
+ overriding procedure Flush_Method (S : in out File) is
+ pragma Assert (S.Cur_Chunk = S.Initial_Chunk'Unchecked_Access);
+ Res : constant Integer :=
+ OS.Write (S.FD, S.Cur_Chunk.Chars'Address, S.Last);
+ begin
+ if Res /= S.Last then
+ raise Program_Error with OS.Errno_Message;
+ end if;
+ S.Last := 0;
+ end Flush_Method;
+
+ The_Stdout : aliased File :=
+ Create_From_FD (OS.Standout,
+ Indent_Amount => Default_Indent_Amount,
+ Chunk_Length => Default_Chunk_Length);
+ The_Stderr : aliased File :=
+ Create_From_FD (OS.Standerr,
+ Indent_Amount => Default_Indent_Amount,
+ Chunk_Length => Default_Chunk_Length);
+
+ function Standard_Output return Sink_Access is (The_Stdout'Access);
+ function Standard_Error return Sink_Access is (The_Stderr'Access);
+
+end Ada.Strings.Text_Output.Basic_Files;
diff --git a/gcc/ada/libgnat/a-stobfi.ads b/gcc/ada/libgnat/a-stobfi.ads
new file mode 100644
index 0000000..65e8e24
--- /dev/null
+++ b/gcc/ada/libgnat/a-stobfi.ads
@@ -0,0 +1,66 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_OUTPUT.BASIC_FILES --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+private with GNAT.OS_Lib;
+package Ada.Strings.Text_Output.Basic_Files is
+ -- Normally, you should use Ada.Strings.Text_Output.Files, which
+ -- automatically Closes files via finalization. If you don't want to use
+ -- finalization, use this package instead. You must then Close the file by
+ -- hand. The semantics is otherwise the same as Files.
+
+ function Standard_Output return Sink_Access;
+ function Standard_Error return Sink_Access;
+
+ type File (<>) is new Sink with private;
+
+ function Create_File
+ (Name : String;
+ Indent_Amount : Natural := Default_Indent_Amount;
+ Chunk_Length : Positive := Default_Chunk_Length) return File;
+ function Create_New_File
+ (Name : String;
+ Indent_Amount : Natural := Default_Indent_Amount;
+ Chunk_Length : Positive := Default_Chunk_Length) return File;
+
+ procedure Close (S : in out File'Class);
+
+private
+
+ package OS renames GNAT.OS_Lib;
+
+ type File is new Sink with record
+ FD : OS.File_Descriptor := OS.Invalid_FD;
+ end record;
+
+ overriding procedure Full_Method (S : in out File);
+ overriding procedure Flush_Method (S : in out File);
+
+end Ada.Strings.Text_Output.Basic_Files;
diff --git a/gcc/ada/libgnat/a-storio.adb b/gcc/ada/libgnat/a-storio.adb
index 441b6ec..5c68082 100644
--- a/gcc/ada/libgnat/a-storio.adb
+++ b/gcc/ada/libgnat/a-storio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stoubu.adb b/gcc/ada/libgnat/a-stoubu.adb
new file mode 100644
index 0000000..9fb6c5a
--- /dev/null
+++ b/gcc/ada/libgnat/a-stoubu.adb
@@ -0,0 +1,138 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_OUTPUT.BUFFERS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Deallocation;
+with Ada.Strings.UTF_Encoding.Strings;
+with Ada.Strings.UTF_Encoding.Wide_Strings;
+with Ada.Strings.UTF_Encoding.Wide_Wide_Strings;
+package body Ada.Strings.Text_Output.Buffers is
+
+ function New_Buffer
+ (Indent_Amount : Natural := Default_Indent_Amount;
+ Chunk_Length : Positive := Default_Chunk_Length) return Buffer
+ is
+ begin
+ return Result : Buffer (Chunk_Length) do
+ Result.Indent_Amount := Indent_Amount;
+ Result.Cur_Chunk := Result.Initial_Chunk'Unchecked_Access;
+ end return;
+ end New_Buffer;
+
+ procedure Destroy (S : in out Buffer) is
+ procedure Free is new Unchecked_Deallocation (Chunk, Chunk_Access);
+ Cur : Chunk_Access := S.Initial_Chunk.Next;
+ begin
+ while Cur /= null loop
+ declare
+ Temp : constant Chunk_Access := Cur.Next;
+ begin
+ Free (Cur);
+ Cur := Temp;
+ end;
+ end loop;
+
+ S.Cur_Chunk := null;
+ end Destroy;
+
+ overriding procedure Full_Method (S : in out Buffer) is
+ begin
+ pragma Assert (S.Cur_Chunk.Next = null);
+ pragma Assert (S.Last = S.Cur_Chunk.Chars'Length);
+ S.Cur_Chunk.Next := new Chunk (S.Chunk_Length);
+ S.Cur_Chunk := S.Cur_Chunk.Next;
+ S.Num_Extra_Chunks := @ + 1;
+ S.Last := 0;
+ end Full_Method;
+
+ function UTF_8_Length (S : Buffer'Class) return Natural is
+ begin
+ return S.Num_Extra_Chunks * S.Chunk_Length + S.Last;
+ end UTF_8_Length;
+
+ procedure Get_UTF_8
+ (S : Buffer'Class; Result : out UTF_8_Lines)
+ is
+ Cur : access constant Chunk := S.Initial_Chunk'Access;
+ First : Positive := 1;
+ begin
+ loop
+ if Cur.Next = null then
+ pragma Assert (Result'Last = First + S.Last - 1);
+ Result (First .. Result'Last) := Cur.Chars (1 .. S.Last);
+ exit;
+ end if;
+
+ pragma Assert (S.Chunk_Length = Cur.Chars'Length);
+ Result (First .. First + S.Chunk_Length - 1) := Cur.Chars;
+ First := First + S.Chunk_Length;
+ Cur := Cur.Next;
+ end loop;
+ end Get_UTF_8;
+
+ function Get_UTF_8 (S : Buffer'Class) return UTF_8_Lines is
+ begin
+ return Result : String (1 .. UTF_8_Length (S)) do
+ Get_UTF_8 (S, Result);
+ end return;
+ end Get_UTF_8;
+
+ function Get (S : Buffer'Class) return String is
+ begin
+ -- If all characters are 7 bits, we don't need to decode;
+ -- this is an optimization.
+
+ -- Otherwise, if all are 8 bits, we need to decode to get Latin-1.
+ -- Otherwise, the result is implementation defined, so we return a
+ -- String encoded as UTF-8. (Note that the AI says "if any character
+ -- in the sequence is not defined in Character, the result is
+ -- implementation-defined", so we are not obliged to decode ANY
+ -- Latin-1 characters if ANY character is bigger than 8 bits.
+
+ if S.All_7_Bits then
+ return Get_UTF_8 (S);
+ elsif S.All_8_Bits then
+ return UTF_Encoding.Strings.Decode (Get_UTF_8 (S));
+ else
+ return Get_UTF_8 (S);
+ end if;
+ end Get;
+
+ function Wide_Get (S : Buffer'Class) return Wide_String is
+ begin
+ return UTF_Encoding.Wide_Strings.Decode (Get_UTF_8 (S));
+ end Wide_Get;
+
+ function Wide_Wide_Get (S : Buffer'Class) return Wide_Wide_String is
+ begin
+ return UTF_Encoding.Wide_Wide_Strings.Decode (Get_UTF_8 (S));
+ end Wide_Wide_Get;
+
+end Ada.Strings.Text_Output.Buffers;
diff --git a/gcc/ada/libgnat/a-stoubu.ads b/gcc/ada/libgnat/a-stoubu.ads
new file mode 100644
index 0000000..faec897
--- /dev/null
+++ b/gcc/ada/libgnat/a-stoubu.ads
@@ -0,0 +1,73 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_OUTPUT.BUFFERS --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package Ada.Strings.Text_Output.Buffers is
+
+ type Buffer (<>) is new Sink with private;
+
+ function New_Buffer
+ (Indent_Amount : Natural := Default_Indent_Amount;
+ Chunk_Length : Positive := Default_Chunk_Length) return Buffer;
+
+ procedure Destroy (S : in out Buffer);
+ -- Reclaim any heap-allocated data, and render the Buffer unusable.
+ -- It would make sense to do this via finalization, but we wish to
+ -- avoid controlled types in the generated code for 'Image.
+
+ function Get_UTF_8 (S : Buffer'Class) return UTF_8_Lines;
+ -- Get the characters in S, encoded as UTF-8.
+
+ function UTF_8_Length (S : Buffer'Class) return Natural;
+ procedure Get_UTF_8
+ (S : Buffer'Class; Result : out UTF_8_Lines) with
+ Pre => Result'First = 1 and Result'Last = UTF_8_Length (S);
+ -- This is a procedure version of the Get_UTF_8 function, for
+ -- efficiency. The Result String must be the exact right length.
+
+ function Get (S : Buffer'Class) return String;
+ function Wide_Get (S : Buffer'Class) return Wide_String;
+ function Wide_Wide_Get (S : Buffer'Class) return Wide_Wide_String;
+ -- Get the characters in S, decoded as [[Wide_]Wide_]String.
+ -- There is no need for procedure versions of these, because
+ -- they are intended primarily to implement the [[Wide_]Wide_]Image
+ -- attribute, which is already a function.
+
+private
+ type Chunk_Count is new Natural;
+ type Buffer is new Sink with record
+ Num_Extra_Chunks : Natural := 0;
+ -- Number of chunks in the linked list, not including Initial_Chunk.
+ end record;
+
+ overriding procedure Full_Method (S : in out Buffer);
+ overriding procedure Flush_Method (S : in out Buffer) is null;
+
+end Ada.Strings.Text_Output.Buffers;
diff --git a/gcc/ada/libgnat/a-stoufi.adb b/gcc/ada/libgnat/a-stoufi.adb
new file mode 100644
index 0000000..34086bb
--- /dev/null
+++ b/gcc/ada/libgnat/a-stoufi.adb
@@ -0,0 +1,123 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_OUTPUT.FILES --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Text_Output.Utils; use Ada.Strings.Text_Output.Utils;
+package body Ada.Strings.Text_Output.Files is
+ use type OS.File_Descriptor;
+
+ function Create_From_FD
+ (FD : OS.File_Descriptor;
+ Indent_Amount : Natural;
+ Chunk_Length : Positive) return File;
+ -- Create a file from an OS file descriptor
+
+ function Create_From_FD
+ (FD : OS.File_Descriptor;
+ Indent_Amount : Natural;
+ Chunk_Length : Positive) return File
+ is
+ begin
+ if FD = OS.Invalid_FD then
+ raise Program_Error with OS.Errno_Message;
+ end if;
+ return Result : File (Chunk_Length) do
+ Result.Indent_Amount := Indent_Amount;
+ Result.Cur_Chunk := Result.Initial_Chunk'Unchecked_Access;
+ Result.FD := FD;
+ end return;
+ end Create_From_FD;
+
+ function Create_File
+ (Name : String;
+ Indent_Amount : Natural := Default_Indent_Amount;
+ Chunk_Length : Positive := Default_Chunk_Length) return File
+ is
+ begin
+ return Create_From_FD
+ (OS.Create_File (Name, Fmode => OS.Text),
+ Indent_Amount, Chunk_Length);
+ end Create_File;
+
+ function Create_New_File
+ (Name : String;
+ Indent_Amount : Natural := Default_Indent_Amount;
+ Chunk_Length : Positive := Default_Chunk_Length) return File
+ is
+ begin
+ return Create_From_FD
+ (OS.Create_New_File (Name, Fmode => OS.Text),
+ Indent_Amount, Chunk_Length);
+ end Create_New_File;
+
+ overriding procedure Finalize (Ref : in out Self_Ref) is
+ begin
+ Close (Ref.Self.all);
+ end Finalize;
+
+ procedure Close (S : in out File'Class) is
+ Status : Boolean;
+ begin
+ Flush (S);
+
+ if S.FD not in OS.Standout | OS.Standerr then -- Don't close these
+ OS.Close (S.FD, Status);
+ if not Status then
+ raise Program_Error with OS.Errno_Message;
+ end if;
+ end if;
+ end Close;
+
+ overriding procedure Full_Method (S : in out File) renames Flush_Method;
+
+ overriding procedure Flush_Method (S : in out File) is
+ pragma Assert (S.Cur_Chunk = S.Initial_Chunk'Unchecked_Access);
+ Res : constant Integer :=
+ OS.Write (S.FD, S.Cur_Chunk.Chars'Address, S.Last);
+ begin
+ if Res /= S.Last then
+ raise Program_Error with OS.Errno_Message;
+ end if;
+ S.Last := 0;
+ end Flush_Method;
+
+ The_Stdout : aliased File :=
+ Create_From_FD (OS.Standout,
+ Indent_Amount => Default_Indent_Amount,
+ Chunk_Length => Default_Chunk_Length);
+ The_Stderr : aliased File :=
+ Create_From_FD (OS.Standerr,
+ Indent_Amount => Default_Indent_Amount,
+ Chunk_Length => Default_Chunk_Length);
+
+ function Standard_Output return Sink_Access is (The_Stdout'Access);
+ function Standard_Error return Sink_Access is (The_Stderr'Access);
+
+end Ada.Strings.Text_Output.Files;
diff --git a/gcc/ada/libgnat/a-stoufi.ads b/gcc/ada/libgnat/a-stoufi.ads
new file mode 100644
index 0000000..0bff45a
--- /dev/null
+++ b/gcc/ada/libgnat/a-stoufi.ads
@@ -0,0 +1,72 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_OUTPUT.FILES --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+private with GNAT.OS_Lib;
+private with Ada.Finalization;
+package Ada.Strings.Text_Output.Files is
+ -- This package supports a Sink type that sends output to a file. The file
+ -- is automatically closed when finalized.
+
+ function Standard_Output return Sink_Access;
+ function Standard_Error return Sink_Access;
+
+ type File (<>) is new Sink with private;
+
+ function Create_File
+ (Name : String;
+ Indent_Amount : Natural := Default_Indent_Amount;
+ Chunk_Length : Positive := Default_Chunk_Length) return File;
+ function Create_New_File
+ (Name : String;
+ Indent_Amount : Natural := Default_Indent_Amount;
+ Chunk_Length : Positive := Default_Chunk_Length) return File;
+ -- Create a file. Create_New_File raises an exception if the file already
+ -- exists; Create_File overwrites.
+
+ procedure Close (S : in out File'Class);
+
+private
+
+ package OS renames GNAT.OS_Lib;
+
+ type Self_Ref (Self : access File) is new Finalization.Limited_Controlled
+ with null record;
+ overriding procedure Finalize (Ref : in out Self_Ref);
+
+ type File is new Sink with record
+ FD : OS.File_Descriptor := OS.Invalid_FD;
+ Ref : Self_Ref (File'Access);
+ end record;
+
+ overriding procedure Full_Method (S : in out File);
+ overriding procedure Flush_Method (S : in out File);
+
+end Ada.Strings.Text_Output.Files;
diff --git a/gcc/ada/libgnat/a-stoufo.adb b/gcc/ada/libgnat/a-stoufo.adb
new file mode 100644
index 0000000..f80b30a
--- /dev/null
+++ b/gcc/ada/libgnat/a-stoufo.adb
@@ -0,0 +1,155 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_OUTPUT.FORMATTING --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Text_Output.Files;
+with Ada.Strings.Text_Output.Buffers; use Ada.Strings.Text_Output.Buffers;
+with Ada.Strings.Text_Output.Utils; use Ada.Strings.Text_Output.Utils;
+package body Ada.Strings.Text_Output.Formatting is
+
+ procedure Put
+ (S : in out Sink'Class; T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "")
+ is
+ J : Positive := T'First;
+ Used : array (1 .. 9) of Boolean := (others => False);
+ begin
+ while J <= T'Last loop
+ if T (J) = '\' then
+ J := J + 1;
+ case T (J) is
+ when 'n' =>
+ New_Line (S);
+ when '\' =>
+ Put_7bit (S, '\');
+ when 'i' =>
+ Indent (S);
+ when 'o' =>
+ Outdent (S);
+ when 'I' =>
+ Indent (S, 1);
+ when 'O' =>
+ Outdent (S, 1);
+
+ when '1' =>
+ Used (1) := True;
+ Put_UTF_8_Lines (S, X1);
+ when '2' =>
+ Used (2) := True;
+ Put_UTF_8_Lines (S, X2);
+ when '3' =>
+ Used (3) := True;
+ Put_UTF_8_Lines (S, X3);
+ when '4' =>
+ Used (4) := True;
+ Put_UTF_8_Lines (S, X4);
+ when '5' =>
+ Used (5) := True;
+ Put_UTF_8_Lines (S, X5);
+ when '6' =>
+ Used (6) := True;
+ Put_UTF_8_Lines (S, X6);
+ when '7' =>
+ Used (7) := True;
+ Put_UTF_8_Lines (S, X7);
+ when '8' =>
+ Used (8) := True;
+ Put_UTF_8_Lines (S, X8);
+ when '9' =>
+ Used (9) := True;
+ Put_UTF_8_Lines (S, X9);
+
+ when others =>
+ raise Program_Error;
+ end case;
+ else
+ Put_7bit (S, T (J));
+ end if;
+
+ J := J + 1;
+ end loop;
+
+ if not Used (1) then
+ pragma Assert (X1 = "");
+ end if;
+ if not Used (2) then
+ pragma Assert (X2 = "");
+ end if;
+ if not Used (3) then
+ pragma Assert (X3 = "");
+ end if;
+ if not Used (4) then
+ pragma Assert (X4 = "");
+ end if;
+ if not Used (5) then
+ pragma Assert (X5 = "");
+ end if;
+ if not Used (6) then
+ pragma Assert (X6 = "");
+ end if;
+ if not Used (7) then
+ pragma Assert (X7 = "");
+ end if;
+ if not Used (8) then
+ pragma Assert (X8 = "");
+ end if;
+ if not Used (9) then
+ pragma Assert (X9 = "");
+ end if;
+
+ Flush (S);
+ end Put;
+
+ procedure Put
+ (T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "") is
+ begin
+ Put (Files.Standard_Output.all, T, X1, X2, X3, X4, X5, X6, X7, X8, X9);
+ end Put;
+
+ procedure Err
+ (T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "") is
+ begin
+ Put (Files.Standard_Error.all, T, X1, X2, X3, X4, X5, X6, X7, X8, X9);
+ end Err;
+
+ function Format
+ (T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "")
+ return UTF_8_Lines
+ is
+ Buf : Buffer := New_Buffer;
+ begin
+ Put (Buf, T, X1, X2, X3, X4, X5, X6, X7, X8, X9);
+ return Get_UTF_8 (Buf);
+ end Format;
+
+end Ada.Strings.Text_Output.Formatting;
diff --git a/gcc/ada/libgnat/a-stoufo.ads b/gcc/ada/libgnat/a-stoufo.ads
new file mode 100644
index 0000000..3b44bd8
--- /dev/null
+++ b/gcc/ada/libgnat/a-stoufo.ads
@@ -0,0 +1,72 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_OUTPUT.FORMATTING --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package Ada.Strings.Text_Output.Formatting is
+
+ -- Template-based output, based loosely on C's printf family. Unlike
+ -- printf, it is type safe. We don't support myriad formatting options; the
+ -- caller is expected to call 'Image, or other functions that might have
+ -- various formatting capabilities.
+ --
+ -- Each of the following calls Flush
+
+ type Template is new UTF_8;
+ procedure Put
+ (S : in out Sink'Class; T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "");
+ -- Prints the template as is, except for the following escape sequences:
+ -- "\n" is end of line.
+ -- "\i" indents by the default amount, and "\o" outdents.
+ -- "\I" indents by one space, and "\O" outdents.
+ -- "\1" is replaced with X1, and similarly for 2, 3, ....
+ -- "\\" is "\".
+
+ -- Note that the template is not type String, to avoid this sort of thing:
+ --
+ -- https://xkcd.com/327/
+
+ procedure Put
+ (T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "");
+ -- Sends to standard output
+
+ procedure Err
+ (T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "");
+ -- Sends to standard error
+
+ function Format
+ (T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "")
+ return UTF_8_Lines;
+ -- Returns a UTF-8-encoded String
+
+end Ada.Strings.Text_Output.Formatting;
diff --git a/gcc/ada/libgnat/a-stouut.adb b/gcc/ada/libgnat/a-stouut.adb
new file mode 100644
index 0000000..b5a8f97
--- /dev/null
+++ b/gcc/ada/libgnat/a-stouut.adb
@@ -0,0 +1,271 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_OUTPUT.UTILS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.UTF_Encoding.Wide_Wide_Strings;
+
+package body Ada.Strings.Text_Output.Utils is
+
+ procedure Put_Octet (S : in out Sink'Class; Item : Character) with Inline;
+ -- Send a single octet to the current Chunk
+
+ procedure Adjust_Column (S : in out Sink'Class) with Inline;
+ -- Adjust the column for a non-NL character.
+
+ procedure Put_UTF_8_Outline (S : in out Sink'Class; Item : UTF_8);
+ -- Out-of-line portion of Put_UTF_8. This exists solely to make Put_UTF_8
+ -- small enough to reasonably inline it.
+
+ procedure Full (S : in out Sink'Class) is
+ begin
+ pragma Assert (S.Last = S.Chunk_Length);
+ Full_Method (S);
+ pragma Assert (S.Last = 0);
+ end Full;
+
+ procedure Flush (S : in out Sink'Class) is
+ begin
+ Flush_Method (S);
+ end Flush;
+
+ procedure Put_Octet (S : in out Sink'Class; Item : Character) is
+ begin
+ S.Last := @ + 1;
+ S.Cur_Chunk.Chars (S.Last) := Item;
+ pragma Assert (S.Chunk_Length = S.Cur_Chunk.Chars'Length);
+ if S.Last = S.Chunk_Length then
+ Full (S);
+ end if;
+ end Put_Octet;
+
+ procedure Adjust_Column (S : in out Sink'Class) is
+ begin
+ -- If we're in the first column, indent. This is handled here, rather
+ -- than when we see NL, because we don't want spaces in a blank line.
+ -- The character we're about to put is not NL; NL is handled in
+ -- New_Line. So after indenting, we simply increment the Column.
+
+ if S.Column = 1 then
+ Tab_To_Column (S, S.Indentation + 1);
+ end if;
+ S.Column := @ + 1;
+ end Adjust_Column;
+
+ procedure Put_7bit (S : in out Sink'Class; Item : Character_7) is
+ begin
+ Adjust_Column (S);
+ Put_Octet (S, Item);
+ end Put_7bit;
+
+ procedure Put_7bit_NL (S : in out Sink'Class; Item : Character_7) is
+ begin
+ if Item = NL then
+ New_Line (S);
+ else
+ Put_7bit (S, Item);
+ end if;
+ end Put_7bit_NL;
+
+ procedure Put_Character (S : in out Sink'Class; Item : Character) is
+ begin
+ if Character'Pos (Item) < 2**7 then
+ Put_7bit_NL (S, Item);
+ else
+ Put_Wide_Wide_Character (S, To_Wide_Wide (Item));
+ end if;
+ end Put_Character;
+
+ procedure Put_Wide_Character
+ (S : in out Sink'Class; Item : Wide_Character) is
+ begin
+ if Wide_Character'Pos (Item) < 2**7 then
+ Put_7bit_NL (S, From_Wide (Item));
+ else
+ Put_Wide_Wide_Character (S, To_Wide_Wide (Item));
+ end if;
+ end Put_Wide_Character;
+
+ procedure Put_Wide_Wide_Character
+ (S : in out Sink'Class; Item : Wide_Wide_Character) is
+ begin
+ if Wide_Wide_Character'Pos (Item) < 2**7 then
+ Put_7bit_NL (S, From_Wide_Wide (Item));
+ else
+ S.All_7_Bits := False;
+ if Wide_Wide_Character'Pos (Item) >= 2**8 then
+ S.All_8_Bits := False;
+ end if;
+ declare
+ Temp : constant UTF_8_Lines :=
+ UTF_Encoding.Wide_Wide_Strings.Encode ((1 => Item));
+ begin
+ for X of Temp loop
+ pragma Assert (X /= NL);
+ Adjust_Column (S);
+ Put_Octet (S, X);
+ end loop;
+ end;
+ end if;
+ end Put_Wide_Wide_Character;
+
+ procedure Put_UTF_8_Outline (S : in out Sink'Class; Item : UTF_8) is
+ begin
+ if S.Last + Item'Length = S.Chunk_Length then
+ -- Item fits exactly in current chunk
+
+ S.Cur_Chunk.Chars (S.Last + 1 .. S.Last + Item'Length) := Item;
+ S.Last := S.Last + Item'Length;
+ Full (S);
+ -- ???Seems like maybe we shouldn't call Full until we have MORE
+ -- characters. But then we can't pass Chunk_Length => 1 to
+ -- Create_File to get unbuffered output.
+ else
+ -- We get here only if Item doesn't fit in the current chunk, which
+ -- should be fairly rare. We split Item into Left and Right, where
+ -- Left exactly fills the current chunk, and recurse on Left and
+ -- Right. Right will fit into the next chunk unless it's very long,
+ -- so another level of recursion will be extremely rare.
+
+ declare
+ Left_Length : constant Natural := S.Chunk_Length - S.Last;
+ Right_First : constant Natural := Item'First + Left_Length;
+ Left : UTF_8 renames Item (Item'First .. Right_First - 1);
+ Right : UTF_8 renames Item (Right_First .. Item'Last);
+ pragma Assert (Left & Right = Item);
+ begin
+ Put_UTF_8 (S, Left); -- This will call Full.
+ Put_UTF_8 (S, Right); -- This might call Full, but probably not.
+ end;
+ end if;
+ end Put_UTF_8_Outline;
+
+ procedure Put_UTF_8 (S : in out Sink'Class; Item : UTF_8) is
+ begin
+ Adjust_Column (S);
+
+ if S.Last + Item'Length < S.Chunk_Length then
+ -- Item fits in current chunk
+
+ S.Cur_Chunk.Chars (S.Last + 1 .. S.Last + Item'Length) := Item;
+ S.Last := S.Last + Item'Length;
+ else
+ Put_UTF_8_Outline (S, Item);
+ end if;
+ end Put_UTF_8;
+
+ procedure Put_UTF_8_Lines (S : in out Sink'Class; Item : UTF_8_Lines) is
+ Line_Start, Index : Integer := Item'First;
+ -- Needs to be Integer, because Item'First might be negative for empty
+ -- Items.
+ begin
+ while Index <= Item'Last loop
+ if Item (Index) = NL then
+ if Index > Line_Start then
+ Put_UTF_8 (S, Item (Line_Start .. Index - 1));
+ end if;
+ New_Line (S);
+ S.Column := 1;
+ Line_Start := Index + 1;
+ end if;
+
+ Index := @ + 1;
+ end loop;
+
+ if Index > Line_Start then
+ Put_UTF_8 (S, Item (Line_Start .. Index - 1));
+ end if;
+ end Put_UTF_8_Lines;
+
+ procedure Put_String (S : in out Sink'Class; Item : String) is
+ begin
+ for X of Item loop
+ Put_Character (S, X);
+ end loop;
+ end Put_String;
+
+ procedure Put_Wide_String (S : in out Sink'Class; Item : Wide_String) is
+ begin
+ for X of Item loop
+ Put_Wide_Character (S, X);
+ end loop;
+ end Put_Wide_String;
+
+ procedure Put_Wide_Wide_String
+ (S : in out Sink'Class; Item : Wide_Wide_String) is
+ begin
+ for X of Item loop
+ Put_Wide_Wide_Character (S, X);
+ end loop;
+ end Put_Wide_Wide_String;
+
+ procedure New_Line (S : in out Sink'Class) is
+ begin
+ S.Column := 1;
+ Put_Octet (S, NL);
+ end New_Line;
+
+ function Column (S : Sink'Class) return Positive is (S.Column);
+
+ procedure Tab_To_Column (S : in out Sink'Class; Column : Positive) is
+ begin
+ if S.Column < Column then
+ for X in 1 .. Column - S.Column loop
+ Put_Octet (S, ' ');
+ end loop;
+ S.Column := Column;
+ end if;
+ end Tab_To_Column;
+
+ procedure Set_Indentation (S : in out Sink'Class; Amount : Natural) is
+ begin
+ S.Indentation := Amount;
+ end Set_Indentation;
+
+ function Indentation (S : Sink'Class) return Natural is (S.Indentation);
+
+ procedure Indent
+ (S : in out Sink'Class; Amount : Optional_Indentation := Default)
+ is
+ By : constant Natural :=
+ (if Amount = Default then S.Indent_Amount else Amount);
+ begin
+ Set_Indentation (S, Indentation (S) + By);
+ end Indent;
+
+ procedure Outdent
+ (S : in out Sink'Class; Amount : Optional_Indentation := Default)
+ is
+ By : constant Natural :=
+ (if Amount = Default then S.Indent_Amount else Amount);
+ begin
+ Set_Indentation (S, Indentation (S) - By);
+ end Outdent;
+
+end Ada.Strings.Text_Output.Utils;
diff --git a/gcc/ada/libgnat/a-stouut.ads b/gcc/ada/libgnat/a-stouut.ads
new file mode 100644
index 0000000..28d7eca
--- /dev/null
+++ b/gcc/ada/libgnat/a-stouut.ads
@@ -0,0 +1,106 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_OUTPUT.UTILS --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package Ada.Strings.Text_Output.Utils with Preelaborate is
+
+ -- This package provides utility functions on Sink'Class. These are
+ -- intended for use by Put_Image attributes, both the default versions
+ -- generated by the compiler, and user-defined ones.
+
+ procedure Full (S : in out Sink'Class) with Inline;
+ -- Must be called when the current chunk is full. Dispatches to
+ -- Full_Method.
+
+ procedure Flush (S : in out Sink'Class) with Inline;
+ -- Dispatches to Flush_Method
+
+ -- Full_Method and Flush_Method should be called only via Full and Flush
+
+ procedure Put_Character (S : in out Sink'Class; Item : Character);
+ procedure Put_Wide_Character (S : in out Sink'Class; Item : Wide_Character);
+ procedure Put_Wide_Wide_Character
+ (S : in out Sink'Class; Item : Wide_Wide_Character);
+ procedure Put_String (S : in out Sink'Class; Item : String);
+ procedure Put_Wide_String (S : in out Sink'Class; Item : Wide_String);
+ procedure Put_Wide_Wide_String
+ (S : in out Sink'Class; Item : Wide_Wide_String);
+ -- Encode characters or strings as UTF-8, and send them to S.
+
+ subtype Character_7 is
+ Character range Character'Val (0) .. Character'Val (2**7 - 1);
+ -- 7-bit character. These are the same in both Latin-1 and UTF-8.
+
+ procedure Put_7bit (S : in out Sink'Class; Item : Character_7)
+ with Inline, Pre => Item /= NL;
+ procedure Put_7bit_NL (S : in out Sink'Class; Item : Character_7)
+ with Inline;
+ -- Put a 7-bit character, and adjust the Column. For Put_7bit_NL, Item can
+ -- be NL.
+
+ procedure Put_UTF_8 (S : in out Sink'Class; Item : UTF_8) with Inline;
+ procedure Put_UTF_8_Lines (S : in out Sink'Class; Item : UTF_8_Lines);
+ -- Send data that is already UTF-8 encoded (including 7-bit ASCII) to
+ -- S. These are more efficient than Put_String.
+
+ procedure New_Line (S : in out Sink'Class) with Inline;
+ -- Puts the new-line character.
+
+ function Column (S : Sink'Class) return Positive with Inline;
+ -- Current output column. The Column is initially 1, and is incremented for
+ -- each 7-bit character output, except for the new-line character, which
+ -- sets Column back to 1. The next character to be output will go in this
+ -- column.
+
+ procedure Tab_To_Column (S : in out Sink'Class; Column : Positive);
+ -- Put spaces until we're at or past Column.
+
+ procedure Set_Indentation (S : in out Sink'Class; Amount : Natural)
+ with Inline;
+ function Indentation (S : Sink'Class) return Natural with Inline;
+ -- Indentation is initially 0. Set_Indentation sets it, and Indentation
+ -- returns it. This number of space characters are put at the start of
+ -- each nonempty line.
+
+ subtype Optional_Indentation is Integer range -1 .. Natural'Last;
+ Default : constant Optional_Indentation := -1;
+
+ procedure Indent
+ (S : in out Sink'Class; Amount : Optional_Indentation := Default)
+ with Inline;
+ procedure Outdent
+ (S : in out Sink'Class; Amount : Optional_Indentation := Default)
+ with Inline;
+ -- Increase/decrease Indentation by Amount. If Amount = Default, the amount
+ -- specified by the Indent_Amount parameter of the sink creation function
+ -- is used. The sink creation functions are New_Buffer, Create_File, and
+ -- Create_New_File.
+
+end Ada.Strings.Text_Output.Utils;
diff --git a/gcc/ada/libgnat/a-strbou.adb b/gcc/ada/libgnat/a-strbou.adb
index 50da492..d48798b 100644
--- a/gcc/ada/libgnat/a-strbou.adb
+++ b/gcc/ada/libgnat/a-strbou.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-strbou.ads b/gcc/ada/libgnat/a-strbou.ads
index ae61b86..ebde112 100644
--- a/gcc/ada/libgnat/a-strbou.ads
+++ b/gcc/ada/libgnat/a-strbou.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-stream.adb b/gcc/ada/libgnat/a-stream.adb
index d4a3f13..67d70c5 100644
--- a/gcc/ada/libgnat/a-stream.adb
+++ b/gcc/ada/libgnat/a-stream.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2013-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-stream.ads b/gcc/ada/libgnat/a-stream.ads
index 8886c94..9a76ee3 100644
--- a/gcc/ada/libgnat/a-stream.ads
+++ b/gcc/ada/libgnat/a-stream.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-strfix.adb b/gcc/ada/libgnat/a-strfix.adb
index b8b5f42..8105f30 100644
--- a/gcc/ada/libgnat/a-strfix.adb
+++ b/gcc/ada/libgnat/a-strfix.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -192,6 +192,10 @@ package body Ada.Strings.Fixed is
elsif From not in Source'Range
or else Through > Source'Last
then
+ pragma Annotate
+ (CodePeer, False_Positive,
+ "test always false", "self fullfilling prophecy");
+
-- In most cases this raises an exception, but the case of deleting
-- a null string at the end of the current one is a special-case, and
-- reflects the equivalence with Replace_String (RM A.4.3 (86/3)).
diff --git a/gcc/ada/libgnat/a-strhas.adb b/gcc/ada/libgnat/a-strhas.adb
index 258ee92..572b766 100644
--- a/gcc/ada/libgnat/a-strhas.adb
+++ b/gcc/ada/libgnat/a-strhas.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-strmap.adb b/gcc/ada/libgnat/a-strmap.adb
index c8917d9..9f6e857 100644
--- a/gcc/ada/libgnat/a-strmap.adb
+++ b/gcc/ada/libgnat/a-strmap.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-strmap.ads b/gcc/ada/libgnat/a-strmap.ads
index 3782189..ab59402 100644
--- a/gcc/ada/libgnat/a-strmap.ads
+++ b/gcc/ada/libgnat/a-strmap.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-strsea.adb b/gcc/ada/libgnat/a-strsea.adb
index c835f3a..b779090 100644
--- a/gcc/ada/libgnat/a-strsea.adb
+++ b/gcc/ada/libgnat/a-strsea.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-strsea.ads b/gcc/ada/libgnat/a-strsea.ads
index 1e1bc59..668b2e1 100644
--- a/gcc/ada/libgnat/a-strsea.ads
+++ b/gcc/ada/libgnat/a-strsea.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-strsto.ads b/gcc/ada/libgnat/a-strsto.ads
new file mode 100644
index 0000000..ae38b2d
--- /dev/null
+++ b/gcc/ada/libgnat/a-strsto.ads
@@ -0,0 +1,44 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R E A M S . S T O R A G E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+package Ada.Streams.Storage with Pure is
+
+ type Storage_Stream_Type is abstract new Root_Stream_Type with private;
+
+ function Element_Count
+ (Stream : Storage_Stream_Type) return Stream_Element_Count is abstract;
+
+ procedure Clear (Stream : in out Storage_Stream_Type) is abstract;
+
+private
+ type Storage_Stream_Type is abstract new Root_Stream_Type with null record;
+end Ada.Streams.Storage;
diff --git a/gcc/ada/libgnat/a-strsup.adb b/gcc/ada/libgnat/a-strsup.adb
index fa2ba88..e11df76 100644
--- a/gcc/ada/libgnat/a-strsup.adb
+++ b/gcc/ada/libgnat/a-strsup.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-strsup.ads b/gcc/ada/libgnat/a-strsup.ads
index f68db86..50607ae 100644
--- a/gcc/ada/libgnat/a-strsup.ads
+++ b/gcc/ada/libgnat/a-strsup.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-strunb.adb b/gcc/ada/libgnat/a-strunb.adb
index 347d85a..988de42 100644
--- a/gcc/ada/libgnat/a-strunb.adb
+++ b/gcc/ada/libgnat/a-strunb.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -35,6 +35,19 @@ with Ada.Unchecked_Deallocation;
package body Ada.Strings.Unbounded is
+ function Sum (Left : Natural; Right : Integer) return Natural with Inline;
+ -- Returns summary of Left and Right, raise Constraint_Error on overflow
+
+ function Mul (Left, Right : Natural) return Natural with Inline;
+ -- Returns multiplication of Left and Right, raise Constraint_Error on
+ -- overflow.
+
+ function Saturated_Sum (Left : Natural; Right : Integer) return Natural;
+ -- Returns summary of Left and Right or Natural'Last on overflow
+
+ function Saturated_Mul (Left, Right : Natural) return Natural;
+ -- Returns multiplication of Left and Right or Natural'Last on overflow
+
---------
-- "&" --
---------
@@ -48,7 +61,7 @@ package body Ada.Strings.Unbounded is
Result : Unbounded_String;
begin
- Result.Last := L_Length + R_Length;
+ Result.Last := Sum (L_Length, R_Length);
Result.Reference := new String (1 .. Result.Last);
@@ -68,7 +81,7 @@ package body Ada.Strings.Unbounded is
Result : Unbounded_String;
begin
- Result.Last := L_Length + Right'Length;
+ Result.Last := Sum (L_Length, Right'Length);
Result.Reference := new String (1 .. Result.Last);
@@ -86,7 +99,7 @@ package body Ada.Strings.Unbounded is
Result : Unbounded_String;
begin
- Result.Last := Left'Length + R_Length;
+ Result.Last := Sum (Left'Length, R_Length);
Result.Reference := new String (1 .. Result.Last);
@@ -104,7 +117,7 @@ package body Ada.Strings.Unbounded is
Result : Unbounded_String;
begin
- Result.Last := Left.Last + 1;
+ Result.Last := Sum (Left.Last, 1);
Result.Reference := new String (1 .. Result.Last);
@@ -122,7 +135,7 @@ package body Ada.Strings.Unbounded is
Result : Unbounded_String;
begin
- Result.Last := Right.Last + 1;
+ Result.Last := Sum (Right.Last, 1);
Result.Reference := new String (1 .. Result.Last);
Result.Reference (1) := Left;
@@ -142,7 +155,7 @@ package body Ada.Strings.Unbounded is
Result : Unbounded_String;
begin
- Result.Last := Left;
+ Result.Last := Left;
Result.Reference := new String (1 .. Left);
for J in Result.Reference'Range loop
@@ -161,7 +174,7 @@ package body Ada.Strings.Unbounded is
Result : Unbounded_String;
begin
- Result.Last := Left * Len;
+ Result.Last := Mul (Left, Len);
Result.Reference := new String (1 .. Result.Last);
@@ -183,7 +196,7 @@ package body Ada.Strings.Unbounded is
Result : Unbounded_String;
begin
- Result.Last := Left * Len;
+ Result.Last := Mul (Left, Len);
Result.Reference := new String (1 .. Result.Last);
@@ -718,6 +731,16 @@ package body Ada.Strings.Unbounded is
return Source.Last;
end Length;
+ ---------
+ -- Mul --
+ ---------
+
+ function Mul (Left, Right : Natural) return Natural is
+ pragma Unsuppress (Overflow_Check);
+ begin
+ return Left * Right;
+ end Mul;
+
---------------
-- Overwrite --
---------------
@@ -783,10 +806,12 @@ package body Ada.Strings.Unbounded is
if Chunk_Size > S_Length - Source.Last then
declare
New_Size : constant Positive :=
- S_Length + Chunk_Size + (S_Length / Growth_Factor);
+ Saturated_Sum
+ (Sum (S_Length, Chunk_Size), S_Length / Growth_Factor);
New_Rounded_Up_Size : constant Positive :=
- ((New_Size - 1) / Min_Mul_Alloc + 1) * Min_Mul_Alloc;
+ Saturated_Mul
+ ((New_Size - 1) / Min_Mul_Alloc + 1, Min_Mul_Alloc);
Tmp : constant String_Access :=
new String (1 .. New_Rounded_Up_Size);
@@ -847,6 +872,30 @@ package body Ada.Strings.Unbounded is
Free (Old);
end Replace_Slice;
+ -------------------
+ -- Saturated_Mul --
+ -------------------
+
+ function Saturated_Mul (Left, Right : Natural) return Natural is
+ begin
+ return Mul (Left, Right);
+ exception
+ when Constraint_Error =>
+ return Natural'Last;
+ end Saturated_Mul;
+
+ -----------------
+ -- Saturated_Sum --
+ -----------------
+
+ function Saturated_Sum (Left : Natural; Right : Integer) return Natural is
+ begin
+ return Sum (Left, Right);
+ exception
+ when Constraint_Error =>
+ return Natural'Last;
+ end Saturated_Sum;
+
--------------------------
-- Set_Unbounded_String --
--------------------------
@@ -882,6 +931,16 @@ package body Ada.Strings.Unbounded is
end if;
end Slice;
+ ---------
+ -- Sum --
+ ---------
+
+ function Sum (Left : Natural; Right : Integer) return Natural is
+ pragma Unsuppress (Overflow_Check);
+ begin
+ return Left + Right;
+ end Sum;
+
----------
-- Tail --
----------
@@ -1047,7 +1106,7 @@ package body Ada.Strings.Unbounded is
High : Natural) return Unbounded_String
is
begin
- if Low > Source.Last + 1 or else High > Source.Last then
+ if Low - 1 > Source.Last or else High > Source.Last then
raise Index_Error;
else
return To_Unbounded_String (Source.Reference.all (Low .. High));
@@ -1061,7 +1120,7 @@ package body Ada.Strings.Unbounded is
High : Natural)
is
begin
- if Low > Source.Last + 1 or else High > Source.Last then
+ if Low - 1 > Source.Last or else High > Source.Last then
raise Index_Error;
else
Target := To_Unbounded_String (Source.Reference.all (Low .. High));
diff --git a/gcc/ada/libgnat/a-strunb.ads b/gcc/ada/libgnat/a-strunb.ads
index e875b5b..3471dbb 100644
--- a/gcc/ada/libgnat/a-strunb.ads
+++ b/gcc/ada/libgnat/a-strunb.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-strunb__shared.adb b/gcc/ada/libgnat/a-strunb__shared.adb
index 90a6c40..0ff34d8 100644
--- a/gcc/ada/libgnat/a-strunb__shared.adb
+++ b/gcc/ada/libgnat/a-strunb__shared.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -56,6 +56,18 @@ package body Ada.Strings.Unbounded is
-- allocated memory segments to use memory effectively by Append/Insert/etc
-- operations.
+ function Sum (Left : Natural; Right : Integer) return Natural with Inline;
+ -- Returns summary of Left and Right, raise Constraint_Error on overflow
+
+ function Mul (Left, Right : Natural) return Natural with Inline;
+ -- Returns multiplication of Left and Right, raise Constraint_Error on
+ -- overflow
+
+ function Allocate
+ (Length, Growth : Natural) return not null Shared_String_Access;
+ -- Allocates new Shared_String with at least specified Length plus optional
+ -- Growth.
+
---------
-- "&" --
---------
@@ -66,14 +78,13 @@ package body Ada.Strings.Unbounded is
is
LR : constant Shared_String_Access := Left.Reference;
RR : constant Shared_String_Access := Right.Reference;
- DL : constant Natural := LR.Last + RR.Last;
+ DL : constant Natural := Sum (LR.Last, RR.Last);
DR : Shared_String_Access;
begin
-- Result is an empty string, reuse shared empty string
if DL = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
-- Left string is empty, return Right string
@@ -105,14 +116,13 @@ package body Ada.Strings.Unbounded is
Right : String) return Unbounded_String
is
LR : constant Shared_String_Access := Left.Reference;
- DL : constant Natural := LR.Last + Right'Length;
+ DL : constant Natural := Sum (LR.Last, Right'Length);
DR : Shared_String_Access;
begin
-- Result is an empty string, reuse shared empty string
if DL = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
-- Right is an empty string, return Left string
@@ -138,14 +148,13 @@ package body Ada.Strings.Unbounded is
Right : Unbounded_String) return Unbounded_String
is
RR : constant Shared_String_Access := Right.Reference;
- DL : constant Natural := Left'Length + RR.Last;
+ DL : constant Natural := Sum (Left'Length, RR.Last);
DR : Shared_String_Access;
begin
-- Result is an empty string, reuse shared one
if DL = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
-- Left is empty string, return Right string
@@ -171,7 +180,7 @@ package body Ada.Strings.Unbounded is
Right : Character) return Unbounded_String
is
LR : constant Shared_String_Access := Left.Reference;
- DL : constant Natural := LR.Last + 1;
+ DL : constant Natural := Sum (LR.Last, 1);
DR : Shared_String_Access;
begin
@@ -188,7 +197,7 @@ package body Ada.Strings.Unbounded is
Right : Unbounded_String) return Unbounded_String
is
RR : constant Shared_String_Access := Right.Reference;
- DL : constant Natural := 1 + RR.Last;
+ DL : constant Natural := Sum (1, RR.Last);
DR : Shared_String_Access;
begin
@@ -214,7 +223,6 @@ package body Ada.Strings.Unbounded is
-- Result is an empty string, reuse shared empty string
if Left = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
-- Otherwise, allocate new shared string and fill it
@@ -236,7 +244,7 @@ package body Ada.Strings.Unbounded is
(Left : Natural;
Right : String) return Unbounded_String
is
- DL : constant Natural := Left * Right'Length;
+ DL : constant Natural := Mul (Left, Right'Length);
DR : Shared_String_Access;
K : Positive;
@@ -244,7 +252,6 @@ package body Ada.Strings.Unbounded is
-- Result is an empty string, reuse shared empty string
if DL = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
-- Otherwise, allocate new shared string and fill it
@@ -269,7 +276,7 @@ package body Ada.Strings.Unbounded is
Right : Unbounded_String) return Unbounded_String
is
RR : constant Shared_String_Access := Right.Reference;
- DL : constant Natural := Left * RR.Last;
+ DL : constant Natural := Mul (Left, RR.Last);
DR : Shared_String_Access;
K : Positive;
@@ -277,7 +284,6 @@ package body Ada.Strings.Unbounded is
-- Result is an empty string, reuse shared empty string
if DL = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
-- Coefficient is one, just return string itself
@@ -486,13 +492,16 @@ package body Ada.Strings.Unbounded is
function Aligned_Max_Length (Max_Length : Natural) return Natural is
Static_Size : constant Natural :=
- Empty_Shared_String'Size / Standard'Storage_Unit;
- -- Total size of all static components
-
+ Empty_Shared_String'Size / Standard'Storage_Unit;
+ -- Total size of all Shared_String static components
begin
- return
- ((Static_Size + Max_Length - 1) / Min_Mul_Alloc + 2) * Min_Mul_Alloc
- - Static_Size;
+ if Max_Length > Natural'Last - Static_Size then
+ return Natural'Last;
+ else
+ return
+ ((Static_Size + Max_Length - 1) / Min_Mul_Alloc + 2) * Min_Mul_Alloc
+ - Static_Size;
+ end if;
end Aligned_Max_Length;
--------------
@@ -506,7 +515,6 @@ package body Ada.Strings.Unbounded is
-- Empty string requested, return shared empty string
if Max_Length = 0 then
- Reference (Empty_Shared_String'Access);
return Empty_Shared_String'Access;
-- Otherwise, allocate requested space (and probably some more room)
@@ -516,6 +524,23 @@ package body Ada.Strings.Unbounded is
end if;
end Allocate;
+ --------------
+ -- Allocate --
+ --------------
+
+ function Allocate
+ (Length, Growth : Natural) return not null Shared_String_Access is
+ begin
+ if Natural'Last - Growth < Length then
+ -- Then Length + Growth would be more than Natural'Last
+
+ return new Shared_String (Integer'Last);
+
+ else
+ return Allocate (Length + Growth);
+ end if;
+ end Allocate;
+
------------
-- Append --
------------
@@ -526,7 +551,7 @@ package body Ada.Strings.Unbounded is
is
SR : constant Shared_String_Access := Source.Reference;
NR : constant Shared_String_Access := New_Item.Reference;
- DL : constant Natural := SR.Last + NR.Last;
+ DL : constant Natural := Sum (SR.Last, NR.Last);
DR : Shared_String_Access;
begin
@@ -551,7 +576,7 @@ package body Ada.Strings.Unbounded is
-- Otherwise, allocate new one and fill it
else
- DR := Allocate (DL + DL / Growth_Factor);
+ DR := Allocate (DL, DL / Growth_Factor);
DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last);
DR.Last := DL;
@@ -565,7 +590,7 @@ package body Ada.Strings.Unbounded is
New_Item : String)
is
SR : constant Shared_String_Access := Source.Reference;
- DL : constant Natural := SR.Last + New_Item'Length;
+ DL : constant Natural := Sum (SR.Last, New_Item'Length);
DR : Shared_String_Access;
begin
@@ -583,7 +608,7 @@ package body Ada.Strings.Unbounded is
-- Otherwise, allocate new one and fill it
else
- DR := Allocate (DL + DL / Growth_Factor);
+ DR := Allocate (DL, DL / Growth_Factor);
DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
DR.Data (SR.Last + 1 .. DL) := New_Item;
DR.Last := DL;
@@ -597,20 +622,20 @@ package body Ada.Strings.Unbounded is
New_Item : Character)
is
SR : constant Shared_String_Access := Source.Reference;
- DL : constant Natural := SR.Last + 1;
+ DL : constant Natural := Sum (SR.Last, 1);
DR : Shared_String_Access;
begin
-- Try to reuse existing shared string
- if Can_Be_Reused (SR, SR.Last + 1) then
+ if Can_Be_Reused (SR, DL) then
SR.Data (SR.Last + 1) := New_Item;
SR.Last := SR.Last + 1;
-- Otherwise, allocate new one and fill it
else
- DR := Allocate (DL + DL / Growth_Factor);
+ DR := Allocate (DL, DL / Growth_Factor);
DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
DR.Data (DL) := New_Item;
DR.Last := DL;
@@ -701,7 +726,6 @@ package body Ada.Strings.Unbounded is
-- Result is an empty string, reuse shared empty string
if DL = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
-- Otherwise, allocate new shared string and fill it
@@ -743,7 +767,6 @@ package body Ada.Strings.Unbounded is
-- Result is empty, reuse shared empty string
if DL = 0 then
- Reference (Empty_Shared_String'Access);
Source.Reference := Empty_Shared_String'Access;
Unreference (SR);
@@ -801,7 +824,6 @@ package body Ada.Strings.Unbounded is
-- effects if a program references an already-finalized object.
Object.Reference := Null_Unbounded_String.Reference;
- Reference (Object.Reference);
Unreference (SR);
end if;
end Finalize;
@@ -862,7 +884,6 @@ package body Ada.Strings.Unbounded is
-- Result is empty, reuse shared empty string
if Count = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
-- Length of the string is the same as requested, reuse source shared
@@ -912,7 +933,6 @@ package body Ada.Strings.Unbounded is
-- Result is empty, reuse empty shared string
if Count = 0 then
- Reference (Empty_Shared_String'Access);
Source.Reference := Empty_Shared_String'Access;
Unreference (SR);
@@ -1090,7 +1110,6 @@ package body Ada.Strings.Unbounded is
-- Result is empty, reuse empty shared string
if DL = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
-- Inserted string is empty, reuse source shared string
@@ -1102,7 +1121,7 @@ package body Ada.Strings.Unbounded is
-- Otherwise, allocate new shared string and fill it
else
- DR := Allocate (DL + DL / Growth_Factor);
+ DR := Allocate (DL, DL / Growth_Factor);
DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
DR.Data (Before + New_Item'Length .. DL) :=
@@ -1132,7 +1151,6 @@ package body Ada.Strings.Unbounded is
-- Result is empty string, reuse empty shared string
if DL = 0 then
- Reference (Empty_Shared_String'Access);
Source.Reference := Empty_Shared_String'Access;
Unreference (SR);
@@ -1152,7 +1170,7 @@ package body Ada.Strings.Unbounded is
-- Otherwise, allocate new shared string and fill it
else
- DR := Allocate (DL + DL / Growth_Factor);
+ DR := Allocate (DL, DL / Growth_Factor);
DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
DR.Data (Before + New_Item'Length .. DL) :=
@@ -1172,6 +1190,16 @@ package body Ada.Strings.Unbounded is
return Source.Reference.Last;
end Length;
+ ---------
+ -- Mul --
+ ---------
+
+ function Mul (Left, Right : Natural) return Natural is
+ pragma Unsuppress (Overflow_Check);
+ begin
+ return Left * Right;
+ end Mul;
+
---------------
-- Overwrite --
---------------
@@ -1192,12 +1220,11 @@ package body Ada.Strings.Unbounded is
raise Index_Error;
end if;
- DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
+ DL := Integer'Max (SR.Last, Sum (Position - 1, New_Item'Length));
-- Result is empty string, reuse empty shared string
if DL = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
-- Result is same as source string, reuse source shared string
@@ -1241,7 +1268,6 @@ package body Ada.Strings.Unbounded is
-- Result is empty string, reuse empty shared string
if DL = 0 then
- Reference (Empty_Shared_String'Access);
Source.Reference := Empty_Shared_String'Access;
Unreference (SR);
@@ -1276,6 +1302,10 @@ package body Ada.Strings.Unbounded is
procedure Reference (Item : not null Shared_String_Access) is
begin
+ if Item = Empty_Shared_String'Access then
+ return;
+ end if;
+
System.Atomic_Counters.Increment (Item.Counter);
end Reference;
@@ -1341,14 +1371,14 @@ package body Ada.Strings.Unbounded is
-- Do replace operation when removed slice is not empty
if High >= Low then
- DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1;
+ DL := Sum (SR.Last,
+ By'Length + Low - Integer'Min (High, SR.Last) - 1);
-- This is the number of characters remaining in the string after
-- replacing the slice.
-- Result is empty string, reuse empty shared string
if DL = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
-- Otherwise allocate new shared string and fill it
@@ -1397,7 +1427,6 @@ package body Ada.Strings.Unbounded is
-- Result is empty string, reuse empty shared string
if DL = 0 then
- Reference (Empty_Shared_String'Access);
Source.Reference := Empty_Shared_String'Access;
Unreference (SR);
@@ -1442,7 +1471,6 @@ package body Ada.Strings.Unbounded is
-- In case of empty string, reuse empty shared string
if Source'Length = 0 then
- Reference (Empty_Shared_String'Access);
Target.Reference := Empty_Shared_String'Access;
else
@@ -1488,6 +1516,16 @@ package body Ada.Strings.Unbounded is
end if;
end Slice;
+ ---------
+ -- Sum --
+ ---------
+
+ function Sum (Left : Natural; Right : Integer) return Natural is
+ pragma Unsuppress (Overflow_Check);
+ begin
+ return Left + Right;
+ end Sum;
+
----------
-- Tail --
----------
@@ -1504,7 +1542,6 @@ package body Ada.Strings.Unbounded is
-- For empty result reuse empty shared string
if Count = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
-- Result is whole source string, reuse source shared string
@@ -1576,7 +1613,6 @@ package body Ada.Strings.Unbounded is
-- Result is empty string, reuse empty shared string
if Count = 0 then
- Reference (Empty_Shared_String'Access);
Source.Reference := Empty_Shared_String'Access;
Unreference (SR);
@@ -1619,7 +1655,6 @@ package body Ada.Strings.Unbounded is
begin
if Source'Length = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
else
@@ -1636,7 +1671,6 @@ package body Ada.Strings.Unbounded is
begin
if Length = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
else
@@ -1662,7 +1696,6 @@ package body Ada.Strings.Unbounded is
-- Nothing to translate, reuse empty shared string
if SR.Last = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
-- Otherwise, allocate new shared string and fill it
@@ -1726,7 +1759,6 @@ package body Ada.Strings.Unbounded is
-- Nothing to translate, reuse empty shared string
if SR.Last = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
-- Otherwise, allocate new shared string and fill it
@@ -1813,7 +1845,6 @@ package body Ada.Strings.Unbounded is
-- All blanks, reuse empty shared string
if Low = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
else
@@ -1867,7 +1898,6 @@ package body Ada.Strings.Unbounded is
-- All blanks, reuse empty shared string
if Low = 0 then
- Reference (Empty_Shared_String'Access);
Source.Reference := Empty_Shared_String'Access;
Unreference (SR);
@@ -1929,7 +1959,6 @@ package body Ada.Strings.Unbounded is
-- string.
if Low = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
else
@@ -1940,7 +1969,6 @@ package body Ada.Strings.Unbounded is
-- is empty, reuse empty shared string.
if High = 0 or else DL = 0 then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
-- Otherwise, allocate new shared string and fill it
@@ -1973,7 +2001,6 @@ package body Ada.Strings.Unbounded is
-- string.
if Low = 0 then
- Reference (Empty_Shared_String'Access);
Source.Reference := Empty_Shared_String'Access;
Unreference (SR);
@@ -1985,7 +2012,6 @@ package body Ada.Strings.Unbounded is
-- is empty, reuse empty shared string.
if High = 0 or else DL = 0 then
- Reference (Empty_Shared_String'Access);
Source.Reference := Empty_Shared_String'Access;
Unreference (SR);
@@ -2023,13 +2049,12 @@ package body Ada.Strings.Unbounded is
begin
-- Check bounds
- if Low > SR.Last + 1 or else High > SR.Last then
+ if Low - 1 > SR.Last or else High > SR.Last then
raise Index_Error;
-- Result is empty slice, reuse empty shared string
elsif Low > High then
- Reference (Empty_Shared_String'Access);
DR := Empty_Shared_String'Access;
-- Otherwise, allocate new shared string and fill it
@@ -2058,13 +2083,12 @@ package body Ada.Strings.Unbounded is
begin
-- Check bounds
- if Low > SR.Last + 1 or else High > SR.Last then
+ if Low - 1 > SR.Last or else High > SR.Last then
raise Index_Error;
-- Result is empty slice, reuse empty shared string
elsif Low > High then
- Reference (Empty_Shared_String'Access);
Target.Reference := Empty_Shared_String'Access;
Unreference (TR);
@@ -2101,14 +2125,12 @@ package body Ada.Strings.Unbounded is
Aux : Shared_String_Access := Item;
begin
- if System.Atomic_Counters.Decrement (Aux.Counter) then
-
- -- Reference counter of Empty_Shared_String should never reach
- -- zero. We check here in case it wraps around.
+ if Aux = Empty_Shared_String'Access then
+ return;
+ end if;
- if Aux /= Empty_Shared_String'Access then
- Free (Aux);
- end if;
+ if System.Atomic_Counters.Decrement (Aux.Counter) then
+ Free (Aux);
end if;
end Unreference;
diff --git a/gcc/ada/libgnat/a-strunb__shared.ads b/gcc/ada/libgnat/a-strunb__shared.ads
index 17acd56..5a5ad93 100644
--- a/gcc/ada/libgnat/a-strunb__shared.ads
+++ b/gcc/ada/libgnat/a-strunb__shared.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -708,10 +708,12 @@ private
type Shared_String_Access is access all Shared_String;
procedure Reference (Item : not null Shared_String_Access);
- -- Increment reference counter
+ -- Increment reference counter.
+ -- Do nothing if Item points to Empty_Shared_String.
procedure Unreference (Item : not null Shared_String_Access);
- -- Decrement reference counter, deallocate Item when counter goes to zero
+ -- Decrement reference counter, deallocate Item when counter goes to zero.
+ -- Do nothing if Item points to Empty_Shared_String.
function Can_Be_Reused
(Item : not null Shared_String_Access;
diff --git a/gcc/ada/libgnat/a-ststbo.adb b/gcc/ada/libgnat/a-ststbo.adb
new file mode 100644
index 0000000..16c6d00
--- /dev/null
+++ b/gcc/ada/libgnat/a-ststbo.adb
@@ -0,0 +1,117 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R E A M S . S T O R A G E . B O U N D E D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+package body Ada.Streams.Storage.Bounded is
+
+ ----------
+ -- Read --
+ ----------
+
+ overriding procedure Read
+ (Stream : in out Stream_Type; Item : out Stream_Element_Array;
+ Last : out Stream_Element_Offset)
+ is
+ EA : Stream_Element_Array renames
+ Stream.Elements (1 .. Element_Count (Stream));
+ begin
+ if Item'Length = 0 then
+ Last := Item'First - 1;
+
+ -- If the entire content of the stream fits in Item, then copy it and
+ -- clear the stream. This is likely the usual case.
+
+ elsif Element_Count (Stream) <= Item'Length then
+ Last := Item'First + Element_Count (Stream) - 1;
+ Item (Item'First .. Last) := EA;
+ Clear (Stream);
+
+ -- Otherwise, copy as much into Item as will fit. Then slide the
+ -- remaining part of the stream down, and compute the new Count.
+ -- We expect this to be the unusual case, so the cost of copying
+ -- the remaining part probably doesn't matter.
+
+ else
+ Last := Item'Last;
+
+ declare
+ New_Count : constant Stream_Element_Count :=
+ Element_Count (Stream) - Item'Length;
+ begin
+ Item := EA (1 .. Item'Length);
+ EA (1 .. New_Count) :=
+ EA (Element_Count (Stream) - New_Count + 1 ..
+ Element_Count (Stream));
+ Stream.Count := New_Count;
+ end;
+ end if;
+ end Read;
+
+ -----------
+ -- Write --
+ -----------
+
+ overriding procedure Write
+ (Stream : in out Stream_Type; Item : Stream_Element_Array)
+ is
+ begin
+ if Element_Count (Stream) + Item'Length > Stream.Max_Elements then
+ -- That is a precondition in the RM
+ raise Constraint_Error;
+ end if;
+
+ declare
+ New_Count : constant Stream_Element_Count :=
+ Element_Count (Stream) + Item'Length;
+ begin
+ Stream.Elements (Element_Count (Stream) + 1 .. New_Count) := Item;
+ Stream.Count := New_Count;
+ end;
+ end Write;
+
+ -------------------
+ -- Element_Count --
+ -------------------
+
+ overriding function Element_Count
+ (Stream : Stream_Type) return Stream_Element_Count
+ is
+ begin
+ return Stream.Count;
+ end Element_Count;
+
+ -----------
+ -- Clear --
+ -----------
+
+ overriding procedure Clear (Stream : in out Stream_Type)
+ is
+ begin
+ Stream.Count := 0;
+ end Clear;
+
+end Ada.Streams.Storage.Bounded;
diff --git a/gcc/ada/libgnat/a-ststbo.ads b/gcc/ada/libgnat/a-ststbo.ads
new file mode 100644
index 0000000..fe41c2c
--- /dev/null
+++ b/gcc/ada/libgnat/a-ststbo.ads
@@ -0,0 +1,73 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R E A M S . S T O R A G E . B O U N D E D --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+package Ada.Streams.Storage.Bounded with Pure is
+
+ type Stream_Type (Max_Elements : Stream_Element_Count) is
+ new Storage_Stream_Type with private with
+ Default_Initial_Condition => Element_Count (Stream_Type) = 0;
+
+ overriding procedure Read
+ (Stream : in out Stream_Type; Item : out Stream_Element_Array;
+ Last : out Stream_Element_Offset)
+ with Post =>
+ (declare
+ Num_Read : constant Stream_Element_Count :=
+ Stream_Element_Count'Min
+ (Element_Count (Stream)'Old, Item'Length);
+ begin
+ Last = Num_Read + Item'First - 1
+ and
+ Element_Count (Stream) =
+ Element_Count (Stream)'Old - Num_Read);
+
+ overriding procedure Write
+ (Stream : in out Stream_Type; Item : Stream_Element_Array) with
+ Post => Element_Count (Stream) =
+ Element_Count (Stream)'Old + Item'Length;
+
+ overriding function Element_Count
+ (Stream : Stream_Type) return Stream_Element_Count with
+ Post => Element_Count'Result <= Stream.Max_Elements;
+
+ overriding procedure Clear (Stream : in out Stream_Type) with
+ Post => Element_Count (Stream) = 0;
+
+private
+
+ type Stream_Type (Max_Elements : Stream_Element_Count) is
+ new Storage_Stream_Type with record
+ Count : Stream_Element_Count := 0;
+ Elements : Stream_Element_Array (1 .. Max_Elements);
+ end record;
+
+end Ada.Streams.Storage.Bounded;
diff --git a/gcc/ada/libgnat/a-ststio.adb b/gcc/ada/libgnat/a-ststio.adb
index 119ac5f..5ed5e00 100644
--- a/gcc/ada/libgnat/a-ststio.adb
+++ b/gcc/ada/libgnat/a-ststio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ststio.ads b/gcc/ada/libgnat/a-ststio.ads
index 30be158..71482a4 100644
--- a/gcc/ada/libgnat/a-ststio.ads
+++ b/gcc/ada/libgnat/a-ststio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-ststun.adb b/gcc/ada/libgnat/a-ststun.adb
new file mode 100644
index 0000000..cf3a250
--- /dev/null
+++ b/gcc/ada/libgnat/a-ststun.adb
@@ -0,0 +1,151 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R E A M S . S T O R A G E . U N B O U N D E D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+
+package body Ada.Streams.Storage.Unbounded is
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Elements_Type, Elements_Access);
+
+ --------------
+ -- Finalize --
+ --------------
+
+ overriding procedure Finalize (X : in out Controlled_Elements_Access) is
+ begin
+ if X.A /= Empty_Elements'Access then
+ Free (X.A);
+ end if;
+ end Finalize;
+
+ ----------
+ -- Read --
+ ----------
+
+ overriding procedure Read
+ (Stream : in out Stream_Type; Item : out Stream_Element_Array;
+ Last : out Stream_Element_Offset)
+ is
+ EA : Stream_Element_Array renames
+ Stream.Elements.A.EA (1 .. Element_Count (Stream));
+ begin
+ if Item'Length = 0 then
+ Last := Item'First - 1;
+
+ -- If the entire content of the stream fits in Item, then copy it and
+ -- clear the stream. This is likely the usual case.
+
+ elsif Element_Count (Stream) <= Item'Length then
+ Last := Item'First + Element_Count (Stream) - 1;
+ Item (Item'First .. Last) := EA;
+ Clear (Stream);
+
+ -- Otherwise, copy as much into Item as will fit. Then slide the
+ -- remaining part of the stream down, and compute the new Count.
+ -- We expect this to be the unusual case, so the cost of copying
+ -- the remaining part probably doesn't matter.
+
+ else
+ Last := Item'Last;
+
+ declare
+ New_Count : constant Stream_Element_Count :=
+ Element_Count (Stream) - Item'Length;
+ begin
+ Item := EA (1 .. Item'Length);
+ EA (1 .. New_Count) :=
+ EA (Element_Count (Stream) - New_Count + 1 ..
+ Element_Count (Stream));
+ Stream.Count := New_Count;
+ end;
+ end if;
+ end Read;
+
+ -----------
+ -- Write --
+ -----------
+
+ overriding procedure Write
+ (Stream : in out Stream_Type; Item : Stream_Element_Array)
+ is
+ New_Count : constant Stream_Element_Count :=
+ Element_Count (Stream) + Item'Length;
+ begin
+ -- Check whether we need to grow the array. If so, then if the Stream is
+ -- empty, allocate a goodly amount. Otherwise double the length, for
+ -- amortized efficiency. In any case, we need to make sure it's at least
+ -- big enough for New_Count.
+
+ if New_Count > Stream.Elements.A.Last then
+ declare
+ New_Last : Stream_Element_Index :=
+ (if Stream.Elements.A.Last = 0 then 2**10 -- goodly amount
+ else Stream.Elements.A.Last * 2);
+ Old_Elements : Elements_Access := Stream.Elements.A;
+ begin
+ if New_Last < New_Count then
+ New_Last := New_Count;
+ end if;
+
+ Stream.Elements.A := new Elements_Type (Last => New_Last);
+
+ if Old_Elements /= Empty_Elements'Access then
+ Stream.Elements.A.EA (Old_Elements.EA'Range) := Old_Elements.EA;
+ Free (Old_Elements);
+ end if;
+ end;
+ end if;
+
+ Stream.Elements.A.EA (Element_Count (Stream) + 1 .. New_Count) := Item;
+ Stream.Count := New_Count;
+ end Write;
+
+ -------------------
+ -- Element_Count --
+ -------------------
+
+ overriding function Element_Count
+ (Stream : Stream_Type) return Stream_Element_Count
+ is
+ begin
+ return Stream.Count;
+ end Element_Count;
+
+ -----------
+ -- Clear --
+ -----------
+
+ overriding procedure Clear (Stream : in out Stream_Type) is
+ begin
+ Stream.Count := 0;
+ -- We don't free Stream.Elements here, because we want to reuse it if
+ -- there are more Write calls.
+ end Clear;
+
+end Ada.Streams.Storage.Unbounded;
diff --git a/gcc/ada/libgnat/a-ststun.ads b/gcc/ada/libgnat/a-ststun.ads
new file mode 100644
index 0000000..95aca9b
--- /dev/null
+++ b/gcc/ada/libgnat/a-ststun.ads
@@ -0,0 +1,91 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R E A M S . S T O R A G E . U N B O U N D E D --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+private with Ada.Finalization;
+
+package Ada.Streams.Storage.Unbounded with Preelaborate is
+
+ type Stream_Type is new Storage_Stream_Type with private with
+ Default_Initial_Condition => Element_Count (Stream_Type) = 0;
+
+ overriding procedure Read
+ (Stream : in out Stream_Type; Item : out Stream_Element_Array;
+ Last : out Stream_Element_Offset)
+ with Post =>
+ (declare
+ Num_Read : constant Stream_Element_Count :=
+ Stream_Element_Count'Min
+ (Element_Count (Stream)'Old, Item'Length);
+ begin
+ Last = Num_Read + Item'First - 1
+ and
+ Element_Count (Stream) =
+ Element_Count (Stream)'Old - Num_Read);
+
+ overriding procedure Write
+ (Stream : in out Stream_Type; Item : Stream_Element_Array) with
+ Post => Element_Count (Stream) =
+ Element_Count (Stream)'Old + Item'Length;
+
+ overriding function Element_Count
+ (Stream : Stream_Type) return Stream_Element_Count;
+
+ overriding procedure Clear (Stream : in out Stream_Type) with
+ Post => Element_Count (Stream) = 0;
+
+private
+
+ subtype Stream_Element_Index is Stream_Element_Count
+ range 1 .. Stream_Element_Count'Last;
+
+ type Elements_Type (Last : Stream_Element_Count) is limited record
+ EA : Stream_Element_Array (1 .. Last);
+ end record;
+
+ Empty_Elements : aliased Elements_Type := (Last => 0, EA => (others => <>));
+
+ type Elements_Access is access all Elements_Type;
+
+ type Controlled_Elements_Access is
+ new Finalization.Limited_Controlled with record
+ A : Elements_Access;
+ end record;
+
+ overriding procedure Finalize (X : in out Controlled_Elements_Access);
+
+ type Stream_Type is new Storage_Stream_Type with record
+ Elements : Controlled_Elements_Access :=
+ (Finalization.Limited_Controlled with A => Empty_Elements'Access);
+ Count : Stream_Element_Count := 0;
+ end record;
+
+end Ada.Streams.Storage.Unbounded;
diff --git a/gcc/ada/libgnat/a-stteou.ads b/gcc/ada/libgnat/a-stteou.ads
new file mode 100644
index 0000000..924b550
--- /dev/null
+++ b/gcc/ada/libgnat/a-stteou.ads
@@ -0,0 +1,191 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_OUTPUT --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.UTF_Encoding;
+with Ada.Strings.UTF_Encoding.Wide_Wide_Strings;
+
+package Ada.Strings.Text_Output with Preelaborate is
+
+ -- This package provides a "Sink" abstraction, to which characters of type
+ -- Character, Wide_Character, and Wide_Wide_Character can be sent. This
+ -- type is used by the Put_Image attribute. In particular, T'Put_Image has
+ -- the following parameter types:
+ --
+ -- procedure T'Put_Image (S : in out Sink'Class; V : T);
+ --
+ -- The default generated code for Put_Image of a composite type will
+ -- typically call Put_Image on the components.
+ --
+ -- This is not a fully general abstraction that can be arbitrarily
+ -- extended. It is designed with particular extensions in mind, and these
+ -- extensions are declared in child packages of this package, because they
+ -- depend on implementation details in the private part of this
+ -- package. The primary extensions of Sink are:
+ --
+ -- Buffer. The characters sent to a Buffer are stored in memory, and can
+ -- be retrieved via Get functions. This is intended for the
+ -- implementation of the 'Image attribute. The compiler will generate a
+ -- T'Image function that declares a local Buffer, sends characters to
+ -- it, and then returns a call to Get, Destroying the Buffer on return.
+ --
+ -- function T'Image (V : T) return String is
+ -- Buf : Buffer := New_Buffer (...);
+ -- begin
+ -- T'Put_Image (Buf, V);
+ -- return Result : constant String := Get (Buf) do
+ -- Destroy (Buf);
+ -- end return;
+ -- end T'Image;
+ -- ????Perhaps Buffer should be controlled; if you don't like
+ -- controlled types, call Put_Image directly.
+ --
+ -- File. The characters are sent to a file, possibly opened by file
+ -- name, or possibly standard output or standard error. 'Put_Image
+ -- can be called directly on a File, thus avoiding any heap allocation.
+
+ type Sink (<>) is abstract tagged limited private;
+ type Sink_Access is access all Sink'Class with Storage_Size => 0;
+ -- Sink is a character sink; you can send characters to a Sink.
+ -- UTF-8 encoding is used.
+
+ procedure Full_Method (S : in out Sink) is abstract;
+ procedure Flush_Method (S : in out Sink) is abstract;
+ -- There is an internal buffer to store the characters. Full_Method is
+ -- called when the buffer is full, and Flush_Method may be called to flush
+ -- the buffer. For Buffer, Full_Method allocates more space for more
+ -- characters, and Flush_Method does nothing. For File, Full_Method and
+ -- Flush_Method do the same thing: write the characters to the file, and
+ -- empty the internal buffer.
+ --
+ -- These are the only dispatching subprograms on Sink. This is for
+ -- efficiency; we don't dispatch on every write to the Sink, but only when
+ -- the internal buffer is full (or upon client request).
+ --
+ -- Full_Method and Flush_Method must make the current chunk empty.
+ --
+ -- Additional operations operating on Sink'Class are declared in the Utils
+ -- child, including Full and Flush, which call the above.
+
+ function To_Wide (C : Character) return Wide_Character is
+ (Wide_Character'Val (Character'Pos (C)));
+ function To_Wide_Wide (C : Character) return Wide_Wide_Character is
+ (Wide_Wide_Character'Val (Character'Pos (C)));
+ function To_Wide_Wide (C : Wide_Character) return Wide_Wide_Character is
+ (Wide_Wide_Character'Val (Wide_Character'Pos (C)));
+ -- Conversions [Wide_]Character --> [Wide_]Wide_Character.
+ -- These cannot fail.
+
+ function From_Wide (C : Wide_Character) return Character is
+ (Character'Val (Wide_Character'Pos (C)));
+ function From_Wide_Wide (C : Wide_Wide_Character) return Character is
+ (Character'Val (Wide_Wide_Character'Pos (C)));
+ function From_Wide_Wide (C : Wide_Wide_Character) return Wide_Character is
+ (Wide_Character'Val (Wide_Wide_Character'Pos (C)));
+ -- Conversions [Wide_]Wide_Character --> [Wide_]Character.
+ -- These fail if the character is out of range.
+
+ function NL return Character is (ASCII.LF) with Inline;
+ function Wide_NL return Wide_Character is (To_Wide (Character'(NL)))
+ with Inline;
+ function Wide_Wide_NL return Wide_Wide_Character is
+ (To_Wide_Wide (Character'(NL))) with Inline;
+ -- Character representing new line. There is no support for CR/LF line
+ -- endings.
+
+ -- We have two subtypes of String that are encoded in UTF-8. UTF_8 cannot
+ -- contain newline characters; UTF_8_Lines can. Sending UTF_8 data to a
+ -- Sink is more efficient, because end-of-line processing is not needed.
+ -- Both of these are more efficient than [[Wide_]Wide_]String, because no
+ -- encoding is needed.
+
+ subtype UTF_8_Lines is UTF_Encoding.UTF_8_String with
+ Predicate =>
+ UTF_Encoding.Wide_Wide_Strings.Encode
+ (UTF_Encoding.Wide_Wide_Strings.Decode (UTF_8_Lines)) = UTF_8_Lines;
+
+ subtype UTF_8 is UTF_8_Lines with
+ Predicate => (for all UTF_8_Char of UTF_8 => UTF_8_Char /= NL);
+
+ Default_Indent_Amount : constant Natural := 4;
+
+ Default_Chunk_Length : constant Positive := 500;
+ -- Experiment shows this value to be reasonably efficient; decreasing it
+ -- slows things down, but increasing it doesn't gain much.
+
+private
+ type String_Access is access all String;
+
+ -- For Buffer, the "internal buffer" mentioned above is implemented as a
+ -- linked list of chunks. When the current chunk is full, we allocate a new
+ -- one. For File, there is only one chunk. When it is full, we send the
+ -- data to the file, and empty it.
+
+ type Chunk;
+ type Chunk_Access is access all Chunk;
+ type Chunk (Length : Positive) is limited record
+ Next : Chunk_Access := null;
+ Chars : UTF_8_Lines (1 .. Length);
+ end record;
+
+ type Sink (Chunk_Length : Positive) is abstract tagged limited record
+ Indent_Amount : Natural;
+ Column : Positive := 1;
+ Indentation : Natural := 0;
+
+ All_7_Bits : Boolean := True;
+ -- For optimization of Text_Output.Buffers.Get (cf).
+ -- True if all characters seen so far fit in 7 bits.
+ -- 7-bit characters are represented the same in Character
+ -- and in UTF-8, so they don't need translation.
+
+ All_8_Bits : Boolean := True;
+ -- True if all characters seen so far fit in 8 bits.
+ -- This is needed in Text_Output.Buffers.Get to distinguish
+ -- the case where all characters are Latin-1 (so it should
+ -- decode) from the case where some characters are bigger than
+ -- 8 bits (so the result is implementation defined).
+
+ Cur_Chunk : Chunk_Access;
+ -- Points to the chunk we are currently sending characters to.
+ -- We want to say:
+ -- Cur_Chunk : Chunk_Access := Initial_Chunk'Access;
+ -- but that's illegal, so we have some horsing around to do.
+
+ Last : Natural := 0;
+ -- Last-used character in Cur_Chunk.all.
+
+ Initial_Chunk : aliased Chunk (Length => Chunk_Length);
+ -- For Buffer, this is the first chunk. Subsequent chunks are allocated
+ -- on the heap. For File, this is the only chunk, and there is no heap
+ -- allocation.
+ end record;
+
+end Ada.Strings.Text_Output;
diff --git a/gcc/ada/libgnat/a-stunau.adb b/gcc/ada/libgnat/a-stunau.adb
index 761afe9..a0e2eda 100644
--- a/gcc/ada/libgnat/a-stunau.adb
+++ b/gcc/ada/libgnat/a-stunau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stunau.ads b/gcc/ada/libgnat/a-stunau.ads
index d3cf29f..bac37ef 100644
--- a/gcc/ada/libgnat/a-stunau.ads
+++ b/gcc/ada/libgnat/a-stunau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stunau__shared.adb b/gcc/ada/libgnat/a-stunau__shared.adb
index 2f3efb7..5f903f1 100644
--- a/gcc/ada/libgnat/a-stunau__shared.adb
+++ b/gcc/ada/libgnat/a-stunau__shared.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stunha.adb b/gcc/ada/libgnat/a-stunha.adb
index 59c76ab..e92ad27 100644
--- a/gcc/ada/libgnat/a-stunha.adb
+++ b/gcc/ada/libgnat/a-stunha.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stuten.adb b/gcc/ada/libgnat/a-stuten.adb
index 178827c..d6654b2 100644
--- a/gcc/ada/libgnat/a-stuten.adb
+++ b/gcc/ada/libgnat/a-stuten.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stwibo.adb b/gcc/ada/libgnat/a-stwibo.adb
index 30a6555..46e1b41 100644
--- a/gcc/ada/libgnat/a-stwibo.adb
+++ b/gcc/ada/libgnat/a-stwibo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stwibo.ads b/gcc/ada/libgnat/a-stwibo.ads
index e6c4e65..ba35134 100644
--- a/gcc/ada/libgnat/a-stwibo.ads
+++ b/gcc/ada/libgnat/a-stwibo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-stwifi.adb b/gcc/ada/libgnat/a-stwifi.adb
index ed81482..05e58e9 100644
--- a/gcc/ada/libgnat/a-stwifi.adb
+++ b/gcc/ada/libgnat/a-stwifi.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stwiha.adb b/gcc/ada/libgnat/a-stwiha.adb
index 47a9fab..b25614a 100644
--- a/gcc/ada/libgnat/a-stwiha.adb
+++ b/gcc/ada/libgnat/a-stwiha.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stwima.adb b/gcc/ada/libgnat/a-stwima.adb
index 514b6e5..1cc7d67 100644
--- a/gcc/ada/libgnat/a-stwima.adb
+++ b/gcc/ada/libgnat/a-stwima.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stwima.ads b/gcc/ada/libgnat/a-stwima.ads
index a37e578..24c6bb84 100644
--- a/gcc/ada/libgnat/a-stwima.ads
+++ b/gcc/ada/libgnat/a-stwima.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-stwise.adb b/gcc/ada/libgnat/a-stwise.adb
index 897591c..f93c5cb 100644
--- a/gcc/ada/libgnat/a-stwise.adb
+++ b/gcc/ada/libgnat/a-stwise.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stwise.ads b/gcc/ada/libgnat/a-stwise.ads
index 3491eff..0573157 100644
--- a/gcc/ada/libgnat/a-stwise.ads
+++ b/gcc/ada/libgnat/a-stwise.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stwisu.adb b/gcc/ada/libgnat/a-stwisu.adb
index a192005..8c343fe 100644
--- a/gcc/ada/libgnat/a-stwisu.adb
+++ b/gcc/ada/libgnat/a-stwisu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stwisu.ads b/gcc/ada/libgnat/a-stwisu.ads
index ee52f0d..387e012 100644
--- a/gcc/ada/libgnat/a-stwisu.ads
+++ b/gcc/ada/libgnat/a-stwisu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stwiun.adb b/gcc/ada/libgnat/a-stwiun.adb
index ded9d10..912af42 100644
--- a/gcc/ada/libgnat/a-stwiun.adb
+++ b/gcc/ada/libgnat/a-stwiun.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stwiun.ads b/gcc/ada/libgnat/a-stwiun.ads
index 9f2a273..00d5c3d 100644
--- a/gcc/ada/libgnat/a-stwiun.ads
+++ b/gcc/ada/libgnat/a-stwiun.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-stwiun__shared.adb b/gcc/ada/libgnat/a-stwiun__shared.adb
index 7fab387..b61139b1 100644
--- a/gcc/ada/libgnat/a-stwiun__shared.adb
+++ b/gcc/ada/libgnat/a-stwiun__shared.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stwiun__shared.ads b/gcc/ada/libgnat/a-stwiun__shared.ads
index ba01ffd..3d29939 100644
--- a/gcc/ada/libgnat/a-stwiun__shared.ads
+++ b/gcc/ada/libgnat/a-stwiun__shared.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-stzbou.adb b/gcc/ada/libgnat/a-stzbou.adb
index 403cc8b..60afeec 100644
--- a/gcc/ada/libgnat/a-stzbou.adb
+++ b/gcc/ada/libgnat/a-stzbou.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stzbou.ads b/gcc/ada/libgnat/a-stzbou.ads
index ffa0e48..f5bbcf3 100644
--- a/gcc/ada/libgnat/a-stzbou.ads
+++ b/gcc/ada/libgnat/a-stzbou.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-stzfix.adb b/gcc/ada/libgnat/a-stzfix.adb
index 0367994..ea97b13 100644
--- a/gcc/ada/libgnat/a-stzfix.adb
+++ b/gcc/ada/libgnat/a-stzfix.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stzhas.adb b/gcc/ada/libgnat/a-stzhas.adb
index 77d838b..43abb80 100644
--- a/gcc/ada/libgnat/a-stzhas.adb
+++ b/gcc/ada/libgnat/a-stzhas.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stzmap.adb b/gcc/ada/libgnat/a-stzmap.adb
index 76c4110..2e1cd5d 100644
--- a/gcc/ada/libgnat/a-stzmap.adb
+++ b/gcc/ada/libgnat/a-stzmap.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stzmap.ads b/gcc/ada/libgnat/a-stzmap.ads
index d0d2a1f..9cfa5ed 100644
--- a/gcc/ada/libgnat/a-stzmap.ads
+++ b/gcc/ada/libgnat/a-stzmap.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-stzsea.adb b/gcc/ada/libgnat/a-stzsea.adb
index 3c800c0..9982b75 100644
--- a/gcc/ada/libgnat/a-stzsea.adb
+++ b/gcc/ada/libgnat/a-stzsea.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stzsea.ads b/gcc/ada/libgnat/a-stzsea.ads
index 244cfb6..bdd27d5 100644
--- a/gcc/ada/libgnat/a-stzsea.ads
+++ b/gcc/ada/libgnat/a-stzsea.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stzsup.adb b/gcc/ada/libgnat/a-stzsup.adb
index ad2160a..e4558e5 100644
--- a/gcc/ada/libgnat/a-stzsup.adb
+++ b/gcc/ada/libgnat/a-stzsup.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stzsup.ads b/gcc/ada/libgnat/a-stzsup.ads
index a60ef64..b128010 100644
--- a/gcc/ada/libgnat/a-stzsup.ads
+++ b/gcc/ada/libgnat/a-stzsup.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stzunb.adb b/gcc/ada/libgnat/a-stzunb.adb
index e795826..f32b3ed 100644
--- a/gcc/ada/libgnat/a-stzunb.adb
+++ b/gcc/ada/libgnat/a-stzunb.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stzunb.ads b/gcc/ada/libgnat/a-stzunb.ads
index 3dc490c9..7ee8a56 100644
--- a/gcc/ada/libgnat/a-stzunb.ads
+++ b/gcc/ada/libgnat/a-stzunb.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-stzunb__shared.adb b/gcc/ada/libgnat/a-stzunb__shared.adb
index f88a4c5..86bed5c 100644
--- a/gcc/ada/libgnat/a-stzunb__shared.adb
+++ b/gcc/ada/libgnat/a-stzunb__shared.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-stzunb__shared.ads b/gcc/ada/libgnat/a-stzunb__shared.ads
index d062d46..5079d63 100644
--- a/gcc/ada/libgnat/a-stzunb__shared.ads
+++ b/gcc/ada/libgnat/a-stzunb__shared.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-suecin.adb b/gcc/ada/libgnat/a-suecin.adb
index 4ea16c2..4336538 100644
--- a/gcc/ada/libgnat/a-suecin.adb
+++ b/gcc/ada/libgnat/a-suecin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-suecin.ads b/gcc/ada/libgnat/a-suecin.ads
index b4085b8..6578191 100644
--- a/gcc/ada/libgnat/a-suecin.ads
+++ b/gcc/ada/libgnat/a-suecin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-suenco.adb b/gcc/ada/libgnat/a-suenco.adb
index 47dee2e..6d30f84 100644
--- a/gcc/ada/libgnat/a-suenco.adb
+++ b/gcc/ada/libgnat/a-suenco.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-suenst.adb b/gcc/ada/libgnat/a-suenst.adb
index 12793c4..ff730e8 100644
--- a/gcc/ada/libgnat/a-suenst.adb
+++ b/gcc/ada/libgnat/a-suenst.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-suewst.adb b/gcc/ada/libgnat/a-suewst.adb
index ed9817f..25a671a 100644
--- a/gcc/ada/libgnat/a-suewst.adb
+++ b/gcc/ada/libgnat/a-suewst.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-suezst.adb b/gcc/ada/libgnat/a-suezst.adb
index bba805f..951a171 100644
--- a/gcc/ada/libgnat/a-suezst.adb
+++ b/gcc/ada/libgnat/a-suezst.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-suhcin.adb b/gcc/ada/libgnat/a-suhcin.adb
index f1dc0f7..98de7a1 100644
--- a/gcc/ada/libgnat/a-suhcin.adb
+++ b/gcc/ada/libgnat/a-suhcin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-suhcin.ads b/gcc/ada/libgnat/a-suhcin.ads
index b06655c..20aa236 100644
--- a/gcc/ada/libgnat/a-suhcin.ads
+++ b/gcc/ada/libgnat/a-suhcin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-sulcin.adb b/gcc/ada/libgnat/a-sulcin.adb
index 096b759..10df730 100644
--- a/gcc/ada/libgnat/a-sulcin.adb
+++ b/gcc/ada/libgnat/a-sulcin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-sulcin.ads b/gcc/ada/libgnat/a-sulcin.ads
index 220ffdc9..174ec4b 100644
--- a/gcc/ada/libgnat/a-sulcin.ads
+++ b/gcc/ada/libgnat/a-sulcin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-suteio.adb b/gcc/ada/libgnat/a-suteio.adb
index 4571692..28d8435 100644
--- a/gcc/ada/libgnat/a-suteio.adb
+++ b/gcc/ada/libgnat/a-suteio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-suteio.ads b/gcc/ada/libgnat/a-suteio.ads
index 64d43de..fda5b3c 100644
--- a/gcc/ada/libgnat/a-suteio.ads
+++ b/gcc/ada/libgnat/a-suteio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-suteio__shared.adb b/gcc/ada/libgnat/a-suteio__shared.adb
index 9847757..fc28aaa 100644
--- a/gcc/ada/libgnat/a-suteio__shared.adb
+++ b/gcc/ada/libgnat/a-suteio__shared.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-swbwha.adb b/gcc/ada/libgnat/a-swbwha.adb
index 2c1574c..7ad420c 100644
--- a/gcc/ada/libgnat/a-swbwha.adb
+++ b/gcc/ada/libgnat/a-swbwha.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-swmwco.ads b/gcc/ada/libgnat/a-swmwco.ads
index 08eda0d..9e71851 100644
--- a/gcc/ada/libgnat/a-swmwco.ads
+++ b/gcc/ada/libgnat/a-swmwco.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-swunau.adb b/gcc/ada/libgnat/a-swunau.adb
index 59520d8..e77a34c 100644
--- a/gcc/ada/libgnat/a-swunau.adb
+++ b/gcc/ada/libgnat/a-swunau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-swunau.ads b/gcc/ada/libgnat/a-swunau.ads
index 8160a8f..a2bf6d1 100644
--- a/gcc/ada/libgnat/a-swunau.ads
+++ b/gcc/ada/libgnat/a-swunau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-swunau__shared.adb b/gcc/ada/libgnat/a-swunau__shared.adb
index 2cd6395..16ffd82 100644
--- a/gcc/ada/libgnat/a-swunau__shared.adb
+++ b/gcc/ada/libgnat/a-swunau__shared.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-swuwha.adb b/gcc/ada/libgnat/a-swuwha.adb
index 935eb47..2ff28b0 100644
--- a/gcc/ada/libgnat/a-swuwha.adb
+++ b/gcc/ada/libgnat/a-swuwha.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-swuwti.adb b/gcc/ada/libgnat/a-swuwti.adb
index df238e5..e664d3d 100644
--- a/gcc/ada/libgnat/a-swuwti.adb
+++ b/gcc/ada/libgnat/a-swuwti.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-swuwti.ads b/gcc/ada/libgnat/a-swuwti.ads
index bcf3b20..6eb9e58 100644
--- a/gcc/ada/libgnat/a-swuwti.ads
+++ b/gcc/ada/libgnat/a-swuwti.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-swuwti__shared.adb b/gcc/ada/libgnat/a-swuwti__shared.adb
index 4b606b2..96680e2 100644
--- a/gcc/ada/libgnat/a-swuwti__shared.adb
+++ b/gcc/ada/libgnat/a-swuwti__shared.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-szbzha.adb b/gcc/ada/libgnat/a-szbzha.adb
index b28689f..e6f6936 100644
--- a/gcc/ada/libgnat/a-szbzha.adb
+++ b/gcc/ada/libgnat/a-szbzha.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-szmzco.ads b/gcc/ada/libgnat/a-szmzco.ads
index ae560cf..eaaf116 100644
--- a/gcc/ada/libgnat/a-szmzco.ads
+++ b/gcc/ada/libgnat/a-szmzco.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-szunau.adb b/gcc/ada/libgnat/a-szunau.adb
index e9b7864..f9c263e 100644
--- a/gcc/ada/libgnat/a-szunau.adb
+++ b/gcc/ada/libgnat/a-szunau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-szunau.ads b/gcc/ada/libgnat/a-szunau.ads
index d791b8e..2795dbe 100644
--- a/gcc/ada/libgnat/a-szunau.ads
+++ b/gcc/ada/libgnat/a-szunau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-szunau__shared.adb b/gcc/ada/libgnat/a-szunau__shared.adb
index a46d632..fcd14eb 100644
--- a/gcc/ada/libgnat/a-szunau__shared.adb
+++ b/gcc/ada/libgnat/a-szunau__shared.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-szuzha.adb b/gcc/ada/libgnat/a-szuzha.adb
index 4666bcc..00cad7c 100644
--- a/gcc/ada/libgnat/a-szuzha.adb
+++ b/gcc/ada/libgnat/a-szuzha.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-szuzti.adb b/gcc/ada/libgnat/a-szuzti.adb
index bd42c76..239d319 100644
--- a/gcc/ada/libgnat/a-szuzti.adb
+++ b/gcc/ada/libgnat/a-szuzti.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-szuzti.ads b/gcc/ada/libgnat/a-szuzti.ads
index 69d63b4..0e7f1f5 100644
--- a/gcc/ada/libgnat/a-szuzti.ads
+++ b/gcc/ada/libgnat/a-szuzti.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-szuzti__shared.adb b/gcc/ada/libgnat/a-szuzti__shared.adb
index 5690294..9f486e2 100644
--- a/gcc/ada/libgnat/a-szuzti__shared.adb
+++ b/gcc/ada/libgnat/a-szuzti__shared.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tags.adb b/gcc/ada/libgnat/a-tags.adb
index 4c99523..798780a 100644
--- a/gcc/ada/libgnat/a-tags.adb
+++ b/gcc/ada/libgnat/a-tags.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -49,10 +49,6 @@ package body Ada.Tags is
-- Local Subprograms --
-----------------------
- function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
- -- Given the tag of an object and the tag associated to a type, return
- -- true if Obj is in Typ'Class.
-
function Get_External_Tag (T : Tag) return System.Address;
-- Returns address of a null terminated string containing the external name
@@ -82,7 +78,6 @@ package body Ada.Tags is
-- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the
-- address of the record containing the Select Specific Data in T's TSD.
- pragma Inline_Always (CW_Membership);
pragma Inline_Always (Get_External_Tag);
pragma Inline_Always (Is_Primary_DT);
pragma Inline_Always (OSD);
diff --git a/gcc/ada/libgnat/a-tags.ads b/gcc/ada/libgnat/a-tags.ads
index 8799a31..fb386c3 100644
--- a/gcc/ada/libgnat/a-tags.ads
+++ b/gcc/ada/libgnat/a-tags.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -501,6 +501,10 @@ private
-- dispatch table, return the tagged kind of a type in the context of
-- concurrency and limitedness.
+ function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
+ -- Given the tag of an object and the tag associated to a type, return
+ -- true if Obj is in Typ'Class.
+
function IW_Membership (This : System.Address; T : Tag) return Boolean;
-- Ada 2005 (AI-251): General routine that checks if a given object
-- implements a tagged type. Its common usage is to check if Obj is in
@@ -588,7 +592,7 @@ private
procedure Unregister_Tag (T : Tag);
-- Remove a particular tag from the external tag hash table
- Max_Predef_Prims : constant Positive := 15;
+ Max_Predef_Prims : constant Positive := 16;
-- Number of reserved slots for the following predefined ada primitives:
--
-- 1. Size
@@ -600,12 +604,13 @@ private
-- 7. assignment
-- 8. deep adjust
-- 9. deep finalize
- -- 10. async select
- -- 11. conditional select
- -- 12. prim_op kind
- -- 13. task_id
- -- 14. dispatching requeue
- -- 15. timed select
+ -- 10. Put_Image
+ -- 11. async select
+ -- 12. conditional select
+ -- 13. prim_op kind
+ -- 14. task_id
+ -- 15. dispatching requeue
+ -- 16. timed select
--
-- The compiler checks that the value here is correct
diff --git a/gcc/ada/libgnat/a-teioed.adb b/gcc/ada/libgnat/a-teioed.adb
index ca70075..f3b0928 100644
--- a/gcc/ada/libgnat/a-teioed.adb
+++ b/gcc/ada/libgnat/a-teioed.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-teioed.ads b/gcc/ada/libgnat/a-teioed.ads
index 6f1652f..273291e 100644
--- a/gcc/ada/libgnat/a-teioed.ads
+++ b/gcc/ada/libgnat/a-teioed.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-textio.adb b/gcc/ada/libgnat/a-textio.adb
index 276be12..b36d28b 100644
--- a/gcc/ada/libgnat/a-textio.adb
+++ b/gcc/ada/libgnat/a-textio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-textio.ads b/gcc/ada/libgnat/a-textio.ads
index a2e1daf..6e5e392 100644
--- a/gcc/ada/libgnat/a-textio.ads
+++ b/gcc/ada/libgnat/a-textio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -70,7 +70,7 @@ is
-- used in this package and System.File_IO.
for File_Mode use
- (In_File => 0, -- System.FIle_IO.File_Mode'Pos (In_File)
+ (In_File => 0, -- System.File_IO.File_Mode'Pos (In_File)
Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File)
Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File)
diff --git a/gcc/ada/libgnat/a-tiboio.adb b/gcc/ada/libgnat/a-tiboio.adb
index bee738e..e212356 100644
--- a/gcc/ada/libgnat/a-tiboio.adb
+++ b/gcc/ada/libgnat/a-tiboio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ticoau.adb b/gcc/ada/libgnat/a-ticoau.adb
index ad3b4d3..e4f56dd 100644
--- a/gcc/ada/libgnat/a-ticoau.adb
+++ b/gcc/ada/libgnat/a-ticoau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ticoau.ads b/gcc/ada/libgnat/a-ticoau.ads
index 01d387c..739dce8 100644
--- a/gcc/ada/libgnat/a-ticoau.ads
+++ b/gcc/ada/libgnat/a-ticoau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ticoio.adb b/gcc/ada/libgnat/a-ticoio.adb
index 0758479..fa52b60 100644
--- a/gcc/ada/libgnat/a-ticoio.adb
+++ b/gcc/ada/libgnat/a-ticoio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ticoio.ads b/gcc/ada/libgnat/a-ticoio.ads
index 5c37f8f..b0e3d8c 100644
--- a/gcc/ada/libgnat/a-ticoio.ads
+++ b/gcc/ada/libgnat/a-ticoio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-tideau.adb b/gcc/ada/libgnat/a-tideau.adb
index debaeda..caf77e3 100644
--- a/gcc/ada/libgnat/a-tideau.adb
+++ b/gcc/ada/libgnat/a-tideau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tideau.ads b/gcc/ada/libgnat/a-tideau.ads
index 2205ffc..e7d7f44 100644
--- a/gcc/ada/libgnat/a-tideau.ads
+++ b/gcc/ada/libgnat/a-tideau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tideio.adb b/gcc/ada/libgnat/a-tideio.adb
index 3497080..0624c2c 100644
--- a/gcc/ada/libgnat/a-tideio.adb
+++ b/gcc/ada/libgnat/a-tideio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tideio.ads b/gcc/ada/libgnat/a-tideio.ads
index efe52c5..83e72aa 100644
--- a/gcc/ada/libgnat/a-tideio.ads
+++ b/gcc/ada/libgnat/a-tideio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-tienau.adb b/gcc/ada/libgnat/a-tienau.adb
index d9cf888..87dce4b 100644
--- a/gcc/ada/libgnat/a-tienau.adb
+++ b/gcc/ada/libgnat/a-tienau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tienau.ads b/gcc/ada/libgnat/a-tienau.ads
index 236d05f..27b15c1 100644
--- a/gcc/ada/libgnat/a-tienau.ads
+++ b/gcc/ada/libgnat/a-tienau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tienio.adb b/gcc/ada/libgnat/a-tienio.adb
index 55c87f3..adc93db 100644
--- a/gcc/ada/libgnat/a-tienio.adb
+++ b/gcc/ada/libgnat/a-tienio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tifiio.adb b/gcc/ada/libgnat/a-tifiio.adb
index d048646..4098f0e 100644
--- a/gcc/ada/libgnat/a-tifiio.adb
+++ b/gcc/ada/libgnat/a-tifiio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tiflau.adb b/gcc/ada/libgnat/a-tiflau.adb
index d3ef65c..214b5c8 100644
--- a/gcc/ada/libgnat/a-tiflau.adb
+++ b/gcc/ada/libgnat/a-tiflau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -194,7 +194,7 @@ package body Ada.Text_IO.Float_Aux is
Aft : Field;
Exp : Field)
is
- Buf : String (1 .. 3 * Field'Last + 2);
+ Buf : String (1 .. Max_Real_Image_Length);
Ptr : Natural := 0;
begin
@@ -212,7 +212,7 @@ package body Ada.Text_IO.Float_Aux is
Aft : Field;
Exp : Field)
is
- Buf : String (1 .. 3 * Field'Last + 2);
+ Buf : String (1 .. Max_Real_Image_Length);
Ptr : Natural := 0;
begin
diff --git a/gcc/ada/libgnat/a-tiflau.ads b/gcc/ada/libgnat/a-tiflau.ads
index 558df2e..68ac9eb 100644
--- a/gcc/ada/libgnat/a-tiflau.ads
+++ b/gcc/ada/libgnat/a-tiflau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tiflio.adb b/gcc/ada/libgnat/a-tiflio.adb
index 23d31f7..0daa044 100644
--- a/gcc/ada/libgnat/a-tiflio.adb
+++ b/gcc/ada/libgnat/a-tiflio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tiflio.ads b/gcc/ada/libgnat/a-tiflio.ads
index 16e65a5..bd4c64f64 100644
--- a/gcc/ada/libgnat/a-tiflio.ads
+++ b/gcc/ada/libgnat/a-tiflio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-tigeau.adb b/gcc/ada/libgnat/a-tigeau.adb
index 462058c9..c7f719a 100644
--- a/gcc/ada/libgnat/a-tigeau.adb
+++ b/gcc/ada/libgnat/a-tigeau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tigeau.ads b/gcc/ada/libgnat/a-tigeau.ads
index 90ccb72..32b5fe3 100644
--- a/gcc/ada/libgnat/a-tigeau.ads
+++ b/gcc/ada/libgnat/a-tigeau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tigeli.adb b/gcc/ada/libgnat/a-tigeli.adb
index 4562ca9..3dad18b 100644
--- a/gcc/ada/libgnat/a-tigeli.adb
+++ b/gcc/ada/libgnat/a-tigeli.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tiinau.adb b/gcc/ada/libgnat/a-tiinau.adb
index 8fe2f75..d09b456 100644
--- a/gcc/ada/libgnat/a-tiinau.adb
+++ b/gcc/ada/libgnat/a-tiinau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tiinau.ads b/gcc/ada/libgnat/a-tiinau.ads
index fd5ffb4..fda5b68 100644
--- a/gcc/ada/libgnat/a-tiinau.ads
+++ b/gcc/ada/libgnat/a-tiinau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tiinio.adb b/gcc/ada/libgnat/a-tiinio.adb
index a62f925..c71b4bf 100644
--- a/gcc/ada/libgnat/a-tiinio.adb
+++ b/gcc/ada/libgnat/a-tiinio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tiinio.ads b/gcc/ada/libgnat/a-tiinio.ads
index 28f8d54..2998764 100644
--- a/gcc/ada/libgnat/a-tiinio.ads
+++ b/gcc/ada/libgnat/a-tiinio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-timoau.adb b/gcc/ada/libgnat/a-timoau.adb
index d42a18c..050b9c8 100644
--- a/gcc/ada/libgnat/a-timoau.adb
+++ b/gcc/ada/libgnat/a-timoau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-timoau.ads b/gcc/ada/libgnat/a-timoau.ads
index 973fb75..247eb14 100644
--- a/gcc/ada/libgnat/a-timoau.ads
+++ b/gcc/ada/libgnat/a-timoau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-timoio.adb b/gcc/ada/libgnat/a-timoio.adb
index d6e9c95..0cdeef1 100644
--- a/gcc/ada/libgnat/a-timoio.adb
+++ b/gcc/ada/libgnat/a-timoio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-timoio.ads b/gcc/ada/libgnat/a-timoio.ads
index 2d1ab91..aa1de6b 100644
--- a/gcc/ada/libgnat/a-timoio.ads
+++ b/gcc/ada/libgnat/a-timoio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1993-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1993-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-tiocst.adb b/gcc/ada/libgnat/a-tiocst.adb
index 0051235..aea0995 100644
--- a/gcc/ada/libgnat/a-tiocst.adb
+++ b/gcc/ada/libgnat/a-tiocst.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tiocst.ads b/gcc/ada/libgnat/a-tiocst.ads
index 0f678dd..0f4f8a5 100644
--- a/gcc/ada/libgnat/a-tiocst.ads
+++ b/gcc/ada/libgnat/a-tiocst.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tirsfi.adb b/gcc/ada/libgnat/a-tirsfi.adb
index 4fe3bc7..a5d217c 100644
--- a/gcc/ada/libgnat/a-tirsfi.adb
+++ b/gcc/ada/libgnat/a-tirsfi.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-tirsfi.ads b/gcc/ada/libgnat/a-tirsfi.ads
index 2ce7e59..e3f8caa 100644
--- a/gcc/ada/libgnat/a-tirsfi.ads
+++ b/gcc/ada/libgnat/a-tirsfi.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-titest.adb b/gcc/ada/libgnat/a-titest.adb
index 3d03981..e0d13dc 100644
--- a/gcc/ada/libgnat/a-titest.adb
+++ b/gcc/ada/libgnat/a-titest.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-undesu.adb b/gcc/ada/libgnat/a-undesu.adb
index 5bcbd00..8fd8a77 100644
--- a/gcc/ada/libgnat/a-undesu.adb
+++ b/gcc/ada/libgnat/a-undesu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wichha.adb b/gcc/ada/libgnat/a-wichha.adb
index 3c01a2d..feccc23 100644
--- a/gcc/ada/libgnat/a-wichha.adb
+++ b/gcc/ada/libgnat/a-wichha.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -51,6 +51,13 @@ package body Ada.Wide_Characters.Handling is
return Is_Letter (Item) or else Is_Digit (Item);
end Is_Alphanumeric;
+ --------------
+ -- Is_Basic --
+ --------------
+
+ function Is_Basic (Item : Wide_Character) return Boolean
+ renames Ada.Wide_Characters.Unicode.Is_Basic;
+
----------------
-- Is_Control --
----------------
@@ -117,6 +124,13 @@ package body Ada.Wide_Characters.Handling is
function Is_Mark (Item : Wide_Character) return Boolean
renames Ada.Wide_Characters.Unicode.Is_Mark;
+ -------------
+ -- Is_NFKC --
+ -------------
+
+ function Is_NFKC (Item : Wide_Character) return Boolean
+ renames Ada.Wide_Characters.Unicode.Is_NFKC;
+
---------------------
-- Is_Other_Format --
---------------------
@@ -192,4 +206,22 @@ package body Ada.Wide_Characters.Handling is
return Result;
end To_Upper;
+ --------------
+ -- To_Basic --
+ --------------
+
+ function To_Basic (Item : Wide_Character) return Wide_Character
+ renames Ada.Wide_Characters.Unicode.To_Basic;
+
+ function To_Basic (Item : Wide_String) return Wide_String is
+ Result : Wide_String (Item'Range);
+
+ begin
+ for J in Result'Range loop
+ Result (J) := To_Basic (Item (J));
+ end loop;
+
+ return Result;
+ end To_Basic;
+
end Ada.Wide_Characters.Handling;
diff --git a/gcc/ada/libgnat/a-wichha.ads b/gcc/ada/libgnat/a-wichha.ads
index a906e02..23eb468 100644
--- a/gcc/ada/libgnat/a-wichha.ads
+++ b/gcc/ada/libgnat/a-wichha.ads
@@ -43,6 +43,12 @@ package Ada.Wide_Characters.Handling is
-- Returns True if the Wide_Character designated by Item is categorized as
-- letter_uppercase, otherwise returns False.
+ function Is_Basic (Item : Wide_Character) return Boolean;
+ pragma Inline (Is_Basic);
+ -- Returns True if the Wide_Character designated by Item has no
+ -- Decomposition Mapping in the code charts of ISO/IEC 10646:2017,
+ -- otherwise returns False.
+
function Is_Digit (Item : Wide_Character) return Boolean;
pragma Inline (Is_Digit);
-- Returns True if the Wide_Character designated by Item is categorized as
@@ -95,6 +101,12 @@ package Ada.Wide_Characters.Handling is
-- Returns True if the Wide_Character designated by Item is categorized as
-- separator_space, otherwise returns False.
+ function Is_NFKC (Item : Wide_Character) return Boolean;
+ pragma Inline (Is_NFKC);
+ -- Returns True if the Wide_Character designated by Item could be present
+ -- in a string normalized to Normalization Form KC (as defined by Clause
+ -- 21 of ISO/IEC 10646:2017), otherwise returns False.
+
function Is_Graphic (Item : Wide_Character) return Boolean;
pragma Inline (Is_Graphic);
-- Returns True if the Wide_Character designated by Item is categorized as
@@ -124,4 +136,16 @@ package Ada.Wide_Characters.Handling is
-- by Item. The result is the null Wide_String if the value of the formal
-- parameter is the null Wide_String.
+ function To_Basic (Item : Wide_Character) return Wide_Character;
+ pragma Inline (To_Basic);
+ -- Returns the Wide_Character whose code point is given by the first value
+ -- of its Decomposition Mapping in the code charts of ISO/IEC 10646:2017 if
+ -- any, returns Item otherwise.
+
+ function To_Basic (Item : Wide_String) return Wide_String;
+ -- Returns the result of applying the To_Basic conversion to each
+ -- Wide_Character element of the Wide_String designated by Item. The result
+ -- is the null Wide_String if the value of the formal parameter is the null
+ -- Wide_String. The lower bound of the result Wide_String is 1.
+
end Ada.Wide_Characters.Handling;
diff --git a/gcc/ada/libgnat/a-wichun.adb b/gcc/ada/libgnat/a-wichun.adb
index 75880ab..09cbad2 100644
--- a/gcc/ada/libgnat/a-wichun.adb
+++ b/gcc/ada/libgnat/a-wichun.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -43,6 +43,15 @@ package body Ada.Wide_Characters.Unicode is
end Get_Category;
--------------
+ -- Is_Basic --
+ --------------
+
+ function Is_Basic (U : Wide_Character) return Boolean is
+ begin
+ return G.Is_UTF_32_Basic (Wide_Character'Pos (U));
+ end Is_Basic;
+
+ --------------
-- Is_Digit --
--------------
@@ -107,6 +116,15 @@ package body Ada.Wide_Characters.Unicode is
return G.Is_UTF_32_Non_Graphic (G.Category (C));
end Is_Non_Graphic;
+ -------------
+ -- Is_NFKC --
+ -------------
+
+ function Is_NFKC (U : Wide_Character) return Boolean is
+ begin
+ return G.Is_UTF_32_NFKC (Wide_Character'Pos (U));
+ end Is_NFKC;
+
--------------
-- Is_Other --
--------------
@@ -149,26 +167,30 @@ package body Ada.Wide_Characters.Unicode is
return G.Is_UTF_32_Space (G.Category (C));
end Is_Space;
+ --------------
+ -- To_Basic --
+ --------------
+
+ function To_Basic (U : Wide_Character) return Wide_Character is
+ begin
+ return Wide_Character'Val (G.UTF_32_To_Basic (Wide_Character'Pos (U)));
+ end To_Basic;
+
-------------------
-- To_Lower_Case --
-------------------
- function To_Lower_Case
- (U : Wide_Character) return Wide_Character
- is
+ function To_Lower_Case (U : Wide_Character) return Wide_Character is
begin
return
- Wide_Character'Val
- (G.UTF_32_To_Lower_Case (Wide_Character'Pos (U)));
+ Wide_Character'Val (G.UTF_32_To_Lower_Case (Wide_Character'Pos (U)));
end To_Lower_Case;
-------------------
-- To_Upper_Case --
-------------------
- function To_Upper_Case
- (U : Wide_Character) return Wide_Character
- is
+ function To_Upper_Case (U : Wide_Character) return Wide_Character is
begin
return
Wide_Character'Val
diff --git a/gcc/ada/libgnat/a-wichun.ads b/gcc/ada/libgnat/a-wichun.ads
index 7a9f597..9e42749 100644
--- a/gcc/ada/libgnat/a-wichun.ads
+++ b/gcc/ada/libgnat/a-wichun.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -131,7 +131,7 @@ package Ada.Wide_Characters.Unicode is
pragma Inline (Is_Other);
-- Returns true iff U is an other format character, which means that it
-- can be used to extend an identifier, but is ignored for the purposes of
- -- matching of identiers, or if C is one of the corresponding categories,
+ -- matching of identifiers, or if C is one of the corresponding categories,
-- which are the following:
-- Other, Format (Cf)
@@ -150,6 +150,12 @@ package Ada.Wide_Characters.Unicode is
-- of the corresponding categories, which are the following:
-- Separator, Space (Zs)
+ function Is_NFKC (U : Wide_Character) return Boolean;
+ pragma Inline (Is_NFKC);
+ -- Returns True if the Wide_Character designated by U could be present
+ -- in a string normalized to Normalization Form KC (as defined by Clause
+ -- 21 of ISO/IEC 10646:2017), otherwise returns False.
+
function Is_Non_Graphic (U : Wide_Character) return Boolean;
function Is_Non_Graphic (C : Category) return Boolean;
pragma Inline (Is_Non_Graphic);
@@ -174,6 +180,18 @@ package Ada.Wide_Characters.Unicode is
-- in the list of categories above. This means that these characters can
-- be included in character and string literals.
+ function Is_Basic (U : Wide_Character) return Boolean;
+ pragma Inline (Is_Basic);
+ -- Returns True if the Wide_Character designated by Item has no
+ -- Decomposition Mapping in the code charts of ISO/IEC 10646:2017,
+ -- otherwise returns False.
+
+ function To_Basic (U : Wide_Character) return Wide_Character;
+ pragma Inline (To_Basic);
+ -- Returns the Wide_Character whose code point is given by the first value
+ -- of its Decomposition Mapping in the code charts of ISO/IEC 10646:2017 if
+ -- any, returns Item otherwise.
+
-- The following function is used to fold to upper case, as required by
-- the Ada 2005 standard rules for identifier case folding. Two
-- identifiers are equivalent if they are identical after folding all
diff --git a/gcc/ada/libgnat/a-witeio.adb b/gcc/ada/libgnat/a-witeio.adb
index ef97f3d..6bc3f48 100644
--- a/gcc/ada/libgnat/a-witeio.adb
+++ b/gcc/ada/libgnat/a-witeio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-witeio.ads b/gcc/ada/libgnat/a-witeio.ads
index c34f290..9dcfda0 100644
--- a/gcc/ada/libgnat/a-witeio.ads
+++ b/gcc/ada/libgnat/a-witeio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-wrstfi.adb b/gcc/ada/libgnat/a-wrstfi.adb
index 7c5f460..95e66ba 100644
--- a/gcc/ada/libgnat/a-wrstfi.adb
+++ b/gcc/ada/libgnat/a-wrstfi.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wrstfi.ads b/gcc/ada/libgnat/a-wrstfi.ads
index fdd40c6..e8bf4d1 100644
--- a/gcc/ada/libgnat/a-wrstfi.ads
+++ b/gcc/ada/libgnat/a-wrstfi.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtcoau.adb b/gcc/ada/libgnat/a-wtcoau.adb
index cf5946f..a60336b 100644
--- a/gcc/ada/libgnat/a-wtcoau.adb
+++ b/gcc/ada/libgnat/a-wtcoau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtcoau.ads b/gcc/ada/libgnat/a-wtcoau.ads
index af75a99..781dd8d 100644
--- a/gcc/ada/libgnat/a-wtcoau.ads
+++ b/gcc/ada/libgnat/a-wtcoau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtcoio.adb b/gcc/ada/libgnat/a-wtcoio.adb
index 228d66a..c1c3b94 100644
--- a/gcc/ada/libgnat/a-wtcoio.adb
+++ b/gcc/ada/libgnat/a-wtcoio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtcstr.adb b/gcc/ada/libgnat/a-wtcstr.adb
index ddcc8f3..c039677 100644
--- a/gcc/ada/libgnat/a-wtcstr.adb
+++ b/gcc/ada/libgnat/a-wtcstr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtcstr.ads b/gcc/ada/libgnat/a-wtcstr.ads
index 73b5ecc..414a5e9 100644
--- a/gcc/ada/libgnat/a-wtcstr.ads
+++ b/gcc/ada/libgnat/a-wtcstr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtdeau.adb b/gcc/ada/libgnat/a-wtdeau.adb
index 36b9a71..7bfc613 100644
--- a/gcc/ada/libgnat/a-wtdeau.adb
+++ b/gcc/ada/libgnat/a-wtdeau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtdeau.ads b/gcc/ada/libgnat/a-wtdeau.ads
index a3dcaa9..0465455 100644
--- a/gcc/ada/libgnat/a-wtdeau.ads
+++ b/gcc/ada/libgnat/a-wtdeau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtdeio.adb b/gcc/ada/libgnat/a-wtdeio.adb
index 5d2f91d..845a217 100644
--- a/gcc/ada/libgnat/a-wtdeio.adb
+++ b/gcc/ada/libgnat/a-wtdeio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtedit.adb b/gcc/ada/libgnat/a-wtedit.adb
index 42cecb7..e8a4b57 100644
--- a/gcc/ada/libgnat/a-wtedit.adb
+++ b/gcc/ada/libgnat/a-wtedit.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtedit.ads b/gcc/ada/libgnat/a-wtedit.ads
index b0e1c7e..4d74578 100644
--- a/gcc/ada/libgnat/a-wtedit.ads
+++ b/gcc/ada/libgnat/a-wtedit.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-wtenau.adb b/gcc/ada/libgnat/a-wtenau.adb
index 939d5a4..3fb6f76 100644
--- a/gcc/ada/libgnat/a-wtenau.adb
+++ b/gcc/ada/libgnat/a-wtenau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtenau.ads b/gcc/ada/libgnat/a-wtenau.ads
index efa09a2..b9b7566 100644
--- a/gcc/ada/libgnat/a-wtenau.ads
+++ b/gcc/ada/libgnat/a-wtenau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtenio.adb b/gcc/ada/libgnat/a-wtenio.adb
index e9ec829..ee500f9 100644
--- a/gcc/ada/libgnat/a-wtenio.adb
+++ b/gcc/ada/libgnat/a-wtenio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtfiio.adb b/gcc/ada/libgnat/a-wtfiio.adb
index c9e7a38..f70c8e4 100644
--- a/gcc/ada/libgnat/a-wtfiio.adb
+++ b/gcc/ada/libgnat/a-wtfiio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtflau.adb b/gcc/ada/libgnat/a-wtflau.adb
index 0011e52..fd9ff1a 100644
--- a/gcc/ada/libgnat/a-wtflau.adb
+++ b/gcc/ada/libgnat/a-wtflau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtflau.ads b/gcc/ada/libgnat/a-wtflau.ads
index db1032c..3598f77 100644
--- a/gcc/ada/libgnat/a-wtflau.ads
+++ b/gcc/ada/libgnat/a-wtflau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtflio.adb b/gcc/ada/libgnat/a-wtflio.adb
index 98542e3..5a36d88 100644
--- a/gcc/ada/libgnat/a-wtflio.adb
+++ b/gcc/ada/libgnat/a-wtflio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtgeau.adb b/gcc/ada/libgnat/a-wtgeau.adb
index f271daf..45eef92 100644
--- a/gcc/ada/libgnat/a-wtgeau.adb
+++ b/gcc/ada/libgnat/a-wtgeau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtgeau.ads b/gcc/ada/libgnat/a-wtgeau.ads
index fa9b2e2..ba8509b 100644
--- a/gcc/ada/libgnat/a-wtgeau.ads
+++ b/gcc/ada/libgnat/a-wtgeau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtinau.adb b/gcc/ada/libgnat/a-wtinau.adb
index 1fe968e..53e8163 100644
--- a/gcc/ada/libgnat/a-wtinau.adb
+++ b/gcc/ada/libgnat/a-wtinau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtinau.ads b/gcc/ada/libgnat/a-wtinau.ads
index bec6e03..691a877 100644
--- a/gcc/ada/libgnat/a-wtinau.ads
+++ b/gcc/ada/libgnat/a-wtinau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtinio.adb b/gcc/ada/libgnat/a-wtinio.adb
index cb0dde0..bc03227 100644
--- a/gcc/ada/libgnat/a-wtinio.adb
+++ b/gcc/ada/libgnat/a-wtinio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtmoau.adb b/gcc/ada/libgnat/a-wtmoau.adb
index 12dd532..9039798 100644
--- a/gcc/ada/libgnat/a-wtmoau.adb
+++ b/gcc/ada/libgnat/a-wtmoau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtmoau.ads b/gcc/ada/libgnat/a-wtmoau.ads
index e89bb5b..9fe444e 100644
--- a/gcc/ada/libgnat/a-wtmoau.ads
+++ b/gcc/ada/libgnat/a-wtmoau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtmoio.adb b/gcc/ada/libgnat/a-wtmoio.adb
index ec82562..629f95d 100644
--- a/gcc/ada/libgnat/a-wtmoio.adb
+++ b/gcc/ada/libgnat/a-wtmoio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wtmoio.ads b/gcc/ada/libgnat/a-wtmoio.ads
index 68f7ff7..b28aacd 100644
--- a/gcc/ada/libgnat/a-wtmoio.ads
+++ b/gcc/ada/libgnat/a-wtmoio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
diff --git a/gcc/ada/libgnat/a-wttest.adb b/gcc/ada/libgnat/a-wttest.adb
index cf5f0d9..01b6688 100644
--- a/gcc/ada/libgnat/a-wttest.adb
+++ b/gcc/ada/libgnat/a-wttest.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-wwboio.adb b/gcc/ada/libgnat/a-wwboio.adb
index 7b73357..4602596 100644
--- a/gcc/ada/libgnat/a-wwboio.adb
+++ b/gcc/ada/libgnat/a-wwboio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-zchhan.adb b/gcc/ada/libgnat/a-zchhan.adb
index 7acd07d..6930121 100644
--- a/gcc/ada/libgnat/a-zchhan.adb
+++ b/gcc/ada/libgnat/a-zchhan.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -108,6 +108,13 @@ package body Ada.Wide_Wide_Characters.Handling is
function Is_Mark (Item : Wide_Wide_Character) return Boolean
renames Ada.Wide_Wide_Characters.Unicode.Is_Mark;
+ -------------
+ -- Is_NFKC --
+ -------------
+
+ function Is_NFKC (Item : Wide_Wide_Character) return Boolean
+ renames Ada.Wide_Wide_Characters.Unicode.Is_NFKC;
+
---------------------
-- Is_Other_Format --
---------------------
diff --git a/gcc/ada/libgnat/a-zchhan.ads b/gcc/ada/libgnat/a-zchhan.ads
index 354452b..74fab2a 100644
--- a/gcc/ada/libgnat/a-zchhan.ads
+++ b/gcc/ada/libgnat/a-zchhan.ads
@@ -98,6 +98,12 @@ package Ada.Wide_Wide_Characters.Handling is
-- Returns True if the Wide_Wide_Character designated by Item is
-- categorized as separator_space, otherwise returns false.
+ function Is_NFKC (Item : Wide_Wide_Character) return Boolean;
+ pragma Inline (Is_NFKC);
+ -- Returns True if the Wide_Wide_Character designated by Item could be
+ -- present in a string normalized to Normalization Form KC (as defined by
+ -- Clause 21 of ISO/IEC 10646:2017), otherwise returns False.
+
function Is_Graphic (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Graphic);
-- Returns True if the Wide_Wide_Character designated by Item is
diff --git a/gcc/ada/libgnat/a-zchuni.adb b/gcc/ada/libgnat/a-zchuni.adb
index e938156..203c3aa 100644
--- a/gcc/ada/libgnat/a-zchuni.adb
+++ b/gcc/ada/libgnat/a-zchuni.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -107,6 +107,15 @@ package body Ada.Wide_Wide_Characters.Unicode is
return G.Is_UTF_32_Non_Graphic (G.Category (C));
end Is_Non_Graphic;
+ -------------
+ -- Is_NFKC --
+ -------------
+
+ function Is_NFKC (U : Wide_Wide_Character) return Boolean is
+ begin
+ return G.Is_UTF_32_NFKC (Wide_Wide_Character'Pos (U));
+ end Is_NFKC;
+
--------------
-- Is_Other --
--------------
diff --git a/gcc/ada/libgnat/a-zchuni.ads b/gcc/ada/libgnat/a-zchuni.ads
index 9b18702..7f4a30b 100644
--- a/gcc/ada/libgnat/a-zchuni.ads
+++ b/gcc/ada/libgnat/a-zchuni.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -147,6 +147,12 @@ package Ada.Wide_Wide_Characters.Unicode is
-- of the corresponding categories, which are the following:
-- Separator, Space (Zs)
+ function Is_NFKC (U : Wide_Wide_Character) return Boolean;
+ pragma Inline (Is_NFKC);
+ -- Returns True if the Wide_Wide_Character designated by U could be present
+ -- in a string normalized to Normalization Form KC (as defined by Clause
+ -- 21 of ISO/IEC 10646:2017), otherwise returns False.
+
function Is_Non_Graphic (U : Wide_Wide_Character) return Boolean;
function Is_Non_Graphic (C : Category) return Boolean;
pragma Inline (Is_Non_Graphic);
diff --git a/gcc/ada/libgnat/a-zrstfi.adb b/gcc/ada/libgnat/a-zrstfi.adb
index e38be0a..aa73032 100644
--- a/gcc/ada/libgnat/a-zrstfi.adb
+++ b/gcc/ada/libgnat/a-zrstfi.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-zrstfi.ads b/gcc/ada/libgnat/a-zrstfi.ads
index 6b6b4f8..86a6fc5 100644
--- a/gcc/ada/libgnat/a-zrstfi.ads
+++ b/gcc/ada/libgnat/a-zrstfi.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztcoau.adb b/gcc/ada/libgnat/a-ztcoau.adb
index d160957..ffe0a90 100644
--- a/gcc/ada/libgnat/a-ztcoau.adb
+++ b/gcc/ada/libgnat/a-ztcoau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztcoio.adb b/gcc/ada/libgnat/a-ztcoio.adb
index 7d1f103..ead1234 100644
--- a/gcc/ada/libgnat/a-ztcoio.adb
+++ b/gcc/ada/libgnat/a-ztcoio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztcstr.adb b/gcc/ada/libgnat/a-ztcstr.adb
index 114a2f4..8ce9d66 100644
--- a/gcc/ada/libgnat/a-ztcstr.adb
+++ b/gcc/ada/libgnat/a-ztcstr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztcstr.ads b/gcc/ada/libgnat/a-ztcstr.ads
index 2405a8e..80c30fc 100644
--- a/gcc/ada/libgnat/a-ztcstr.ads
+++ b/gcc/ada/libgnat/a-ztcstr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztdeau.adb b/gcc/ada/libgnat/a-ztdeau.adb
index 684fdd3..3daff0f 100644
--- a/gcc/ada/libgnat/a-ztdeau.adb
+++ b/gcc/ada/libgnat/a-ztdeau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztdeau.ads b/gcc/ada/libgnat/a-ztdeau.ads
index 412e1a0..b493b80 100644
--- a/gcc/ada/libgnat/a-ztdeau.ads
+++ b/gcc/ada/libgnat/a-ztdeau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztdeio.adb b/gcc/ada/libgnat/a-ztdeio.adb
index 8e0dce2..3655386 100644
--- a/gcc/ada/libgnat/a-ztdeio.adb
+++ b/gcc/ada/libgnat/a-ztdeio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztedit.adb b/gcc/ada/libgnat/a-ztedit.adb
index 328dc74..a23074d 100644
--- a/gcc/ada/libgnat/a-ztedit.adb
+++ b/gcc/ada/libgnat/a-ztedit.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztedit.ads b/gcc/ada/libgnat/a-ztedit.ads
index 4d18e86..54cd24a 100644
--- a/gcc/ada/libgnat/a-ztedit.ads
+++ b/gcc/ada/libgnat/a-ztedit.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-ztenau.adb b/gcc/ada/libgnat/a-ztenau.adb
index e9f8461..f985d52d 100644
--- a/gcc/ada/libgnat/a-ztenau.adb
+++ b/gcc/ada/libgnat/a-ztenau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztenau.ads b/gcc/ada/libgnat/a-ztenau.ads
index 9148029..dd31182 100644
--- a/gcc/ada/libgnat/a-ztenau.ads
+++ b/gcc/ada/libgnat/a-ztenau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztenio.adb b/gcc/ada/libgnat/a-ztenio.adb
index 202e198..5a61874 100644
--- a/gcc/ada/libgnat/a-ztenio.adb
+++ b/gcc/ada/libgnat/a-ztenio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztexio.adb b/gcc/ada/libgnat/a-ztexio.adb
index 0a4c7a8..dcd6f9e 100644
--- a/gcc/ada/libgnat/a-ztexio.adb
+++ b/gcc/ada/libgnat/a-ztexio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztexio.ads b/gcc/ada/libgnat/a-ztexio.ads
index e16a175..85ea6b5 100644
--- a/gcc/ada/libgnat/a-ztexio.ads
+++ b/gcc/ada/libgnat/a-ztexio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/a-ztfiio.adb b/gcc/ada/libgnat/a-ztfiio.adb
index 3451197..7c0c95d 100644
--- a/gcc/ada/libgnat/a-ztfiio.adb
+++ b/gcc/ada/libgnat/a-ztfiio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztflau.adb b/gcc/ada/libgnat/a-ztflau.adb
index c71bcaf..c0c55ba 100644
--- a/gcc/ada/libgnat/a-ztflau.adb
+++ b/gcc/ada/libgnat/a-ztflau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztflau.ads b/gcc/ada/libgnat/a-ztflau.ads
index 825cb95..dc24682 100644
--- a/gcc/ada/libgnat/a-ztflau.ads
+++ b/gcc/ada/libgnat/a-ztflau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztflio.adb b/gcc/ada/libgnat/a-ztflio.adb
index 8d16ffc..fd6bf52 100644
--- a/gcc/ada/libgnat/a-ztflio.adb
+++ b/gcc/ada/libgnat/a-ztflio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztgeau.adb b/gcc/ada/libgnat/a-ztgeau.adb
index 02ee1bf..dbd8926 100644
--- a/gcc/ada/libgnat/a-ztgeau.adb
+++ b/gcc/ada/libgnat/a-ztgeau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztgeau.ads b/gcc/ada/libgnat/a-ztgeau.ads
index 2b3ee11..2c5c306 100644
--- a/gcc/ada/libgnat/a-ztgeau.ads
+++ b/gcc/ada/libgnat/a-ztgeau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztinau.adb b/gcc/ada/libgnat/a-ztinau.adb
index a39056b..e7e290e 100644
--- a/gcc/ada/libgnat/a-ztinau.adb
+++ b/gcc/ada/libgnat/a-ztinau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztinau.ads b/gcc/ada/libgnat/a-ztinau.ads
index ea01d11..49eb3c5 100644
--- a/gcc/ada/libgnat/a-ztinau.ads
+++ b/gcc/ada/libgnat/a-ztinau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztinio.adb b/gcc/ada/libgnat/a-ztinio.adb
index 9607cb1..c0726ce 100644
--- a/gcc/ada/libgnat/a-ztinio.adb
+++ b/gcc/ada/libgnat/a-ztinio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztmoau.adb b/gcc/ada/libgnat/a-ztmoau.adb
index 1cc2a24..2f179e2 100644
--- a/gcc/ada/libgnat/a-ztmoau.adb
+++ b/gcc/ada/libgnat/a-ztmoau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztmoau.ads b/gcc/ada/libgnat/a-ztmoau.ads
index 46454ff..9d53154 100644
--- a/gcc/ada/libgnat/a-ztmoau.ads
+++ b/gcc/ada/libgnat/a-ztmoau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-ztmoio.adb b/gcc/ada/libgnat/a-ztmoio.adb
index 1675c4f..bf9d42b 100644
--- a/gcc/ada/libgnat/a-ztmoio.adb
+++ b/gcc/ada/libgnat/a-ztmoio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-zttest.adb b/gcc/ada/libgnat/a-zttest.adb
index fee4974..71004bb 100644
--- a/gcc/ada/libgnat/a-zttest.adb
+++ b/gcc/ada/libgnat/a-zttest.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/a-zzboio.adb b/gcc/ada/libgnat/a-zzboio.adb
index 5b22b72..a41aadc 100644
--- a/gcc/ada/libgnat/a-zzboio.adb
+++ b/gcc/ada/libgnat/a-zzboio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-allein.ads b/gcc/ada/libgnat/g-allein.ads
index a29fc67..ab23380 100644
--- a/gcc/ada/libgnat/g-allein.ads
+++ b/gcc/ada/libgnat/g-allein.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-alleve.adb b/gcc/ada/libgnat/g-alleve.adb
index 7bd9194..a3aa5b6 100644
--- a/gcc/ada/libgnat/g-alleve.adb
+++ b/gcc/ada/libgnat/g-alleve.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- (Soft Binding Version) --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-alleve.ads b/gcc/ada/libgnat/g-alleve.ads
index 73100f4..3c39b11 100644
--- a/gcc/ada/libgnat/g-alleve.ads
+++ b/gcc/ada/libgnat/g-alleve.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Soft Binding Version) --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-alleve__hard.adb b/gcc/ada/libgnat/g-alleve__hard.adb
index caf4366..7934091 100644
--- a/gcc/ada/libgnat/g-alleve__hard.adb
+++ b/gcc/ada/libgnat/g-alleve__hard.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- (Hard Binding Version) --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-alleve__hard.ads b/gcc/ada/libgnat/g-alleve__hard.ads
index d4306ee..318f72d 100644
--- a/gcc/ada/libgnat/g-alleve__hard.ads
+++ b/gcc/ada/libgnat/g-alleve__hard.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Hard Binding Version) --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-altcon.adb b/gcc/ada/libgnat/g-altcon.adb
index 9fe4dcc..589ba6c 100644
--- a/gcc/ada/libgnat/g-altcon.adb
+++ b/gcc/ada/libgnat/g-altcon.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-altcon.ads b/gcc/ada/libgnat/g-altcon.ads
index 5a6faed..173d0d0 100644
--- a/gcc/ada/libgnat/g-altcon.ads
+++ b/gcc/ada/libgnat/g-altcon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-altive.ads b/gcc/ada/libgnat/g-altive.ads
index a77a60d..455ebe7 100644
--- a/gcc/ada/libgnat/g-altive.ads
+++ b/gcc/ada/libgnat/g-altive.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-alveop.adb b/gcc/ada/libgnat/g-alveop.adb
index cb36031..b889778 100644
--- a/gcc/ada/libgnat/g-alveop.adb
+++ b/gcc/ada/libgnat/g-alveop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-alveop.ads b/gcc/ada/libgnat/g-alveop.ads
index a7e0f26..644b3c4 100644
--- a/gcc/ada/libgnat/g-alveop.ads
+++ b/gcc/ada/libgnat/g-alveop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-alvety.ads b/gcc/ada/libgnat/g-alvety.ads
index 0d742fe..66cac0c 100644
--- a/gcc/ada/libgnat/g-alvety.ads
+++ b/gcc/ada/libgnat/g-alvety.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-alvevi.ads b/gcc/ada/libgnat/g-alvevi.ads
index a23c491..adf463c 100644
--- a/gcc/ada/libgnat/g-alvevi.ads
+++ b/gcc/ada/libgnat/g-alvevi.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-arrspl.adb b/gcc/ada/libgnat/g-arrspl.adb
index 119e7c9..e6f0d99 100644
--- a/gcc/ada/libgnat/g-arrspl.adb
+++ b/gcc/ada/libgnat/g-arrspl.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-arrspl.ads b/gcc/ada/libgnat/g-arrspl.ads
index f06a0e2..3383f40 100644
--- a/gcc/ada/libgnat/g-arrspl.ads
+++ b/gcc/ada/libgnat/g-arrspl.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-awk.adb b/gcc/ada/libgnat/g-awk.adb
index 45305e6..cd2031f 100644
--- a/gcc/ada/libgnat/g-awk.adb
+++ b/gcc/ada/libgnat/g-awk.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-awk.ads b/gcc/ada/libgnat/g-awk.ads
index fc7b3ae..21b008b 100644
--- a/gcc/ada/libgnat/g-awk.ads
+++ b/gcc/ada/libgnat/g-awk.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-binenv.adb b/gcc/ada/libgnat/g-binenv.adb
index c7dece4..95ef997 100644
--- a/gcc/ada/libgnat/g-binenv.adb
+++ b/gcc/ada/libgnat/g-binenv.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2015-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-binenv.ads b/gcc/ada/libgnat/g-binenv.ads
index e702ce4..dab454a 100644
--- a/gcc/ada/libgnat/g-binenv.ads
+++ b/gcc/ada/libgnat/g-binenv.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2015-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-brapre.ads b/gcc/ada/libgnat/g-brapre.ads
index 9b88e35..3559b0a 100644
--- a/gcc/ada/libgnat/g-brapre.ads
+++ b/gcc/ada/libgnat/g-brapre.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019, AdaCore --
+-- Copyright (C) 2019-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-bubsor.adb b/gcc/ada/libgnat/g-bubsor.adb
index b59707c..f36c5a9c 100644
--- a/gcc/ada/libgnat/g-bubsor.adb
+++ b/gcc/ada/libgnat/g-bubsor.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-bubsor.ads b/gcc/ada/libgnat/g-bubsor.ads
index cae1fff..5eeb5dd 100644
--- a/gcc/ada/libgnat/g-bubsor.ads
+++ b/gcc/ada/libgnat/g-bubsor.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-busora.adb b/gcc/ada/libgnat/g-busora.adb
index e91d4e3..125afee 100644
--- a/gcc/ada/libgnat/g-busora.adb
+++ b/gcc/ada/libgnat/g-busora.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-busora.ads b/gcc/ada/libgnat/g-busora.ads
index bd87cf5..11a3d75 100644
--- a/gcc/ada/libgnat/g-busora.ads
+++ b/gcc/ada/libgnat/g-busora.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-busorg.adb b/gcc/ada/libgnat/g-busorg.adb
index 4efe587..543a197 100644
--- a/gcc/ada/libgnat/g-busorg.adb
+++ b/gcc/ada/libgnat/g-busorg.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-busorg.ads b/gcc/ada/libgnat/g-busorg.ads
index fa13aea..fc6546a 100644
--- a/gcc/ada/libgnat/g-busorg.ads
+++ b/gcc/ada/libgnat/g-busorg.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-byorma.adb b/gcc/ada/libgnat/g-byorma.adb
index b067240..635f4b4 100644
--- a/gcc/ada/libgnat/g-byorma.adb
+++ b/gcc/ada/libgnat/g-byorma.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2006-2019, AdaCore --
+-- Copyright (C) 2006-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-byorma.ads b/gcc/ada/libgnat/g-byorma.ads
index e0cc749..ac0d812 100644
--- a/gcc/ada/libgnat/g-byorma.ads
+++ b/gcc/ada/libgnat/g-byorma.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2019, AdaCore --
+-- Copyright (C) 2006-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-bytswa.adb b/gcc/ada/libgnat/g-bytswa.adb
index e915e58..f34730f 100644
--- a/gcc/ada/libgnat/g-bytswa.adb
+++ b/gcc/ada/libgnat/g-bytswa.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2006-2019, AdaCore --
+-- Copyright (C) 2006-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -45,7 +45,7 @@ package body GNAT.Byte_Swapping is
function Swapped2 (Input : Item) return Item is
function As_U16 is new Unchecked_Conversion (Item, U16);
function As_Item is new Unchecked_Conversion (U16, Item);
- pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 2,
+ pragma Compile_Time_Warning (Item'Max_Size_In_Storage_Elements /= 2,
"storage size must be 2 bytes");
begin
return As_Item (Bswap_16 (As_U16 (Input)));
@@ -58,7 +58,7 @@ package body GNAT.Byte_Swapping is
function Swapped4 (Input : Item) return Item is
function As_U32 is new Unchecked_Conversion (Item, U32);
function As_Item is new Unchecked_Conversion (U32, Item);
- pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 4,
+ pragma Compile_Time_Warning (Item'Max_Size_In_Storage_Elements /= 4,
"storage size must be 4 bytes");
begin
return As_Item (Bswap_32 (As_U32 (Input)));
@@ -71,7 +71,7 @@ package body GNAT.Byte_Swapping is
function Swapped8 (Input : Item) return Item is
function As_U64 is new Unchecked_Conversion (Item, U64);
function As_Item is new Unchecked_Conversion (U64, Item);
- pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 8,
+ pragma Compile_Time_Warning (Item'Max_Size_In_Storage_Elements /= 8,
"storage size must be 8 bytes");
begin
return As_Item (Bswap_64 (As_U64 (Input)));
diff --git a/gcc/ada/libgnat/g-bytswa.ads b/gcc/ada/libgnat/g-bytswa.ads
index a552db7..01d4501 100644
--- a/gcc/ada/libgnat/g-bytswa.ads
+++ b/gcc/ada/libgnat/g-bytswa.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2019, AdaCore --
+-- Copyright (C) 2006-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-calend.adb b/gcc/ada/libgnat/g-calend.adb
index d1d4b55..55fb181 100644
--- a/gcc/ada/libgnat/g-calend.adb
+++ b/gcc/ada/libgnat/g-calend.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -226,7 +226,8 @@ package body GNAT.Calendar is
begin
-- Even though the input time zone is UTC (0), the flag Use_TZ will
- -- ensure that Split picks up the local time zone.
+ -- ensure that Split picks up the local time zone. ???But Use_TZ is
+ -- False below, and anyway, Use_TZ has no effect if Time_Zone is 0.
Ada_Calendar_Split
(Date => Date,
@@ -315,7 +316,8 @@ package body GNAT.Calendar is
begin
-- Even though the input time zone is UTC (0), the flag Use_TZ will
- -- ensure that Split picks up the local time zone.
+ -- ensure that Split picks up the local time zone. ???But there is no
+ -- call to Split here.
return
Ada_Calendar_Time_Of
@@ -352,6 +354,9 @@ package body GNAT.Calendar is
begin
timeval_to_duration (T, sec'Access, usec'Access);
+ pragma Annotate (CodePeer, Modified, sec);
+ pragma Annotate (CodePeer, Modified, usec);
+
return Duration (sec) + Duration (usec) / Micro;
end To_Duration;
diff --git a/gcc/ada/libgnat/g-calend.ads b/gcc/ada/libgnat/g-calend.ads
index 19999af..e153e08 100644
--- a/gcc/ada/libgnat/g-calend.ads
+++ b/gcc/ada/libgnat/g-calend.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-casuti.adb b/gcc/ada/libgnat/g-casuti.adb
index 621147f..7baa43a 100644
--- a/gcc/ada/libgnat/g-casuti.adb
+++ b/gcc/ada/libgnat/g-casuti.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-casuti.ads b/gcc/ada/libgnat/g-casuti.ads
index 9607c35..5468e25 100644
--- a/gcc/ada/libgnat/g-casuti.ads
+++ b/gcc/ada/libgnat/g-casuti.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-catiio.adb b/gcc/ada/libgnat/g-catiio.adb
index dc2fa40..cd2df6a 100644
--- a/gcc/ada/libgnat/g-catiio.adb
+++ b/gcc/ada/libgnat/g-catiio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,7 +29,6 @@
-- --
------------------------------------------------------------------------------
-with Ada.Calendar; use Ada.Calendar;
with Ada.Characters.Handling;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO;
@@ -70,6 +69,14 @@ package body GNAT.Calendar.Time_IO is
-- Local Subprograms --
-----------------------
+ function Image_Helper
+ (Date : Ada.Calendar.Time;
+ Picture : Picture_String;
+ Time_Zone : Time_Zones.Time_Offset) return String;
+ -- This is called by the two exported Image functions. It uses the local
+ -- time zone for its computations, but uses Time_Zone when interpreting the
+ -- "%:::z" tag.
+
function Am_Pm (H : Natural) return String;
-- Return AM or PM depending on the hour H
@@ -93,19 +100,14 @@ package body GNAT.Calendar.Time_IO is
Length : Natural := 0) return String;
-- As above with N provided in Integer format
- procedure Parse_ISO_8861_UTC
+ procedure Parse_ISO_8601
(Date : String;
Time : out Ada.Calendar.Time;
Success : out Boolean);
-- Subsidiary of function Value. It parses the string Date, interpreted as
- -- an ISO 8861 time representation, and returns corresponding Time value.
- -- Success is set to False when the string is not a supported ISO 8861
- -- date. The following regular expression defines the supported format:
- --
- -- (yyyymmdd | yyyy'-'mm'-'dd)'T'(hhmmss | hh':'mm':'ss)
- -- [ ('Z' | ('.' | ',') s{s} | ('+'|'-')hh':'mm) ]
- --
- -- Trailing characters (in particular spaces) are not allowed.
+ -- an ISO 8601 time representation, and returns corresponding Time value.
+ -- Success is set to False when the string is not a supported ISO 8601
+ -- date.
--
-- Examples:
--
@@ -174,6 +176,10 @@ package body GNAT.Calendar.Time_IO is
return Image (Sec_Number (N), Padding, Length);
end Image;
+ -----------
+ -- Image --
+ -----------
+
function Image
(N : Sec_Number;
Padding : Padding_Mode := Zero;
@@ -214,9 +220,46 @@ package body GNAT.Calendar.Time_IO is
-----------
function Image
+ (Date : Ada.Calendar.Time;
+ Picture : Picture_String;
+ Time_Zone : Time_Zones.Time_Offset) return String
+ is
+ -- We subtract off the local time zone, and add in the requested
+ -- Time_Zone, and then pass it on to Image_Helper, which uses the
+ -- local time zone.
+
+ use Time_Zones;
+ Local_TZ : constant Time_Offset := Local_Time_Offset (Date);
+ Minute_Offset : constant Integer := Integer (Time_Zone - Local_TZ);
+ Second_Offset : constant Integer := Minute_Offset * 60;
+ begin
+ return Image_Helper
+ (Date + Duration (Second_Offset), Picture, Time_Zone);
+ end Image;
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image
(Date : Ada.Calendar.Time;
Picture : Picture_String) return String
is
+ use Time_Zones;
+ Local_TZ : constant Time_Offset := Local_Time_Offset (Date);
+ begin
+ return Image_Helper (Date, Picture, Local_TZ);
+ end Image;
+
+ ------------------
+ -- Image_Helper --
+ ------------------
+
+ function Image_Helper
+ (Date : Ada.Calendar.Time;
+ Picture : Picture_String;
+ Time_Zone : Time_Zones.Time_Offset) return String
+ is
Padding : Padding_Mode := Zero;
-- Padding is set for one directive
@@ -409,6 +452,43 @@ package body GNAT.Calendar.Time_IO is
Image (Minute, Padding, Length => 2) & ':' &
Image (Second, Padding, Length => 2);
+ -- Time zone. Append "+hh", "-hh", "+hh:mm", or "-hh:mm", as
+ -- appropriate.
+
+ when ':' =>
+ declare
+ use type Time_Zones.Time_Offset;
+ TZ_Form : constant Picture_String := "%:::z";
+ TZ : constant Natural := Natural (abs Time_Zone);
+ begin
+ if P + TZ_Form'Length - 1 <= Picture'Last
+ and then Picture (P .. P + TZ_Form'Length - 1) = "%:::z"
+ then
+ if Time_Zone >= 0 then
+ Result := Result & "+";
+ else
+ Result := Result & "-";
+ end if;
+
+ Result := Result &
+ Image (Integer (TZ / 60), Padding, Length => 2);
+
+ if TZ mod 60 /= 0 then
+ Result := Result & ":";
+ Result := Result &
+ Image (TZ mod 60, Padding, Length => 2);
+ end if;
+
+ P := P + TZ_Form'Length - 2; -- will add 2 below
+
+ -- We do not support any of the other standard GNU
+ -- time-zone formats (%z, %:z, %::z, %Z).
+
+ else
+ raise Picture_Error with "unsupported picture format";
+ end if;
+ end;
+
-- Locale's abbreviated weekday name (Sun..Sat)
when 'a' =>
@@ -535,7 +615,7 @@ package body GNAT.Calendar.Time_IO is
end loop;
return To_String (Result);
- end Image;
+ end Image_Helper;
--------------------------
-- Month_Name_To_Number --
@@ -565,26 +645,29 @@ package body GNAT.Calendar.Time_IO is
return Abbrev_Upper_Month_Names'First;
end Month_Name_To_Number;
- ------------------------
- -- Parse_ISO_8861_UTC --
- ------------------------
+ --------------------
+ -- Parse_ISO_8601 --
+ --------------------
- procedure Parse_ISO_8861_UTC
+ procedure Parse_ISO_8601
(Date : String;
Time : out Ada.Calendar.Time;
Success : out Boolean)
is
+ pragma Unsuppress (All_Checks);
+ -- This is necessary because the run-time library is usually compiled
+ -- with checks suppressed, and we are relying on constraint checks in
+ -- this code to catch syntax errors in the Date string (e.g. out of
+ -- bounds slices).
+
Index : Positive := Date'First;
-- The current character scan index. After a call to Advance, Index
-- points to the next character.
- End_Of_Source_Reached : exception;
- -- An exception used to signal that the scan pointer has reached the
- -- end of the source string.
-
Wrong_Syntax : exception;
-- An exception used to signal that the scan pointer has reached an
- -- unexpected character in the source string.
+ -- unexpected character in the source string, or if premature
+ -- end-of-source was reached.
procedure Advance;
pragma Inline (Advance);
@@ -642,13 +725,12 @@ package body GNAT.Calendar.Time_IO is
procedure Advance is
begin
- -- Signal the end of the source string. This stops a complex scan by
- -- bottoming up any recursive calls till control reaches routine Scan
- -- which handles the exception. Certain scanning scenarios may handle
- -- this exception on their own.
+ -- Signal the end of the source string. This stops a complex scan
+ -- by bottoming up any recursive calls till control reaches routine
+ -- Scan, which handles the exception.
if Index > Date'Last then
- raise End_Of_Source_Reached;
+ raise Wrong_Syntax;
-- Advance the scan pointer as long as there are characters to scan,
-- in other words, the scan pointer has not passed the end of the
@@ -767,17 +849,10 @@ package body GNAT.Calendar.Time_IO is
begin
Advance_Digits (Num_Digits => 1);
- while Symbol in '0' .. '9'
- and then Index < Date'Length
- loop
+ while Index <= Date'Length and then Symbol in '0' .. '9' loop
Advance;
end loop;
- if Symbol not in '0' .. '9' then
- raise Wrong_Syntax;
- end if;
-
- Advance;
return Second_Duration'Value ("0." & Date (From .. Index - 1));
end Scan_Subsecond;
@@ -804,7 +879,7 @@ package body GNAT.Calendar.Time_IO is
-- this exception on their own.
if Index > Date'Last then
- raise End_Of_Source_Reached;
+ raise Wrong_Syntax;
else
return Date (Index);
@@ -813,25 +888,29 @@ package body GNAT.Calendar.Time_IO is
-- Local variables
+ use Time_Zones;
+
Date_Separator : constant Character := '-';
Hour_Separator : constant Character := ':';
- Day : Day_Number;
- Month : Month_Number;
- Year : Year_Number;
- Hour : Hour_Number := 0;
- Minute : Minute_Number := 0;
- Second : Second_Number := 0;
- Subsec : Second_Duration := 0.0;
+ Day : Day_Number;
+ Month : Month_Number;
+ Year : Year_Number;
+ Hour : Hour_Number := 0;
+ Minute : Minute_Number := 0;
+ Second : Second_Number := 0;
+ Subsec : Second_Duration := 0.0;
- Local_Hour : Hour_Number := 0;
- Local_Minute : Minute_Number := 0;
- Local_Sign : Character := ' ';
- Local_Disp : Duration;
+ Time_Zone_Seen : Boolean := False;
+ Time_Zone_Offset : Time_Offset; -- Valid only if Time_Zone_Seen
Sep_Required : Boolean := False;
-- True if a separator is seen (and therefore required after it!)
+ subtype Sign_Type is Character with Predicate => Sign_Type in '+' | '-';
+
+ -- Start of processing for Parse_ISO_8601
+
begin
-- Parse date
@@ -856,25 +935,31 @@ package body GNAT.Calendar.Time_IO is
Second := Scan_Second;
- -- [('Z' | ('.' | ',') s{s} | ('+'|'-')hh:mm)]
+ -- [ ('.' | ',') s{s} ]
if Index <= Date'Last then
-
- -- Suffix 'Z' just confirms that this is an UTC time. No further
- -- action needed.
-
- if Symbol = 'Z' then
- Advance;
-
-- A decimal fraction shall have at least one digit, and has as
-- many digits as supported by the underlying implementation.
-- The valid decimal separators are those specified in ISO 31-0,
-- i.e. the comma [,] or full stop [.]. Of these, the comma is
- -- the preferred separator of ISO-8861.
+ -- the preferred separator of ISO-8601.
- elsif Symbol = ',' or else Symbol = '.' then
+ if Symbol = ',' or else Symbol = '.' then
Advance; -- past decimal separator
Subsec := Scan_Subsecond;
+ end if;
+ end if;
+
+ -- [ ('Z' | ('+'|'-')hh':'mm) ]
+
+ if Index <= Date'Last then
+ Time_Zone_Seen := Symbol in 'Z' | Sign_Type;
+
+ -- Suffix 'Z' signifies that this is UTC time (time zone 0)
+
+ if Symbol = 'Z' then
+ Time_Zone_Offset := 0;
+ Advance;
-- Difference between local time and UTC: It shall be expressed
-- as positive (i.e. with the leading plus sign [+]) if the local
@@ -884,62 +969,57 @@ package body GNAT.Calendar.Time_IO is
-- if the difference between the time scales is exactly an
-- integral number of hours.
- elsif Symbol = '+' or else Symbol = '-' then
- Local_Sign := Symbol;
- Advance;
- Local_Hour := Scan_Hour;
+ elsif Symbol in Sign_Type then
+ declare
+ Time_Zone_Sign : constant Sign_Type := Symbol;
+ Time_Zone_Hour : Hour_Number;
+ Time_Zone_Minute : Minute_Number;
+ begin
+ Advance;
+ Time_Zone_Hour := Scan_Hour;
- -- Past ':'
+ -- Past ':'
- if Index < Date'Last and then Symbol = Hour_Separator then
- Advance;
- Local_Minute := Scan_Minute;
- end if;
+ if Index < Date'Last and then Symbol = Hour_Separator then
+ Advance;
+ Time_Zone_Minute := Scan_Minute;
+ else
+ Time_Zone_Minute := 0;
+ end if;
+
+ -- Compute Time_Zone_Offset
- -- Compute local displacement
+ Time_Zone_Offset :=
+ Time_Offset (Time_Zone_Hour * 60 + Time_Zone_Minute);
- Local_Disp := Local_Hour * 3600.0 + Local_Minute * 60.0;
+ case Time_Zone_Sign is
+ when '+' => null;
+ when '-' => Time_Zone_Offset := -Time_Zone_Offset;
+ end case;
+ end;
else
raise Wrong_Syntax;
end if;
end if;
end if;
- -- Sanity checks. The check on Index ensures that there are no trailing
- -- characters.
-
- if Index /= Date'Length + 1
- or else not Year'Valid
- or else not Month'Valid
- or else not Day'Valid
- or else not Hour'Valid
- or else not Minute'Valid
- or else not Second'Valid
- or else not Subsec'Valid
- or else not Local_Hour'Valid
- or else not Local_Minute'Valid
- then
+ -- Check for trailing characters
+
+ if Index /= Date'Length + 1 then
raise Wrong_Syntax;
end if;
- -- Compute time without local displacement
-
- if Local_Sign = ' ' then
- Time := Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec);
+ -- If a time zone was specified, use Ada.Calendar.Formatting.Time_Of,
+ -- and specify the time zone. Otherwise, call GNAT.Calendar.Time_Of,
+ -- which uses local time.
- -- Compute time with positive local displacement
-
- elsif Local_Sign = '+' then
- Time :=
- Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec) -
- Local_Disp;
-
- -- Compute time with negative local displacement
-
- elsif Local_Sign = '-' then
- Time :=
- Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec) +
- Local_Disp;
+ if Time_Zone_Seen then
+ Time := Ada.Calendar.Formatting.Time_Of
+ (Year, Month, Day, Hour, Minute, Second, Subsec,
+ Time_Zone => Time_Zone_Offset);
+ else
+ Time := GNAT.Calendar.Time_Of
+ (Year, Month, Day, Hour, Minute, Second, Subsec);
end if;
-- Notify that the input string was successfully parsed
@@ -947,17 +1027,22 @@ package body GNAT.Calendar.Time_IO is
Success := True;
exception
- when End_Of_Source_Reached
- | Wrong_Syntax
- =>
+ when Wrong_Syntax | Constraint_Error =>
+ -- If constraint check fails, we want to behave the same as
+ -- Wrong_Syntax; we want the caller (Value) to try other
+ -- allowed syntaxes.
+ Time :=
+ Time_Of (Year_Number'First, Month_Number'First, Day_Number'First);
Success := False;
- end Parse_ISO_8861_UTC;
+ end Parse_ISO_8601;
-----------
-- Value --
-----------
function Value (Date : String) return Ada.Calendar.Time is
+ pragma Unsuppress (All_Checks); -- see comment in Parse_ISO_8601
+
D : String (1 .. 21);
D_Length : constant Natural := Date'Length;
@@ -1172,10 +1257,10 @@ package body GNAT.Calendar.Time_IO is
-- Start of processing for Value
begin
- -- Let's try parsing Date as a supported ISO-8861 format. If we do not
+ -- Let's try parsing Date as a supported ISO-8601 format. If we do not
-- succeed, then retry using all the other GNAT supported formats.
- Parse_ISO_8861_UTC (Date, Time, Success);
+ Parse_ISO_8601 (Date, Time, Success);
if Success then
return Time;
@@ -1183,15 +1268,7 @@ package body GNAT.Calendar.Time_IO is
-- Length checks
- if D_Length /= 8
- and then D_Length /= 10
- and then D_Length /= 11
- and then D_Length /= 12
- and then D_Length /= 17
- and then D_Length /= 19
- and then D_Length /= 20
- and then D_Length /= 21
- then
+ if D_Length not in 8 | 10 | 11 | 12 | 17 | 19 | 20 | 21 then
raise Constraint_Error;
end if;
@@ -1215,18 +1292,6 @@ package body GNAT.Calendar.Time_IO is
Extract_Time (1, Hour, Minute, Second, Check_Space => False);
end if;
- -- Sanity checks
-
- if not Year'Valid
- or else not Month'Valid
- or else not Day'Valid
- or else not Hour'Valid
- or else not Minute'Valid
- or else not Second'Valid
- then
- raise Constraint_Error;
- end if;
-
return Time_Of (Year, Month, Day, Hour, Minute, Second);
end Value;
diff --git a/gcc/ada/libgnat/g-catiio.ads b/gcc/ada/libgnat/g-catiio.ads
index 272f1ee..6bb9847 100644
--- a/gcc/ada/libgnat/g-catiio.ads
+++ b/gcc/ada/libgnat/g-catiio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,6 +32,8 @@
-- This package augments standard Ada.Text_IO with facilities for input
-- and output of time values in standardized format.
+with Ada.Calendar.Time_Zones; use Ada.Calendar;
+
package GNAT.Calendar.Time_IO is
Picture_Error : exception;
@@ -41,7 +43,7 @@ package GNAT.Calendar.Time_IO is
-- This is a string to describe date and time output format. The string is
-- a set of standard character and special tag that are replaced by the
-- corresponding values. It follows the GNU Date specification. Here are
- -- the recognized directives :
+ -- the recognized directives:
--
-- % a literal %
-- n a newline
@@ -60,6 +62,8 @@ package GNAT.Calendar.Time_IO is
-- (a nonstandard extension)
-- %S second (00..59)
-- %T time, 24-hour (hh:mm:ss)
+ -- %:::z numeric time zone with : to necessary precision
+ -- (e.g., -04, +05:30)
--
-- Date fields:
--
@@ -96,8 +100,11 @@ package GNAT.Calendar.Time_IO is
-- %e microseconds (6 digits)
-- %o nanoseconds (9 digits)
+ ISO_Time : constant Picture_String;
+ -- ISO 8601 standard date and time, with time zone.
+
ISO_Date : constant Picture_String;
- -- This format follow the ISO 8601 standard. The format is "YYYY-MM-DD",
+ -- This format follows the ISO 8601 standard. The format is "YYYY-MM-DD",
-- four digits year, month and day number separated by minus.
US_Date : constant Picture_String;
@@ -115,6 +122,13 @@ package GNAT.Calendar.Time_IO is
-- with format Picture. Raise Picture_Error if picture string is null or
-- has an incorrect format.
+ function Image
+ (Date : Ada.Calendar.Time;
+ Picture : Picture_String;
+ Time_Zone : Time_Zones.Time_Offset) return String;
+ -- Same as previous Image, except it uses the specified time zone instead
+ -- of the local time zone.
+
function Value (Date : String) return Ada.Calendar.Time;
-- Parse the string Date, interpreted as a time representation in the
-- current local time zone, and return the corresponding Time value. The
@@ -141,11 +155,15 @@ package GNAT.Calendar.Time_IO is
-- mmm dd, yyyy - month spelled out
-- dd mmm yyyy - month spelled out
--
- -- The following ISO-8861 format expressed as a regular expression is also
+ -- The following ISO-8601 format expressed as a regular expression is also
-- supported:
--
-- (yyyymmdd | yyyy'-'mm'-'dd)'T'(hhmmss | hh':'mm':'ss)
- -- [ ('Z' | ('.' | ',') s{s} | ('+'|'-')hh':'mm) ]
+ -- [ ('.' | ',') s{s} ]
+ -- [ ('Z' | ('+'|'-')hh':'mm) ]
+ -- Trailing characters (including spaces) are not allowed.
+ -- In the ISO case, the current time zone is not used; the time zone
+ -- is as specified in the string, defaulting to UTC.
--
-- Examples:
--
@@ -161,6 +179,7 @@ package GNAT.Calendar.Time_IO is
-- Put Date with format Picture. Raise Picture_Error if bad picture string
private
+ ISO_Time : constant Picture_String := "%Y-%m-%dT%H:%M:%S%:::z";
ISO_Date : constant Picture_String := "%Y-%m-%d";
US_Date : constant Picture_String := "%m/%d/%y";
European_Date : constant Picture_String := "%d/%m/%y";
diff --git a/gcc/ada/libgnat/g-cgi.adb b/gcc/ada/libgnat/g-cgi.adb
index 7ac74dcd..495b6dd 100644
--- a/gcc/ada/libgnat/g-cgi.adb
+++ b/gcc/ada/libgnat/g-cgi.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-cgi.ads b/gcc/ada/libgnat/g-cgi.ads
index 879cf62..4b2b9dc 100644
--- a/gcc/ada/libgnat/g-cgi.ads
+++ b/gcc/ada/libgnat/g-cgi.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-cgicoo.adb b/gcc/ada/libgnat/g-cgicoo.adb
index a1fca87..0f4444a 100644
--- a/gcc/ada/libgnat/g-cgicoo.adb
+++ b/gcc/ada/libgnat/g-cgicoo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-cgicoo.ads b/gcc/ada/libgnat/g-cgicoo.ads
index 0d57f46..42b79db 100644
--- a/gcc/ada/libgnat/g-cgicoo.ads
+++ b/gcc/ada/libgnat/g-cgicoo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-cgideb.adb b/gcc/ada/libgnat/g-cgideb.adb
index c52ccbc4..7ce04a1 100644
--- a/gcc/ada/libgnat/g-cgideb.adb
+++ b/gcc/ada/libgnat/g-cgideb.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-cgideb.ads b/gcc/ada/libgnat/g-cgideb.ads
index 51f0f71..5ae3bdd 100644
--- a/gcc/ada/libgnat/g-cgideb.ads
+++ b/gcc/ada/libgnat/g-cgideb.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-comlin.adb b/gcc/ada/libgnat/g-comlin.adb
index ec057a9..0ca82f8 100644
--- a/gcc/ada/libgnat/g-comlin.adb
+++ b/gcc/ada/libgnat/g-comlin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -537,6 +537,7 @@ package body GNAT.Command_Line is
P : Switch_Parameter_Type;
begin
+ Param := Parameter_None;
Index_In_Switches := 0;
Switch_Length := 0;
diff --git a/gcc/ada/libgnat/g-comlin.ads b/gcc/ada/libgnat/g-comlin.ads
index 34feee7..aa25118 100644
--- a/gcc/ada/libgnat/g-comlin.ads
+++ b/gcc/ada/libgnat/g-comlin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-comver.adb b/gcc/ada/libgnat/g-comver.adb
index d337c24..fbc1469 100644
--- a/gcc/ada/libgnat/g-comver.adb
+++ b/gcc/ada/libgnat/g-comver.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, AdaCore --
+-- Copyright (C) 2002-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-comver.ads b/gcc/ada/libgnat/g-comver.ads
index c8a9c9c..0b56b78 100644
--- a/gcc/ada/libgnat/g-comver.ads
+++ b/gcc/ada/libgnat/g-comver.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, AdaCore --
+-- Copyright (C) 2002-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-cppexc.adb b/gcc/ada/libgnat/g-cppexc.adb
index bb8f2b6..691780f 100644
--- a/gcc/ada/libgnat/g-cppexc.adb
+++ b/gcc/ada/libgnat/g-cppexc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2013-2019, AdaCore --
+-- Copyright (C) 2013-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-cppexc.ads b/gcc/ada/libgnat/g-cppexc.ads
index 04ee87a..3781c13 100644
--- a/gcc/ada/libgnat/g-cppexc.ads
+++ b/gcc/ada/libgnat/g-cppexc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2013-2019, AdaCore --
+-- Copyright (C) 2013-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-crc32.adb b/gcc/ada/libgnat/g-crc32.adb
index 85be42f..3adcf60 100644
--- a/gcc/ada/libgnat/g-crc32.adb
+++ b/gcc/ada/libgnat/g-crc32.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-crc32.ads b/gcc/ada/libgnat/g-crc32.ads
index e56330e..b3d6005 100644
--- a/gcc/ada/libgnat/g-crc32.ads
+++ b/gcc/ada/libgnat/g-crc32.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, AdaCore --
+-- Copyright (C) 2004-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-ctrl_c.adb b/gcc/ada/libgnat/g-ctrl_c.adb
index ad14abe..82d66b9 100644
--- a/gcc/ada/libgnat/g-ctrl_c.adb
+++ b/gcc/ada/libgnat/g-ctrl_c.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, AdaCore --
+-- Copyright (C) 2002-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-ctrl_c.ads b/gcc/ada/libgnat/g-ctrl_c.ads
index ad1a9cf..c3f2cc8 100644
--- a/gcc/ada/libgnat/g-ctrl_c.ads
+++ b/gcc/ada/libgnat/g-ctrl_c.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, AdaCore --
+-- Copyright (C) 2002-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-curexc.ads b/gcc/ada/libgnat/g-curexc.ads
index 56d89e0..2af5cd8 100644
--- a/gcc/ada/libgnat/g-curexc.ads
+++ b/gcc/ada/libgnat/g-curexc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2019, AdaCore --
+-- Copyright (C) 1996-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-debpoo.adb b/gcc/ada/libgnat/g-debpoo.adb
index 52c0c50..b6523ca 100644
--- a/gcc/ada/libgnat/g-debpoo.adb
+++ b/gcc/ada/libgnat/g-debpoo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1420,6 +1420,7 @@ package body GNAT.Debug_Pools is
begin
Valid := Is_Valid (Storage_Address);
+ Size_In_Storage_Elements := Storage_Count'First;
if Is_Valid (Storage_Address) then
declare
diff --git a/gcc/ada/libgnat/g-debpoo.ads b/gcc/ada/libgnat/g-debpoo.ads
index 6b2f0ab..ed000fa 100644
--- a/gcc/ada/libgnat/g-debpoo.ads
+++ b/gcc/ada/libgnat/g-debpoo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-debuti.adb b/gcc/ada/libgnat/g-debuti.adb
index 07f826a..5b1277d 100644
--- a/gcc/ada/libgnat/g-debuti.adb
+++ b/gcc/ada/libgnat/g-debuti.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, AdaCore --
+-- Copyright (C) 1997-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-debuti.ads b/gcc/ada/libgnat/g-debuti.ads
index 04be683..dab5131 100644
--- a/gcc/ada/libgnat/g-debuti.ads
+++ b/gcc/ada/libgnat/g-debuti.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-decstr.adb b/gcc/ada/libgnat/g-decstr.adb
index 68755a0..64ae297 100644
--- a/gcc/ada/libgnat/g-decstr.adb
+++ b/gcc/ada/libgnat/g-decstr.adb
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-decstr.ads b/gcc/ada/libgnat/g-decstr.ads
index 0f3b1f1..9e82b75 100644
--- a/gcc/ada/libgnat/g-decstr.ads
+++ b/gcc/ada/libgnat/g-decstr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-deutst.ads b/gcc/ada/libgnat/g-deutst.ads
index 5e1009c..e4ae4e19 100644
--- a/gcc/ada/libgnat/g-deutst.ads
+++ b/gcc/ada/libgnat/g-deutst.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-diopit.adb b/gcc/ada/libgnat/g-diopit.adb
index fb62d4f..50bbf9b 100644
--- a/gcc/ada/libgnat/g-diopit.adb
+++ b/gcc/ada/libgnat/g-diopit.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-diopit.ads b/gcc/ada/libgnat/g-diopit.ads
index bf3cc3b..aa60d32 100644
--- a/gcc/ada/libgnat/g-diopit.ads
+++ b/gcc/ada/libgnat/g-diopit.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-dirope.adb b/gcc/ada/libgnat/g-dirope.adb
index 9153c70..3078130 100644
--- a/gcc/ada/libgnat/g-dirope.adb
+++ b/gcc/ada/libgnat/g-dirope.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -352,6 +352,8 @@ package body GNAT.Directory_Operations is
begin
K := K + 1;
+ pragma Annotate (CodePeer, Modified, P);
+
if P = '%' or else Path (K) = '{' then
-- Set terminator character
diff --git a/gcc/ada/libgnat/g-dirope.ads b/gcc/ada/libgnat/g-dirope.ads
index 3747553..03a062f 100644
--- a/gcc/ada/libgnat/g-dirope.ads
+++ b/gcc/ada/libgnat/g-dirope.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-dynhta.adb b/gcc/ada/libgnat/g-dynhta.adb
index 84dcc30..4c8dda5 100644
--- a/gcc/ada/libgnat/g-dynhta.adb
+++ b/gcc/ada/libgnat/g-dynhta.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, AdaCore --
+-- Copyright (C) 2002-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-dynhta.ads b/gcc/ada/libgnat/g-dynhta.ads
index 107c4c0..3e4f561 100644
--- a/gcc/ada/libgnat/g-dynhta.ads
+++ b/gcc/ada/libgnat/g-dynhta.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-dyntab.adb b/gcc/ada/libgnat/g-dyntab.adb
index 1eb0e59..4c53f15 100644
--- a/gcc/ada/libgnat/g-dyntab.adb
+++ b/gcc/ada/libgnat/g-dyntab.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-dyntab.ads b/gcc/ada/libgnat/g-dyntab.ads
index 6a7b5e3..7a6c9fa 100644
--- a/gcc/ada/libgnat/g-dyntab.ads
+++ b/gcc/ada/libgnat/g-dyntab.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-eacodu.adb b/gcc/ada/libgnat/g-eacodu.adb
index 6dd77b8..cb07631 100644
--- a/gcc/ada/libgnat/g-eacodu.adb
+++ b/gcc/ada/libgnat/g-eacodu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-encstr.adb b/gcc/ada/libgnat/g-encstr.adb
index b115c8a..62fff77 100644
--- a/gcc/ada/libgnat/g-encstr.adb
+++ b/gcc/ada/libgnat/g-encstr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-encstr.ads b/gcc/ada/libgnat/g-encstr.ads
index 764710d..0e2fdf4 100644
--- a/gcc/ada/libgnat/g-encstr.ads
+++ b/gcc/ada/libgnat/g-encstr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-enutst.ads b/gcc/ada/libgnat/g-enutst.ads
index b2696e8..e5b20cf 100644
--- a/gcc/ada/libgnat/g-enutst.ads
+++ b/gcc/ada/libgnat/g-enutst.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-excact.adb b/gcc/ada/libgnat/g-excact.adb
index acffd93..202d9e2 100644
--- a/gcc/ada/libgnat/g-excact.adb
+++ b/gcc/ada/libgnat/g-excact.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -38,9 +38,19 @@ with System.Exception_Table; use System.Exception_Table;
package body GNAT.Exception_Actions is
Global_Action : Exception_Action;
- pragma Import (C, Global_Action, "__gnat_exception_actions_global_action");
+ pragma Import
+ (Ada, Global_Action, "__gnat_exception_actions_global_action");
+ pragma Atomic (Global_Action);
-- Imported from Ada.Exceptions. Any change in the external name needs to
- -- be coordinated with a-except.adb
+ -- be coordinated with a-exextr.adb.
+
+ Global_Unhandled_Action : Exception_Action;
+ pragma Import
+ (Ada, Global_Unhandled_Action,
+ "__gnat_exception_actions_global_unhandled_action");
+ pragma Atomic (Global_Unhandled_Action);
+ -- Imported from Ada.Exceptions. Any change in the external name needs to
+ -- be coordinated with a-exextr.adb.
Raise_Hook_Initialized : Boolean;
pragma Import
@@ -61,11 +71,18 @@ package body GNAT.Exception_Actions is
procedure Register_Global_Action (Action : Exception_Action) is
begin
- Lock_Task.all;
Global_Action := Action;
- Unlock_Task.all;
end Register_Global_Action;
+ --------------------------------------
+ -- Register_Global_Unhandled_Action --
+ --------------------------------------
+
+ procedure Register_Global_Unhandled_Action (Action : Exception_Action) is
+ begin
+ Global_Unhandled_Action := Action;
+ end Register_Global_Unhandled_Action;
+
------------------------
-- Register_Id_Action --
------------------------
diff --git a/gcc/ada/libgnat/g-excact.ads b/gcc/ada/libgnat/g-excact.ads
index 92a5329..c38f6a0 100644
--- a/gcc/ada/libgnat/g-excact.ads
+++ b/gcc/ada/libgnat/g-excact.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -57,6 +57,7 @@ package GNAT.Exception_Actions is
type Exception_Action is access
procedure (Occurrence : Exception_Occurrence);
+ pragma Favor_Top_Level (Exception_Action);
-- General callback type whenever an exception is raised. The callback
-- procedure must not propagate an exception (execution of the program
-- is erroneous if such an exception is propagated).
@@ -69,6 +70,10 @@ package GNAT.Exception_Actions is
-- Action is called before the exception is propagated to user's code.
-- If Action is null, this will in effect cancel all exception actions.
+ procedure Register_Global_Unhandled_Action (Action : Exception_Action);
+ -- Similar to Register_Global_Action, called on unhandled exceptions
+ -- only.
+
procedure Register_Id_Action
(Id : Exception_Id;
Action : Exception_Action);
diff --git a/gcc/ada/libgnat/g-except.ads b/gcc/ada/libgnat/g-except.ads
index 1af6fca..6d13f5a 100644
--- a/gcc/ada/libgnat/g-except.ads
+++ b/gcc/ada/libgnat/g-except.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-exctra.adb b/gcc/ada/libgnat/g-exctra.adb
index 371836f..1db76b7 100644
--- a/gcc/ada/libgnat/g-exctra.adb
+++ b/gcc/ada/libgnat/g-exctra.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-exctra.ads b/gcc/ada/libgnat/g-exctra.ads
index 8e0bdae..3ae90f4 100644
--- a/gcc/ada/libgnat/g-exctra.ads
+++ b/gcc/ada/libgnat/g-exctra.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-expect.adb b/gcc/ada/libgnat/g-expect.adb
index 4efd98d..78b3c27 100644
--- a/gcc/ada/libgnat/g-expect.adb
+++ b/gcc/ada/libgnat/g-expect.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-expect.ads b/gcc/ada/libgnat/g-expect.ads
index 77bb579..19e704b 100644
--- a/gcc/ada/libgnat/g-expect.ads
+++ b/gcc/ada/libgnat/g-expect.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-exptty.adb b/gcc/ada/libgnat/g-exptty.adb
index 758be7a..bc239e4 100644
--- a/gcc/ada/libgnat/g-exptty.adb
+++ b/gcc/ada/libgnat/g-exptty.adb
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -314,9 +314,9 @@ package body GNAT.Expect.TTY is
overriding procedure Set_Up_Communications
(Pid : in out TTY_Process_Descriptor;
Err_To_Out : Boolean;
- Pipe1 : access Pipe_Type;
- Pipe2 : access Pipe_Type;
- Pipe3 : access Pipe_Type)
+ Pipe1 : not null access Pipe_Type;
+ Pipe2 : not null access Pipe_Type;
+ Pipe3 : not null access Pipe_Type)
is
pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3);
diff --git a/gcc/ada/libgnat/g-exptty.ads b/gcc/ada/libgnat/g-exptty.ads
index 683a453..ede147c 100644
--- a/gcc/ada/libgnat/g-exptty.ads
+++ b/gcc/ada/libgnat/g-exptty.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -116,9 +116,9 @@ private
procedure Set_Up_Communications
(Pid : in out TTY_Process_Descriptor;
Err_To_Out : Boolean;
- Pipe1 : access Pipe_Type;
- Pipe2 : access Pipe_Type;
- Pipe3 : access Pipe_Type);
+ Pipe1 : not null access Pipe_Type;
+ Pipe2 : not null access Pipe_Type;
+ Pipe3 : not null access Pipe_Type);
procedure Set_Up_Parent_Communications
(Pid : in out TTY_Process_Descriptor;
diff --git a/gcc/ada/libgnat/g-flocon.ads b/gcc/ada/libgnat/g-flocon.ads
index 5ea17f1..bdc9b0e 100644
--- a/gcc/ada/libgnat/g-flocon.ads
+++ b/gcc/ada/libgnat/g-flocon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-forstr.adb b/gcc/ada/libgnat/g-forstr.adb
index 4fb87ec..94492e9 100644
--- a/gcc/ada/libgnat/g-forstr.adb
+++ b/gcc/ada/libgnat/g-forstr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-forstr.ads b/gcc/ada/libgnat/g-forstr.ads
index 4dd5be5..9c15845 100644
--- a/gcc/ada/libgnat/g-forstr.ads
+++ b/gcc/ada/libgnat/g-forstr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-graphs.adb b/gcc/ada/libgnat/g-graphs.adb
index 1049641..410b6ca 100644
--- a/gcc/ada/libgnat/g-graphs.adb
+++ b/gcc/ada/libgnat/g-graphs.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2018-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-graphs.ads b/gcc/ada/libgnat/g-graphs.ads
index 3b65522..ec3fbbc 100644
--- a/gcc/ada/libgnat/g-graphs.ads
+++ b/gcc/ada/libgnat/g-graphs.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2018-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-heasor.adb b/gcc/ada/libgnat/g-heasor.adb
index 00e4108..449cf8d 100644
--- a/gcc/ada/libgnat/g-heasor.adb
+++ b/gcc/ada/libgnat/g-heasor.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-heasor.ads b/gcc/ada/libgnat/g-heasor.ads
index 4d9dd29..bab0c5b 100644
--- a/gcc/ada/libgnat/g-heasor.ads
+++ b/gcc/ada/libgnat/g-heasor.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-hesora.adb b/gcc/ada/libgnat/g-hesora.adb
index 0bef033..f4610e2 100644
--- a/gcc/ada/libgnat/g-hesora.adb
+++ b/gcc/ada/libgnat/g-hesora.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-hesora.ads b/gcc/ada/libgnat/g-hesora.ads
index 0c20479..f7064e4 100644
--- a/gcc/ada/libgnat/g-hesora.ads
+++ b/gcc/ada/libgnat/g-hesora.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-hesorg.adb b/gcc/ada/libgnat/g-hesorg.adb
index fec6e9c..89de591 100644
--- a/gcc/ada/libgnat/g-hesorg.adb
+++ b/gcc/ada/libgnat/g-hesorg.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -45,6 +45,8 @@ package body GNAT.Heap_Sort_G is
-- from 2NlogN to NlogN.
procedure Sort (N : Natural) is
+ pragma Annotate (CodePeer, Skip_Analysis);
+ -- CodePeer is sometimes getting confused on this procedure
Max : Natural := N;
-- Current Max index in tree being sifted
diff --git a/gcc/ada/libgnat/g-hesorg.ads b/gcc/ada/libgnat/g-hesorg.ads
index 7127b68..e2a3b8e 100644
--- a/gcc/ada/libgnat/g-hesorg.ads
+++ b/gcc/ada/libgnat/g-hesorg.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-htable.adb b/gcc/ada/libgnat/g-htable.adb
index 141fe4e..31bce1d 100644
--- a/gcc/ada/libgnat/g-htable.adb
+++ b/gcc/ada/libgnat/g-htable.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-htable.ads b/gcc/ada/libgnat/g-htable.ads
index 4849ade..b7c464d 100644
--- a/gcc/ada/libgnat/g-htable.ads
+++ b/gcc/ada/libgnat/g-htable.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-io-put__vxworks.adb b/gcc/ada/libgnat/g-io-put__vxworks.adb
index 4fef0a1..135e435 100644
--- a/gcc/ada/libgnat/g-io-put__vxworks.adb
+++ b/gcc/ada/libgnat/g-io-put__vxworks.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-io.adb b/gcc/ada/libgnat/g-io.adb
index bc874b5..c2c1ffa 100644
--- a/gcc/ada/libgnat/g-io.adb
+++ b/gcc/ada/libgnat/g-io.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -47,10 +47,10 @@ package body GNAT.IO is
end Get;
procedure Get (C : out Character) is
- function Get_Char return Character;
+ function Get_Char return Integer;
pragma Import (C, Get_Char, "get_char");
begin
- C := Get_Char;
+ C := Character'Val (Get_Char);
end Get;
--------------
@@ -121,16 +121,16 @@ package body GNAT.IO is
end Put;
procedure Put (File : File_Type; C : Character) is
- procedure Put_Char (C : Character);
+ procedure Put_Char (C : Integer);
pragma Import (C, Put_Char, "put_char");
- procedure Put_Char_Stderr (C : Character);
+ procedure Put_Char_Stderr (C : Integer);
pragma Import (C, Put_Char_Stderr, "put_char_stderr");
begin
case File is
- when Stdout => Put_Char (C);
- when Stderr => Put_Char_Stderr (C);
+ when Stdout => Put_Char (Character'Pos (C));
+ when Stderr => Put_Char_Stderr (Character'Pos (C));
end case;
end Put;
diff --git a/gcc/ada/libgnat/g-io.ads b/gcc/ada/libgnat/g-io.ads
index 1b0ec06..2ba9362 100644
--- a/gcc/ada/libgnat/g-io.ads
+++ b/gcc/ada/libgnat/g-io.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-io_aux.adb b/gcc/ada/libgnat/g-io_aux.adb
index daaa364..0590199 100644
--- a/gcc/ada/libgnat/g-io_aux.adb
+++ b/gcc/ada/libgnat/g-io_aux.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-io_aux.ads b/gcc/ada/libgnat/g-io_aux.ads
index 99e0377..aa9978a 100644
--- a/gcc/ada/libgnat/g-io_aux.ads
+++ b/gcc/ada/libgnat/g-io_aux.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-lists.adb b/gcc/ada/libgnat/g-lists.adb
index 817274a..e9414e7 100644
--- a/gcc/ada/libgnat/g-lists.adb
+++ b/gcc/ada/libgnat/g-lists.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2018-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-lists.ads b/gcc/ada/libgnat/g-lists.ads
index fdcaed6..29cda7a 100644
--- a/gcc/ada/libgnat/g-lists.ads
+++ b/gcc/ada/libgnat/g-lists.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2018-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-locfil.adb b/gcc/ada/libgnat/g-locfil.adb
index c5ffb63..7112704 100644
--- a/gcc/ada/libgnat/g-locfil.adb
+++ b/gcc/ada/libgnat/g-locfil.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-locfil.ads b/gcc/ada/libgnat/g-locfil.ads
index 4d05149..4ef4912 100644
--- a/gcc/ada/libgnat/g-locfil.ads
+++ b/gcc/ada/libgnat/g-locfil.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-mbdira.adb b/gcc/ada/libgnat/g-mbdira.adb
index 80117d2..f89a563 100644
--- a/gcc/ada/libgnat/g-mbdira.adb
+++ b/gcc/ada/libgnat/g-mbdira.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-mbdira.ads b/gcc/ada/libgnat/g-mbdira.ads
index 2893db6..f3d7e5e 100644
--- a/gcc/ada/libgnat/g-mbdira.ads
+++ b/gcc/ada/libgnat/g-mbdira.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/g-mbflra.adb b/gcc/ada/libgnat/g-mbflra.adb
index a31f143..2e4498d 100644
--- a/gcc/ada/libgnat/g-mbflra.adb
+++ b/gcc/ada/libgnat/g-mbflra.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-mbflra.ads b/gcc/ada/libgnat/g-mbflra.ads
index 2722659..6c65469 100644
--- a/gcc/ada/libgnat/g-mbflra.ads
+++ b/gcc/ada/libgnat/g-mbflra.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/g-md5.adb b/gcc/ada/libgnat/g-md5.adb
index fa9bb2a..90f2242 100644
--- a/gcc/ada/libgnat/g-md5.adb
+++ b/gcc/ada/libgnat/g-md5.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-md5.ads b/gcc/ada/libgnat/g-md5.ads
index 75d337e..f599c8b 100644
--- a/gcc/ada/libgnat/g-md5.ads
+++ b/gcc/ada/libgnat/g-md5.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-memdum.adb b/gcc/ada/libgnat/g-memdum.adb
index a680cab..ffc8d02 100644
--- a/gcc/ada/libgnat/g-memdum.adb
+++ b/gcc/ada/libgnat/g-memdum.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, AdaCore --
+-- Copyright (C) 2003-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-memdum.ads b/gcc/ada/libgnat/g-memdum.ads
index 2cedbf1..cfb9ad9 100644
--- a/gcc/ada/libgnat/g-memdum.ads
+++ b/gcc/ada/libgnat/g-memdum.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2019, AdaCore --
+-- Copyright (C) 2003-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-moreex.adb b/gcc/ada/libgnat/g-moreex.adb
index 303b4b3..6802b4de 100644
--- a/gcc/ada/libgnat/g-moreex.adb
+++ b/gcc/ada/libgnat/g-moreex.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-moreex.ads b/gcc/ada/libgnat/g-moreex.ads
index b05706d..15c5c67 100644
--- a/gcc/ada/libgnat/g-moreex.ads
+++ b/gcc/ada/libgnat/g-moreex.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-os_lib.adb b/gcc/ada/libgnat/g-os_lib.adb
index 56c1197..608f685 100644
--- a/gcc/ada/libgnat/g-os_lib.adb
+++ b/gcc/ada/libgnat/g-os_lib.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-os_lib.ads b/gcc/ada/libgnat/g-os_lib.ads
index 9796d1e..c178465 100644
--- a/gcc/ada/libgnat/g-os_lib.ads
+++ b/gcc/ada/libgnat/g-os_lib.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-pehage.adb b/gcc/ada/libgnat/g-pehage.adb
index 9b88256..a2c25f1 100644
--- a/gcc/ada/libgnat/g-pehage.adb
+++ b/gcc/ada/libgnat/g-pehage.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, AdaCore --
+-- Copyright (C) 2002-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -622,6 +622,7 @@ package body GNAT.Perfect_Hash_Generators is
E := Get_Edges (J);
if Get_Graph (E.Y) = -1 then
+ pragma Assert (NK /= 0);
Set_Graph (E.Y, (E.Key - Get_Graph (X)) mod NK);
Assign (E.Y);
end if;
@@ -2201,6 +2202,8 @@ package body GNAT.Perfect_Hash_Generators is
-- in the position selection.
for J in S'Range loop
+ pragma Annotate (CodePeer, Modified, S (J));
+
if S (J).First = S (J).Last then
F := S (J).First;
L := S (J).Last;
@@ -2359,6 +2362,10 @@ package body GNAT.Perfect_Hash_Generators is
for P in 1 .. Last_Sel_Pos - 1 loop
if Max_Diff_Sel_Pos < Sel_Position (P) then
+ pragma Annotate
+ (CodePeer, False_Positive,
+ "test always false", "false positive?");
+
Sel_Position (P + 1 .. Last_Sel_Pos) :=
Sel_Position (P .. Last_Sel_Pos - 1);
Sel_Position (P) := Max_Diff_Sel_Pos;
@@ -2525,6 +2532,7 @@ package body GNAT.Perfect_Hash_Generators is
for J in 0 .. T1_Len - 1 loop
exit when Word (J + 1) = ASCII.NUL;
R := Get_Table (Table, J, Get_Used_Char (Word (J + 1)));
+ pragma Assert (NV /= 0);
S := (S + R) mod NV;
end loop;
@@ -2532,6 +2540,7 @@ package body GNAT.Perfect_Hash_Generators is
for J in 0 .. T1_Len - 1 loop
exit when Word (J + 1) = ASCII.NUL;
R := Get_Table (Table, J, 0);
+ pragma Assert (NV /= 0);
S := (S + R * Character'Pos (Word (J + 1))) mod NV;
end loop;
end case;
diff --git a/gcc/ada/libgnat/g-pehage.ads b/gcc/ada/libgnat/g-pehage.ads
index f9dbc61..814f1cc 100644
--- a/gcc/ada/libgnat/g-pehage.ads
+++ b/gcc/ada/libgnat/g-pehage.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, AdaCore --
+-- Copyright (C) 2002-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-rannum.adb b/gcc/ada/libgnat/g-rannum.adb
index ed43a71..b7ef7d1 100644
--- a/gcc/ada/libgnat/g-rannum.adb
+++ b/gcc/ada/libgnat/g-rannum.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-rannum.ads b/gcc/ada/libgnat/g-rannum.ads
index fad5ace..5b633ff 100644
--- a/gcc/ada/libgnat/g-rannum.ads
+++ b/gcc/ada/libgnat/g-rannum.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-regexp.adb b/gcc/ada/libgnat/g-regexp.adb
index b1e6d1f..3d8b8c7 100644
--- a/gcc/ada/libgnat/g-regexp.adb
+++ b/gcc/ada/libgnat/g-regexp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-regexp.ads b/gcc/ada/libgnat/g-regexp.ads
index 162738b..3a21edb 100644
--- a/gcc/ada/libgnat/g-regexp.ads
+++ b/gcc/ada/libgnat/g-regexp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-regist.adb b/gcc/ada/libgnat/g-regist.adb
index 283cb05..fa67f0c 100644
--- a/gcc/ada/libgnat/g-regist.adb
+++ b/gcc/ada/libgnat/g-regist.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-regist.ads b/gcc/ada/libgnat/g-regist.ads
index bb35523..606fa91 100644
--- a/gcc/ada/libgnat/g-regist.ads
+++ b/gcc/ada/libgnat/g-regist.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-regpat.adb b/gcc/ada/libgnat/g-regpat.adb
index 5244a03..b06214b 100644
--- a/gcc/ada/libgnat/g-regpat.adb
+++ b/gcc/ada/libgnat/g-regpat.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1986 by University of Toronto. --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-regpat.ads b/gcc/ada/libgnat/g-regpat.ads
index 62fc2e8..c45e722 100644
--- a/gcc/ada/libgnat/g-regpat.ads
+++ b/gcc/ada/libgnat/g-regpat.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1986 by University of Toronto. --
--- Copyright (C) 1996-2019, AdaCore --
+-- Copyright (C) 1996-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-rewdat.adb b/gcc/ada/libgnat/g-rewdat.adb
index c4906e8..897cac4 100644
--- a/gcc/ada/libgnat/g-rewdat.adb
+++ b/gcc/ada/libgnat/g-rewdat.adb
@@ -5,7 +5,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-rewdat.ads b/gcc/ada/libgnat/g-rewdat.ads
index 8f7602d..108035f 100644
--- a/gcc/ada/libgnat/g-rewdat.ads
+++ b/gcc/ada/libgnat/g-rewdat.ads
@@ -5,7 +5,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sechas.adb b/gcc/ada/libgnat/g-sechas.adb
index edf7d3e..bd97571 100644
--- a/gcc/ada/libgnat/g-sechas.adb
+++ b/gcc/ada/libgnat/g-sechas.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -40,25 +40,25 @@ package body GNAT.Secure_Hashes is
type Fill_Buffer_Access is
access procedure
(M : in out Message_State;
- S : String;
- First : Natural;
- Last : out Natural);
- -- A procedure to transfer data from S, starting at First, into M's block
+ SEA : Stream_Element_Array;
+ First : Stream_Element_Offset;
+ Last : out Stream_Element_Offset);
+ -- A procedure to transfer data from SEA, starting at First, into M's block
-- buffer until either the block buffer is full or all data from S has been
-- consumed.
procedure Fill_Buffer_Copy
(M : in out Message_State;
- S : String;
- First : Natural;
- Last : out Natural);
+ SEA : Stream_Element_Array;
+ First : Stream_Element_Offset;
+ Last : out Stream_Element_Offset);
-- Transfer procedure which just copies data from S to M
procedure Fill_Buffer_Swap
(M : in out Message_State;
- S : String;
- First : Natural;
- Last : out Natural);
+ SEA : Stream_Element_Array;
+ First : Stream_Element_Offset;
+ Last : out Stream_Element_Offset);
-- Transfer procedure which swaps bytes from S when copying into M. S must
-- have even length. Note that the swapping is performed considering pairs
-- starting at S'First, even if S'First /= First (that is, if
@@ -75,22 +75,23 @@ package body GNAT.Secure_Hashes is
procedure Fill_Buffer_Copy
(M : in out Message_State;
- S : String;
- First : Natural;
- Last : out Natural)
+ SEA : Stream_Element_Array;
+ First : Stream_Element_Offset;
+ Last : out Stream_Element_Offset)
is
- Buf_String : String (M.Buffer'Range);
- for Buf_String'Address use M.Buffer'Address;
- pragma Import (Ada, Buf_String);
+ Buf_SEA : Stream_Element_Array (M.Buffer'Range);
+ for Buf_SEA'Address use M.Buffer'Address;
+ pragma Import (Ada, Buf_SEA);
- Length : constant Natural :=
- Natural'Min (M.Block_Length - M.Last, S'Last - First + 1);
+ Length : constant Stream_Element_Offset :=
+ Stream_Element_Offset'Min
+ (M.Block_Length - M.Last, SEA'Last - First + 1);
begin
pragma Assert (Length > 0);
- Buf_String (M.Last + 1 .. M.Last + Length) :=
- S (First .. First + Length - 1);
+ Buf_SEA (M.Last + 1 .. M.Last + Length) :=
+ SEA (First .. First + Length - 1);
M.Last := M.Last + Length;
Last := First + Length - 1;
end Fill_Buffer_Copy;
@@ -101,20 +102,21 @@ package body GNAT.Secure_Hashes is
procedure Fill_Buffer_Swap
(M : in out Message_State;
- S : String;
- First : Natural;
- Last : out Natural)
+ SEA : Stream_Element_Array;
+ First : Stream_Element_Offset;
+ Last : out Stream_Element_Offset)
is
- pragma Assert (S'Length mod 2 = 0);
- Length : constant Natural :=
- Natural'Min (M.Block_Length - M.Last, S'Last - First + 1);
+ pragma Assert (SEA'Length mod 2 = 0);
+ Length : constant Stream_Element_Offset :=
+ Stream_Element_Offset'Min
+ (M.Block_Length - M.Last, SEA'Last - First + 1);
begin
Last := First;
while Last - First < Length loop
M.Buffer (M.Last + 1 + Last - First) :=
- (if (Last - S'First) mod 2 = 0
- then S (Last + 1)
- else S (Last - 1));
+ (if (Last - SEA'First) mod 2 = 0
+ then SEA (Last + 1)
+ else SEA (Last - 1));
Last := Last + 1;
end loop;
M.Last := M.Last + Length;
@@ -146,7 +148,7 @@ package body GNAT.Secure_Hashes is
procedure Update
(C : in out Context;
- S : String;
+ SEA : Stream_Element_Array;
Fill_Buffer : Fill_Buffer_Access);
-- Internal common routine for all Update procedures
@@ -161,8 +163,7 @@ package body GNAT.Secure_Hashes is
------------
function Digest (C : Context) return Message_Digest is
- Hash_Bits : Stream_Element_Array
- (1 .. Stream_Element_Offset (Hash_Length));
+ Hash_Bits : Stream_Element_Array (1 .. Hash_Length);
begin
Final (C, Hash_Bits);
return MD : Message_Digest do
@@ -185,8 +186,7 @@ package body GNAT.Secure_Hashes is
end Digest;
function Digest (C : Context) return Binary_Message_Digest is
- Hash_Bits : Stream_Element_Array
- (1 .. Stream_Element_Offset (Hash_Length));
+ Hash_Bits : Stream_Element_Array (1 .. Hash_Length);
begin
Final (C, Hash_Bits);
return Hash_Bits;
@@ -223,13 +223,13 @@ package body GNAT.Secure_Hashes is
is
FC : Context := C;
- Zeroes : Natural;
+ Zeroes : Stream_Element_Count;
-- Number of 0 bytes in padding
Message_Length : Unsigned_64 := FC.M_State.Length;
-- Message length in bytes
- Size_Length : constant Natural :=
+ Size_Length : constant Stream_Element_Count :=
2 * Hash_State.Word'Size / 8;
-- Length in bytes of the size representation
@@ -237,11 +237,11 @@ package body GNAT.Secure_Hashes is
Zeroes := (Block_Length - 1 - Size_Length - FC.M_State.Last)
mod FC.M_State.Block_Length;
declare
- Pad : String (1 .. 1 + Zeroes + Size_Length) :=
- (1 => Character'Val (128), others => ASCII.NUL);
+ Pad : Stream_Element_Array (1 .. 1 + Zeroes + Size_Length) :=
+ (1 => 128, others => 0);
- Index : Natural;
- First_Index : Natural;
+ Index : Stream_Element_Offset;
+ First_Index : Stream_Element_Offset;
begin
First_Index := (if Hash_Bit_Order = Low_Order_First
@@ -255,12 +255,12 @@ package body GNAT.Secure_Hashes is
-- Message_Length is in bytes, but we need to store it as
-- a bit count.
- Pad (Index) := Character'Val
+ Pad (Index) := Stream_Element
(Shift_Left (Message_Length and 16#1f#, 3));
Message_Length := Shift_Right (Message_Length, 5);
else
- Pad (Index) := Character'Val (Message_Length and 16#ff#);
+ Pad (Index) := Stream_Element (Message_Length and 16#ff#);
Message_Length := Shift_Right (Message_Length, 8);
end if;
@@ -308,7 +308,7 @@ package body GNAT.Secure_Hashes is
return C : Context (KL => (if Key'Length <= Key_Length'Last
then Key'Length
- else Stream_Element_Offset (Hash_Length)))
+ else Hash_Length))
do
-- Set Key (if longer than block length, first hash it)
@@ -361,22 +361,29 @@ package body GNAT.Secure_Hashes is
procedure Update
(C : in out Context;
- S : String;
+ SEA : Stream_Element_Array;
Fill_Buffer : Fill_Buffer_Access)
is
- Last : Natural;
+ First, Last : Stream_Element_Offset;
begin
- C.M_State.Length := C.M_State.Length + S'Length;
+ if SEA'Length = 0 then
+ return;
+ end if;
+
+ C.M_State.Length := C.M_State.Length + SEA'Length;
- Last := S'First - 1;
- while Last < S'Last loop
- Fill_Buffer (C.M_State, S, Last + 1, Last);
+ First := SEA'First;
+ loop
+ Fill_Buffer (C.M_State, SEA, First, Last);
if C.M_State.Last = Block_Length then
Transform (C.H_State, C.M_State);
C.M_State.Last := 0;
end if;
+
+ exit when Last = SEA'Last;
+ First := Last + 1;
end loop;
end Update;
@@ -384,7 +391,7 @@ package body GNAT.Secure_Hashes is
-- Update --
------------
- procedure Update (C : in out Context; Input : String) is
+ procedure Update (C : in out Context; Input : Stream_Element_Array) is
begin
Update (C, Input, Fill_Buffer_Copy'Access);
end Update;
@@ -393,12 +400,13 @@ package body GNAT.Secure_Hashes is
-- Update --
------------
- procedure Update (C : in out Context; Input : Stream_Element_Array) is
- S : String (1 .. Input'Length);
- for S'Address use Input'Address;
- pragma Import (Ada, S);
+ procedure Update (C : in out Context; Input : String) is
+ pragma Assert (Input'Length <= Stream_Element_Offset'Last);
+ SEA : Stream_Element_Array (1 .. Input'Length);
+ for SEA'Address use Input'Address;
+ pragma Import (Ada, SEA);
begin
- Update (C, S, Fill_Buffer_Copy'Access);
+ Update (C, SEA, Fill_Buffer_Copy'Access);
end Update;
-----------------
@@ -406,12 +414,12 @@ package body GNAT.Secure_Hashes is
-----------------
procedure Wide_Update (C : in out Context; Input : Wide_String) is
- S : String (1 .. 2 * Input'Length);
- for S'Address use Input'Address;
- pragma Import (Ada, S);
+ SEA : Stream_Element_Array (1 .. 2 * Input'Length);
+ for SEA'Address use Input'Address;
+ pragma Import (Ada, SEA);
begin
Update
- (C, S,
+ (C, SEA,
(if System.Default_Bit_Order /= Low_Order_First
then Fill_Buffer_Swap'Access
else Fill_Buffer_Copy'Access));
@@ -460,7 +468,7 @@ package body GNAT.Secure_Hashes is
-------------
procedure To_Hash (H : State; H_Bits : out Stream_Element_Array) is
- Hash_Words : constant Natural := H'Size / Word'Size;
+ Hash_Words : constant Stream_Element_Offset := H'Size / Word'Size;
Result : State (1 .. Hash_Words) :=
H (H'Last - Hash_Words + 1 .. H'Last);
diff --git a/gcc/ada/libgnat/g-sechas.ads b/gcc/ada/libgnat/g-sechas.ads
index a259ec3..2edc2e3 100644
--- a/gcc/ada/libgnat/g-sechas.ads
+++ b/gcc/ada/libgnat/g-sechas.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -44,7 +44,7 @@ with System;
package GNAT.Secure_Hashes is
- type Buffer_Type is new String;
+ type Buffer_Type is new Stream_Element_Array;
for Buffer_Type'Alignment use 8;
-- Secure hash functions use a string buffer that is also accessed as an
-- array of words, which may require up to 64 bit alignment.
@@ -52,8 +52,8 @@ package GNAT.Secure_Hashes is
-- The function-independent part of processing state: A buffer of data
-- being accumulated until a complete block is ready for hashing.
- type Message_State (Block_Length : Natural) is record
- Last : Natural := 0;
+ type Message_State (Block_Length : Stream_Element_Count) is record
+ Last : Stream_Element_Offset := 0;
-- Index of last used element in Buffer
Length : Interfaces.Unsigned_64 := 0;
@@ -81,7 +81,7 @@ package GNAT.Secure_Hashes is
package Hash_Function_State is
- type State is array (Natural range <>) of Word;
+ type State is array (Stream_Element_Offset range <>) of Word;
-- Used to store a hash function's internal state
procedure To_Hash
@@ -97,13 +97,13 @@ package GNAT.Secure_Hashes is
-- secure hash function is an instance of this generic package.
generic
- Block_Words : Natural;
+ Block_Words : Stream_Element_Count;
-- Number of words in each block
- State_Words : Natural;
+ State_Words : Stream_Element_Count;
-- Number of words in internal state
- Hash_Words : Natural;
+ Hash_Words : Stream_Element_Count;
-- Number of words in the final hash (must be no greater than
-- State_Words).
@@ -157,11 +157,10 @@ package GNAT.Secure_Hashes is
-- the Wide_String version, each Wide_Character is processed low order
-- byte first.
- Word_Length : constant Natural := Hash_State.Word'Size / 8;
- Hash_Length : constant Natural := Hash_Words * Word_Length;
+ Word_Length : constant Stream_Element_Offset := Hash_State.Word'Size / 8;
+ Hash_Length : constant Stream_Element_Offset := Hash_Words * Word_Length;
- subtype Binary_Message_Digest is
- Stream_Element_Array (1 .. Stream_Element_Offset (Hash_Length));
+ subtype Binary_Message_Digest is Stream_Element_Array (1 .. Hash_Length);
-- The fixed-length byte array returned by Digest, providing
-- the hash in binary representation.
@@ -176,7 +175,7 @@ package GNAT.Secure_Hashes is
-- Wide_Update) on a default initialized Context, followed by Digest
-- on the resulting Context.
- subtype Message_Digest is String (1 .. 2 * Hash_Length);
+ subtype Message_Digest is String (1 .. 2 * Integer (Hash_Length));
-- The fixed-length string returned by Digest, providing the hash in
-- hexadecimal representation.
@@ -199,11 +198,12 @@ package GNAT.Secure_Hashes is
private
- Block_Length : constant Natural := Block_Words * Word_Length;
+ Block_Length : constant Stream_Element_Count :=
+ Block_Words * Word_Length;
-- Length in bytes of a data block
subtype Key_Length is
- Stream_Element_Offset range 0 .. Stream_Element_Offset (Block_Length);
+ Stream_Element_Offset range 0 .. Block_Length;
-- KL is 0 for a normal hash context, > 0 for HMAC
diff --git a/gcc/ada/libgnat/g-sehamd.adb b/gcc/ada/libgnat/g-sehamd.adb
index f759ec8..d82cc36 100644
--- a/gcc/ada/libgnat/g-sehamd.adb
+++ b/gcc/ada/libgnat/g-sehamd.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sehamd.ads b/gcc/ada/libgnat/g-sehamd.ads
index 7cecc92..5f9bfe3 100644
--- a/gcc/ada/libgnat/g-sehamd.ads
+++ b/gcc/ada/libgnat/g-sehamd.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sehash.adb b/gcc/ada/libgnat/g-sehash.adb
index bd94510..470c9b5 100644
--- a/gcc/ada/libgnat/g-sehash.adb
+++ b/gcc/ada/libgnat/g-sehash.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sehash.ads b/gcc/ada/libgnat/g-sehash.ads
index 133a109..ed8aefb 100644
--- a/gcc/ada/libgnat/g-sehash.ads
+++ b/gcc/ada/libgnat/g-sehash.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sercom.adb b/gcc/ada/libgnat/g-sercom.adb
index ccf5239..6f4d5e0 100644
--- a/gcc/ada/libgnat/g-sercom.adb
+++ b/gcc/ada/libgnat/g-sercom.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sercom.ads b/gcc/ada/libgnat/g-sercom.ads
index 52447db..5d4a809 100644
--- a/gcc/ada/libgnat/g-sercom.ads
+++ b/gcc/ada/libgnat/g-sercom.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sercom__linux.adb b/gcc/ada/libgnat/g-sercom__linux.adb
index 87143e2..7d93e57 100644
--- a/gcc/ada/libgnat/g-sercom__linux.adb
+++ b/gcc/ada/libgnat/g-sercom__linux.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sercom__mingw.adb b/gcc/ada/libgnat/g-sercom__mingw.adb
index d5e2344..a0da5ff 100644
--- a/gcc/ada/libgnat/g-sercom__mingw.adb
+++ b/gcc/ada/libgnat/g-sercom__mingw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sestin.ads b/gcc/ada/libgnat/g-sestin.ads
index 236009d..1e74ff8 100644
--- a/gcc/ada/libgnat/g-sestin.ads
+++ b/gcc/ada/libgnat/g-sestin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, AdaCore --
+-- Copyright (C) 2004-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sets.adb b/gcc/ada/libgnat/g-sets.adb
index b588880..9d34553 100644
--- a/gcc/ada/libgnat/g-sets.adb
+++ b/gcc/ada/libgnat/g-sets.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2018-2019, AdaCore --
+-- Copyright (C) 2018-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sets.ads b/gcc/ada/libgnat/g-sets.ads
index 1898e26..18568fa 100644
--- a/gcc/ada/libgnat/g-sets.ads
+++ b/gcc/ada/libgnat/g-sets.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2018-2019, AdaCore --
+-- Copyright (C) 2018-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sha1.adb b/gcc/ada/libgnat/g-sha1.adb
index b84ca95..66e717f 100644
--- a/gcc/ada/libgnat/g-sha1.adb
+++ b/gcc/ada/libgnat/g-sha1.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sha1.ads b/gcc/ada/libgnat/g-sha1.ads
index c662e8f..584c560 100644
--- a/gcc/ada/libgnat/g-sha1.ads
+++ b/gcc/ada/libgnat/g-sha1.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sha224.ads b/gcc/ada/libgnat/g-sha224.ads
index 6a4dd25..fd8b753 100644
--- a/gcc/ada/libgnat/g-sha224.ads
+++ b/gcc/ada/libgnat/g-sha224.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sha256.ads b/gcc/ada/libgnat/g-sha256.ads
index 6f226f8..58d8b16 100644
--- a/gcc/ada/libgnat/g-sha256.ads
+++ b/gcc/ada/libgnat/g-sha256.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sha384.ads b/gcc/ada/libgnat/g-sha384.ads
index dc5df0a..32ea088 100644
--- a/gcc/ada/libgnat/g-sha384.ads
+++ b/gcc/ada/libgnat/g-sha384.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sha512.ads b/gcc/ada/libgnat/g-sha512.ads
index 42926ff..6d7c0ee 100644
--- a/gcc/ada/libgnat/g-sha512.ads
+++ b/gcc/ada/libgnat/g-sha512.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-shsh32.adb b/gcc/ada/libgnat/g-shsh32.adb
index 4036ad6..1631562 100644
--- a/gcc/ada/libgnat/g-shsh32.adb
+++ b/gcc/ada/libgnat/g-shsh32.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-shsh32.ads b/gcc/ada/libgnat/g-shsh32.ads
index 6359001..3f46df3 100644
--- a/gcc/ada/libgnat/g-shsh32.ads
+++ b/gcc/ada/libgnat/g-shsh32.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-shsh64.adb b/gcc/ada/libgnat/g-shsh64.adb
index bf95a3d..061c407 100644
--- a/gcc/ada/libgnat/g-shsh64.adb
+++ b/gcc/ada/libgnat/g-shsh64.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-shsh64.ads b/gcc/ada/libgnat/g-shsh64.ads
index 5d8e07a..010e5c4 100644
--- a/gcc/ada/libgnat/g-shsh64.ads
+++ b/gcc/ada/libgnat/g-shsh64.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-shshco.adb b/gcc/ada/libgnat/g-shshco.adb
index c0802ce..89e27f0 100644
--- a/gcc/ada/libgnat/g-shshco.adb
+++ b/gcc/ada/libgnat/g-shshco.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -108,7 +108,8 @@ package body GNAT.Secure_Hashes.SHA2_Common is
-- 3. Perform transformation rounds
for T in 0 .. Rounds - 1 loop
- T1 := H + Sigma1 (E) + Ch (E, F, G) + K (T) + W (T);
+ T1 := H + Sigma1 (E) + Ch (E, F, G)
+ + K (Stream_Element_Offset (T)) + W (T);
T2 := Sigma0 (A) + Maj (A, B, C);
H := G;
G := F;
diff --git a/gcc/ada/libgnat/g-shshco.ads b/gcc/ada/libgnat/g-shshco.ads
index 8f0e84c..8c389dd 100644
--- a/gcc/ada/libgnat/g-shshco.ads
+++ b/gcc/ada/libgnat/g-shshco.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-soccon.ads b/gcc/ada/libgnat/g-soccon.ads
index 0fe12dc..06cf683 100644
--- a/gcc/ada/libgnat/g-soccon.ads
+++ b/gcc/ada/libgnat/g-soccon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-socket.adb b/gcc/ada/libgnat/g-socket.adb
index 6c65424..719d9a9 100644
--- a/gcc/ada/libgnat/g-socket.adb
+++ b/gcc/ada/libgnat/g-socket.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,14 +29,14 @@
-- --
------------------------------------------------------------------------------
-with Ada.Streams; use Ada.Streams;
-with Ada.Exceptions; use Ada.Exceptions;
with Ada.Containers.Generic_Array_Sort;
+with Ada.Exceptions; use Ada.Exceptions;
with Ada.Finalization;
+with Ada.Streams; use Ada.Streams;
with Ada.Unchecked_Conversion;
-with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common;
with GNAT.Sockets.Thin; use GNAT.Sockets.Thin;
+with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common;
with GNAT.Sockets.Linker_Options;
pragma Warnings (Off, GNAT.Sockets.Linker_Options);
@@ -291,7 +291,7 @@ package body GNAT.Sockets is
function Create_Address
(Family : Family_Inet_4_6; Bytes : Inet_Addr_Bytes) return Inet_Addr_Type
with Inline;
- -- Creates address from family and Inet_Addr_Bytes array.
+ -- Creates address from family and Inet_Addr_Bytes array
function Get_Bytes (Addr : Inet_Addr_Type) return Inet_Addr_Bytes
with Inline;
@@ -836,6 +836,7 @@ package body GNAT.Sockets is
-- the waiting task to resume its execution.
Res := Signalling_Fds.Create (Two_Fds'Access);
+ pragma Annotate (CodePeer, Modified, Two_Fds);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
@@ -886,6 +887,7 @@ package body GNAT.Sockets is
((if Family = Family_Unspec then Default_Socket_Pair_Family
else Families (Family)),
Modes (Mode), Levels (Level), Pair'Access);
+ pragma Annotate (CodePeer, Modified, Pair);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
@@ -957,8 +959,12 @@ package body GNAT.Sockets is
if Item.Last /= No_Socket then
Get_Socket_From_Set
(Item.Set'Access, Last => L'Access, Socket => S'Access);
+ pragma Annotate (CodePeer, Modified, L);
+ pragma Annotate (CodePeer, Modified, S);
+
Item.Last := Socket_Type (L);
Socket := Socket_Type (S);
+
else
Socket := No_Socket;
end if;
@@ -1216,7 +1222,7 @@ package body GNAT.Sockets is
pragma Unreferenced (Family);
HA : aliased In_Addr_Union (Address.Family);
- Buflen : constant C.int := Netdb_Buffer_Size;
+ Buflen : constant C.size_t := Netdb_Buffer_Size;
Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
Res : aliased Hostent;
Err : aliased C.int;
@@ -1271,7 +1277,7 @@ package body GNAT.Sockets is
declare
HN : constant C.char_array := C.To_C (Name);
- Buflen : constant C.int := Netdb_Buffer_Size;
+ Buflen : constant C.size_t := Netdb_Buffer_Size;
Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
Res : aliased Hostent;
Err : aliased C.int;
@@ -1319,7 +1325,7 @@ package body GNAT.Sockets is
is
SN : constant C.char_array := C.To_C (Name);
SP : constant C.char_array := C.To_C (Protocol);
- Buflen : constant C.int := Netdb_Buffer_Size;
+ Buflen : constant C.size_t := Netdb_Buffer_Size;
Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
Res : aliased Servent;
@@ -1349,7 +1355,7 @@ package body GNAT.Sockets is
Protocol : String) return Service_Entry_Type
is
SP : constant C.char_array := C.To_C (Protocol);
- Buflen : constant C.int := Netdb_Buffer_Size;
+ Buflen : constant C.size_t := Netdb_Buffer_Size;
Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
Res : aliased Servent;
@@ -2022,7 +2028,11 @@ package body GNAT.Sockets is
type Local_Selector_Access is access Selector_Type;
for Local_Selector_Access'Storage_Size use Selector_Type'Size;
- S : Selector_Access;
+ procedure Unchecked_Free is new Ada.Unchecked_Deallocation
+ (Selector_Type, Local_Selector_Access);
+
+ Local_S : Local_Selector_Access;
+ S : Selector_Access;
-- Selector to use for waiting
R_Fd_Set : Socket_Set_Type;
@@ -2032,12 +2042,9 @@ package body GNAT.Sockets is
-- Create selector if not provided by the user
if Selector = null then
- declare
- Local_S : constant Local_Selector_Access := new Selector_Type;
- begin
- S := Local_S.all'Unchecked_Access;
- Create_Selector (S.all);
- end;
+ Local_S := new Selector_Type;
+ S := Local_S.all'Unchecked_Access;
+ Create_Selector (S.all);
else
S := Selector.all'Access;
@@ -2053,7 +2060,17 @@ package body GNAT.Sockets is
if Selector = null then
Close_Selector (S.all);
+ Unchecked_Free (Local_S);
end if;
+
+ exception
+ when others =>
+ Status := Completed;
+
+ if Selector = null then
+ Close_Selector (S.all);
+ Unchecked_Free (Local_S);
+ end if;
end Wait_On_Socket;
-----------------
@@ -2709,14 +2726,14 @@ package body GNAT.Sockets is
U4 := C.unsigned (Option.Timeout / 0.001);
if Option.Timeout > 0.0 and then U4 = 0 then
- -- Avoid round to zero. Zero timeout mean unlimited.
+ -- Avoid round to zero. Zero timeout mean unlimited
U4 := 1;
end if;
-- Old windows versions actual timeout is 500 ms + the given
-- value (unless it is 0).
- if Minus_500ms_Windows_Timeout /= 0 then
+ if Minus_500ms_Windows_Timeout then
if U4 > 500 then
U4 := U4 - 500;
@@ -2833,9 +2850,11 @@ package body GNAT.Sockets is
-- Check for possible Duration overflow when Tv_Sec field is 64 bit
-- integer.
- if Val.Tv_Sec > time_t (Max_D) or else
- (Val.Tv_Sec = time_t (Max_D) and then
- Val.Tv_Usec > suseconds_t ((Forever - Duration (Max_D)) * 1E6))
+ if Val.Tv_Sec > time_t (Max_D)
+ or else
+ (Val.Tv_Sec = time_t (Max_D)
+ and then
+ Val.Tv_Usec > suseconds_t ((Forever - Duration (Max_D)) * 1E6))
then
return Forever;
end if;
@@ -2921,8 +2940,7 @@ package body GNAT.Sockets is
-- To_Int --
------------
- function To_Int (F : Request_Flag_Type) return C.int
- is
+ function To_Int (F : Request_Flag_Type) return C.int is
Current : Request_Flag_Type := F;
Result : C.int := 0;
@@ -2932,6 +2950,10 @@ package body GNAT.Sockets is
if Current mod 2 /= 0 then
if Flags (J) = -1 then
+ pragma Annotate
+ (CodePeer, False_Positive,
+ "test always false", "self fulfilling prophecy");
+
Raise_Socket_Error (SOSC.EOPNOTSUPP);
end if;
diff --git a/gcc/ada/libgnat/g-socket.ads b/gcc/ada/libgnat/g-socket.ads
index 3962cc0..9167241 100644
--- a/gcc/ada/libgnat/g-socket.ads
+++ b/gcc/ada/libgnat/g-socket.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-socket__dummy.adb b/gcc/ada/libgnat/g-socket__dummy.adb
index 6873185..a343eab 100644
--- a/gcc/ada/libgnat/g-socket__dummy.adb
+++ b/gcc/ada/libgnat/g-socket__dummy.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-socket__dummy.ads b/gcc/ada/libgnat/g-socket__dummy.ads
index 67f9e0f..2cd7460 100644
--- a/gcc/ada/libgnat/g-socket__dummy.ads
+++ b/gcc/ada/libgnat/g-socket__dummy.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-socthi.adb b/gcc/ada/libgnat/g-socthi.adb
index d1640f1..5d86993 100644
--- a/gcc/ada/libgnat/g-socthi.adb
+++ b/gcc/ada/libgnat/g-socthi.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -74,17 +74,17 @@ package body GNAT.Sockets.Thin is
function Syscall_Recv
(S : C.int;
Msg : System.Address;
- Len : C.int;
- Flags : C.int) return C.int;
+ Len : C.size_t;
+ Flags : C.int) return System.CRTL.ssize_t;
pragma Import (C, Syscall_Recv, "recv");
function Syscall_Recvfrom
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int;
From : System.Address;
- Fromlen : not null access C.int) return C.int;
+ Fromlen : not null access C.int) return System.CRTL.ssize_t;
pragma Import (C, Syscall_Recvfrom, "recvfrom");
function Syscall_Recvmsg
@@ -102,10 +102,10 @@ package body GNAT.Sockets.Thin is
function Syscall_Sendto
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int;
To : System.Address;
- Tolen : C.int) return C.int;
+ Tolen : C.int) return System.CRTL.ssize_t;
pragma Import (C, Syscall_Sendto, "sendto");
function Syscall_Socket
@@ -250,14 +250,14 @@ package body GNAT.Sockets.Thin is
function C_Recv
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int) return C.int
is
Res : C.int;
begin
loop
- Res := Syscall_Recv (S, Msg, Len, Flags);
+ Res := C.int (Syscall_Recv (S, Msg, Len, Flags));
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
@@ -275,7 +275,7 @@ package body GNAT.Sockets.Thin is
function C_Recvfrom
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int;
From : System.Address;
Fromlen : not null access C.int) return C.int
@@ -284,7 +284,7 @@ package body GNAT.Sockets.Thin is
begin
loop
- Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
+ Res := C.int (Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen));
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
@@ -350,7 +350,7 @@ package body GNAT.Sockets.Thin is
function C_Sendto
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int;
To : System.Address;
Tolen : C.int) return C.int
@@ -359,7 +359,7 @@ package body GNAT.Sockets.Thin is
begin
loop
- Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
+ Res := C.int (Syscall_Sendto (S, Msg, Len, Flags, To, Tolen));
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
diff --git a/gcc/ada/libgnat/g-socthi.ads b/gcc/ada/libgnat/g-socthi.ads
index 56b31ac..c6a07ba 100644
--- a/gcc/ada/libgnat/g-socthi.ads
+++ b/gcc/ada/libgnat/g-socthi.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -98,7 +98,7 @@ package GNAT.Sockets.Thin is
function C_Gethostname
(Name : System.Address;
- Namelen : C.int) return C.int;
+ Namelen : C.size_t) return C.int;
function C_Getpeername
(S : C.int;
@@ -129,13 +129,13 @@ package GNAT.Sockets.Thin is
function C_Recv
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int) return C.int;
function C_Recvfrom
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int;
From : System.Address;
Fromlen : not null access C.int) return C.int;
@@ -160,7 +160,7 @@ package GNAT.Sockets.Thin is
function C_Sendto
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int;
To : System.Address;
Tolen : C.int) return C.int;
diff --git a/gcc/ada/libgnat/g-socthi__dummy.adb b/gcc/ada/libgnat/g-socthi__dummy.adb
index c83f9e8..53acef5 100644
--- a/gcc/ada/libgnat/g-socthi__dummy.adb
+++ b/gcc/ada/libgnat/g-socthi__dummy.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-socthi__dummy.ads b/gcc/ada/libgnat/g-socthi__dummy.ads
index 3aacf17..3ddcdb4 100644
--- a/gcc/ada/libgnat/g-socthi__dummy.ads
+++ b/gcc/ada/libgnat/g-socthi__dummy.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-socthi__mingw.adb b/gcc/ada/libgnat/g-socthi__mingw.adb
index 5ad292d..f63a6cb 100644
--- a/gcc/ada/libgnat/g-socthi__mingw.adb
+++ b/gcc/ada/libgnat/g-socthi__mingw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-socthi__mingw.ads b/gcc/ada/libgnat/g-socthi__mingw.ads
index a5aa67e..ff6feaa 100644
--- a/gcc/ada/libgnat/g-socthi__mingw.ads
+++ b/gcc/ada/libgnat/g-socthi__mingw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-socthi__vxworks.adb b/gcc/ada/libgnat/g-socthi__vxworks.adb
index a2bbed6..548b9d3 100644
--- a/gcc/ada/libgnat/g-socthi__vxworks.adb
+++ b/gcc/ada/libgnat/g-socthi__vxworks.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, AdaCore --
+-- Copyright (C) 2002-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -78,14 +78,14 @@ package body GNAT.Sockets.Thin is
function Syscall_Recv
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int) return C.int;
pragma Import (C, Syscall_Recv, "recv");
function Syscall_Recvfrom
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int;
From : System.Address;
Fromlen : not null access C.int) return C.int;
@@ -106,17 +106,17 @@ package body GNAT.Sockets.Thin is
function Syscall_Send
(S : C.int;
Msg : System.Address;
- Len : C.int;
- Flags : C.int) return C.int;
+ Len : C.size_t;
+ Flags : C.int) return System.CRTL.ssize_t;
pragma Import (C, Syscall_Send, "send");
function Syscall_Sendto
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int;
To : System.Address;
- Tolen : C.int) return C.int;
+ Tolen : C.int) return System.CRTL.ssize_t;
pragma Import (C, Syscall_Sendto, "sendto");
function Syscall_Socket
@@ -252,7 +252,7 @@ package body GNAT.Sockets.Thin is
function C_Recv
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int) return C.int
is
Res : C.int;
@@ -277,7 +277,7 @@ package body GNAT.Sockets.Thin is
function C_Recvfrom
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int;
From : System.Address;
Fromlen : not null access C.int) return C.int
@@ -352,7 +352,7 @@ package body GNAT.Sockets.Thin is
function C_Sendto
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int;
To : System.Address;
Tolen : C.int) return C.int
@@ -369,12 +369,12 @@ package body GNAT.Sockets.Thin is
-- support sendto(2) calls on connected sockets with a null
-- destination address, so use send(2) instead in that case.
- Res := Syscall_Send (S, Msg, Len, Flags);
+ Res := C.int (Syscall_Send (S, Msg, Len, Flags));
-- Normal case where destination address is non-null
else
- Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
+ Res := C.int (Syscall_Sendto (S, Msg, Len, Flags, To, Tolen));
end if;
exit when SOSC.Thread_Blocking_IO
diff --git a/gcc/ada/libgnat/g-socthi__vxworks.ads b/gcc/ada/libgnat/g-socthi__vxworks.ads
index 664218d..704ec0a 100644
--- a/gcc/ada/libgnat/g-socthi__vxworks.ads
+++ b/gcc/ada/libgnat/g-socthi__vxworks.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, AdaCore --
+-- Copyright (C) 2002-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -95,7 +95,7 @@ package GNAT.Sockets.Thin is
function C_Gethostname
(Name : System.Address;
- Namelen : C.int) return C.int;
+ Namelen : C.size_t) return C.int;
function C_Getpeername
(S : C.int;
@@ -126,13 +126,13 @@ package GNAT.Sockets.Thin is
function C_Recv
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int) return C.int;
function C_Recvfrom
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int;
From : System.Address;
Fromlen : not null access C.int) return C.int;
@@ -157,7 +157,7 @@ package GNAT.Sockets.Thin is
function C_Sendto
(S : C.int;
Msg : System.Address;
- Len : C.int;
+ Len : C.size_t;
Flags : C.int;
To : System.Address;
Tolen : C.int) return C.int;
diff --git a/gcc/ada/libgnat/g-soliop.ads b/gcc/ada/libgnat/g-soliop.ads
index cbbf015..295d812 100644
--- a/gcc/ada/libgnat/g-soliop.ads
+++ b/gcc/ada/libgnat/g-soliop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-soliop__lynxos.ads b/gcc/ada/libgnat/g-soliop__lynxos.ads
index f9f8b89..227c2e4 100644
--- a/gcc/ada/libgnat/g-soliop__lynxos.ads
+++ b/gcc/ada/libgnat/g-soliop__lynxos.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-soliop__mingw.ads b/gcc/ada/libgnat/g-soliop__mingw.ads
index cca249d..cbb3e36 100644
--- a/gcc/ada/libgnat/g-soliop__mingw.ads
+++ b/gcc/ada/libgnat/g-soliop__mingw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-soliop__qnx.ads b/gcc/ada/libgnat/g-soliop__qnx.ads
index 5ea4d8d..c45bd04 100644
--- a/gcc/ada/libgnat/g-soliop__qnx.ads
+++ b/gcc/ada/libgnat/g-soliop__qnx.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-soliop__solaris.ads b/gcc/ada/libgnat/g-soliop__solaris.ads
index 613b343..388b87c 100644
--- a/gcc/ada/libgnat/g-soliop__solaris.ads
+++ b/gcc/ada/libgnat/g-soliop__solaris.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sothco.adb b/gcc/ada/libgnat/g-sothco.adb
index 9794d8b..1b8dd49 100644
--- a/gcc/ada/libgnat/g-sothco.adb
+++ b/gcc/ada/libgnat/g-sothco.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, AdaCore --
+-- Copyright (C) 2008-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sothco.ads b/gcc/ada/libgnat/g-sothco.ads
index a68019c..e30af18 100644
--- a/gcc/ada/libgnat/g-sothco.ads
+++ b/gcc/ada/libgnat/g-sothco.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, AdaCore --
+-- Copyright (C) 2008-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -281,7 +281,7 @@ package GNAT.Sockets.Thin_Common is
(Name : C.char_array;
Ret : not null access Hostent;
Buf : System.Address;
- Buflen : C.int;
+ Buflen : C.size_t;
H_Errnop : not null access C.int) return C.int;
function C_Gethostbyaddr
@@ -290,7 +290,7 @@ package GNAT.Sockets.Thin_Common is
Addr_Type : C.int;
Ret : not null access Hostent;
Buf : System.Address;
- Buflen : C.int;
+ Buflen : C.size_t;
H_Errnop : not null access C.int) return C.int;
function C_Getservbyname
@@ -298,14 +298,14 @@ package GNAT.Sockets.Thin_Common is
Proto : C.char_array;
Ret : not null access Servent;
Buf : System.Address;
- Buflen : C.int) return C.int;
+ Buflen : C.size_t) return C.int;
function C_Getservbyport
(Port : C.int;
Proto : C.char_array;
Ret : not null access Servent;
Buf : System.Address;
- Buflen : C.int) return C.int;
+ Buflen : C.size_t) return C.int;
Address_Size : constant := Standard'Address_Size;
@@ -451,12 +451,19 @@ package GNAT.Sockets.Thin_Common is
renames Short_To_Network;
-- Symmetric operation
- function Minus_500ms_Windows_Timeout return C.int;
+ Minus_500ms_Windows_Timeout : constant Boolean;
-- Microsoft Windows desktop older then 8.0 and Microsoft Windows Server
-- older than 2019 need timeout correction for 500 milliseconds. This
- -- routine returns 1 for such versions.
+ -- constant is True for such versions.
private
+
+ function Get_Minus_500ms_Timeout return C.int
+ with Import, Convention => C, External_Name => "__gnat_minus_500ms";
+
+ Minus_500ms_Windows_Timeout : constant Boolean :=
+ Get_Minus_500ms_Timeout /= 0;
+
pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set");
pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set");
pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set");
@@ -488,6 +495,4 @@ private
pragma Import (C, Hostent_H_Length, "__gnat_hostent_h_length");
pragma Import (C, Hostent_H_Addr, "__gnat_hostent_h_addr");
- pragma Import (C, Minus_500ms_Windows_Timeout, "__gnat_minus_500ms");
-
end GNAT.Sockets.Thin_Common;
diff --git a/gcc/ada/libgnat/g-sothco__dummy.adb b/gcc/ada/libgnat/g-sothco__dummy.adb
index 62f99bb..8c90ab0 100644
--- a/gcc/ada/libgnat/g-sothco__dummy.adb
+++ b/gcc/ada/libgnat/g-sothco__dummy.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sothco__dummy.ads b/gcc/ada/libgnat/g-sothco__dummy.ads
index ae3e5cc..d93916a 100644
--- a/gcc/ada/libgnat/g-sothco__dummy.ads
+++ b/gcc/ada/libgnat/g-sothco__dummy.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, AdaCore --
+-- Copyright (C) 2008-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-souinf.ads b/gcc/ada/libgnat/g-souinf.ads
index bdd27a5..ce55464 100644
--- a/gcc/ada/libgnat/g-souinf.ads
+++ b/gcc/ada/libgnat/g-souinf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-spchge.adb b/gcc/ada/libgnat/g-spchge.adb
index ad70fad..62f1666 100644
--- a/gcc/ada/libgnat/g-spchge.adb
+++ b/gcc/ada/libgnat/g-spchge.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-spchge.ads b/gcc/ada/libgnat/g-spchge.ads
index 93e8dbc..a0ce625 100644
--- a/gcc/ada/libgnat/g-spchge.ads
+++ b/gcc/ada/libgnat/g-spchge.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-speche.adb b/gcc/ada/libgnat/g-speche.adb
index 21c1d85..545ca42 100644
--- a/gcc/ada/libgnat/g-speche.adb
+++ b/gcc/ada/libgnat/g-speche.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-speche.ads b/gcc/ada/libgnat/g-speche.ads
index d566e1e..a906e43 100644
--- a/gcc/ada/libgnat/g-speche.ads
+++ b/gcc/ada/libgnat/g-speche.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-spipat.adb b/gcc/ada/libgnat/g-spipat.adb
index 699b322..e9f4bf5 100644
--- a/gcc/ada/libgnat/g-spipat.adb
+++ b/gcc/ada/libgnat/g-spipat.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-spipat.ads b/gcc/ada/libgnat/g-spipat.ads
index 4dfc25a..d711b3b6 100644
--- a/gcc/ada/libgnat/g-spipat.ads
+++ b/gcc/ada/libgnat/g-spipat.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2019, AdaCore --
+-- Copyright (C) 1997-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-spitbo.adb b/gcc/ada/libgnat/g-spitbo.adb
index ad56822..07ecd52 100644
--- a/gcc/ada/libgnat/g-spitbo.adb
+++ b/gcc/ada/libgnat/g-spitbo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-spitbo.ads b/gcc/ada/libgnat/g-spitbo.ads
index 126972f..29a0606 100644
--- a/gcc/ada/libgnat/g-spitbo.ads
+++ b/gcc/ada/libgnat/g-spitbo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2019, AdaCore --
+-- Copyright (C) 1997-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -126,7 +126,7 @@ package GNAT.Spitbol is
Len : Natural;
Pad : Character := ' ') return VString;
-- If the length of Str is greater than or equal to Len, then Str is
- -- returned unchanged. Otherwise, The value returned is obtained by
+ -- returned unchanged. Otherwise, the value returned is obtained by
-- concatenating Length (Str) - Len instances of the Pad character to
-- the left hand side.
@@ -155,7 +155,7 @@ package GNAT.Spitbol is
Len : Natural;
Pad : Character := ' ') return VString;
-- If the length of Str is greater than or equal to Len, then Str is
- -- returned unchanged. Otherwise, The value returned is obtained by
+ -- returned unchanged. Otherwise, the value returned is obtained by
-- concatenating Length (Str) - Len instances of the Pad character to
-- the right hand side.
diff --git a/gcc/ada/libgnat/g-sptabo.ads b/gcc/ada/libgnat/g-sptabo.ads
index 06de800..4aa1a76 100644
--- a/gcc/ada/libgnat/g-sptabo.ads
+++ b/gcc/ada/libgnat/g-sptabo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2019, AdaCore --
+-- Copyright (C) 1997-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sptain.ads b/gcc/ada/libgnat/g-sptain.ads
index 0a0933c..065a33d 100644
--- a/gcc/ada/libgnat/g-sptain.ads
+++ b/gcc/ada/libgnat/g-sptain.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2019, AdaCore --
+-- Copyright (C) 1997-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sptavs.ads b/gcc/ada/libgnat/g-sptavs.ads
index 8b7d85c..2771cf5 100644
--- a/gcc/ada/libgnat/g-sptavs.ads
+++ b/gcc/ada/libgnat/g-sptavs.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2019, AdaCore --
+-- Copyright (C) 1997-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sse.ads b/gcc/ada/libgnat/g-sse.ads
index 915eda3..fc220bd 100644
--- a/gcc/ada/libgnat/g-sse.ads
+++ b/gcc/ada/libgnat/g-sse.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-ssvety.ads b/gcc/ada/libgnat/g-ssvety.ads
index 53e8dc1..d7b134d 100644
--- a/gcc/ada/libgnat/g-ssvety.ads
+++ b/gcc/ada/libgnat/g-ssvety.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-sthcso.adb b/gcc/ada/libgnat/g-sthcso.adb
index 49c55f2..f6345d4 100644
--- a/gcc/ada/libgnat/g-sthcso.adb
+++ b/gcc/ada/libgnat/g-sthcso.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-stheme.adb b/gcc/ada/libgnat/g-stheme.adb
index 38859dd..679adf0 100644
--- a/gcc/ada/libgnat/g-stheme.adb
+++ b/gcc/ada/libgnat/g-stheme.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-strhas.ads b/gcc/ada/libgnat/g-strhas.ads
index 266c2e1..f6949b5 100644
--- a/gcc/ada/libgnat/g-strhas.ads
+++ b/gcc/ada/libgnat/g-strhas.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2015-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-string.adb b/gcc/ada/libgnat/g-string.adb
index a4d3c54..7d820c6 100644
--- a/gcc/ada/libgnat/g-string.adb
+++ b/gcc/ada/libgnat/g-string.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-string.ads b/gcc/ada/libgnat/g-string.ads
index 37d86a4..8d35847 100644
--- a/gcc/ada/libgnat/g-string.ads
+++ b/gcc/ada/libgnat/g-string.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-strspl.ads b/gcc/ada/libgnat/g-strspl.ads
index af58dc6..0995e2b 100644
--- a/gcc/ada/libgnat/g-strspl.ads
+++ b/gcc/ada/libgnat/g-strspl.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-stseme.adb b/gcc/ada/libgnat/g-stseme.adb
index e752622..ad78669 100644
--- a/gcc/ada/libgnat/g-stseme.adb
+++ b/gcc/ada/libgnat/g-stseme.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-stsifd__sockets.adb b/gcc/ada/libgnat/g-stsifd__sockets.adb
index 90c98b7..6d018e2 100644
--- a/gcc/ada/libgnat/g-stsifd__sockets.adb
+++ b/gcc/ada/libgnat/g-stsifd__sockets.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-table.adb b/gcc/ada/libgnat/g-table.adb
index bcced26..8872a4c 100644
--- a/gcc/ada/libgnat/g-table.adb
+++ b/gcc/ada/libgnat/g-table.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-table.ads b/gcc/ada/libgnat/g-table.ads
index 68c851c..752f1dc 100644
--- a/gcc/ada/libgnat/g-table.ads
+++ b/gcc/ada/libgnat/g-table.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-tasloc.adb b/gcc/ada/libgnat/g-tasloc.adb
index ca46b89..64c4940 100644
--- a/gcc/ada/libgnat/g-tasloc.adb
+++ b/gcc/ada/libgnat/g-tasloc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, AdaCore --
+-- Copyright (C) 1997-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-tasloc.ads b/gcc/ada/libgnat/g-tasloc.ads
index 7770c27b..b8ccb83 100644
--- a/gcc/ada/libgnat/g-tasloc.ads
+++ b/gcc/ada/libgnat/g-tasloc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-timsta.adb b/gcc/ada/libgnat/g-timsta.adb
index 1c34082..6bc12ab 100644
--- a/gcc/ada/libgnat/g-timsta.adb
+++ b/gcc/ada/libgnat/g-timsta.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-timsta.ads b/gcc/ada/libgnat/g-timsta.ads
index fa3c2e0..df87840 100644
--- a/gcc/ada/libgnat/g-timsta.ads
+++ b/gcc/ada/libgnat/g-timsta.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-traceb.adb b/gcc/ada/libgnat/g-traceb.adb
index 9cf04de..c826dd5 100644
--- a/gcc/ada/libgnat/g-traceb.adb
+++ b/gcc/ada/libgnat/g-traceb.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-traceb.ads b/gcc/ada/libgnat/g-traceb.ads
index 6a565c9..0bd1ddf 100644
--- a/gcc/ada/libgnat/g-traceb.ads
+++ b/gcc/ada/libgnat/g-traceb.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-trasym.adb b/gcc/ada/libgnat/g-trasym.adb
index ecc2aac..064724c 100644
--- a/gcc/ada/libgnat/g-trasym.adb
+++ b/gcc/ada/libgnat/g-trasym.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-trasym.ads b/gcc/ada/libgnat/g-trasym.ads
index 5d3620c..03055d4 100644
--- a/gcc/ada/libgnat/g-trasym.ads
+++ b/gcc/ada/libgnat/g-trasym.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-tty.adb b/gcc/ada/libgnat/g-tty.adb
index da9a60f..ff3bb46 100644
--- a/gcc/ada/libgnat/g-tty.adb
+++ b/gcc/ada/libgnat/g-tty.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, AdaCore --
+-- Copyright (C) 2002-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-tty.ads b/gcc/ada/libgnat/g-tty.ads
index 022a778..502850b 100644
--- a/gcc/ada/libgnat/g-tty.ads
+++ b/gcc/ada/libgnat/g-tty.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, AdaCore --
+-- Copyright (C) 2002-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-u3spch.adb b/gcc/ada/libgnat/g-u3spch.adb
index 0012953..a225afb 100644
--- a/gcc/ada/libgnat/g-u3spch.adb
+++ b/gcc/ada/libgnat/g-u3spch.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-u3spch.ads b/gcc/ada/libgnat/g-u3spch.ads
index c31d604..8960231 100644
--- a/gcc/ada/libgnat/g-u3spch.ads
+++ b/gcc/ada/libgnat/g-u3spch.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-utf_32.adb b/gcc/ada/libgnat/g-utf_32.adb
index dd5a9b6..82958f8 100644
--- a/gcc/ada/libgnat/g-utf_32.adb
+++ b/gcc/ada/libgnat/g-utf_32.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-utf_32.ads b/gcc/ada/libgnat/g-utf_32.ads
index 11dc6fd..2d6dc72 100644
--- a/gcc/ada/libgnat/g-utf_32.ads
+++ b/gcc/ada/libgnat/g-utf_32.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-wispch.adb b/gcc/ada/libgnat/g-wispch.adb
index 670edc1..403d02a 100644
--- a/gcc/ada/libgnat/g-wispch.adb
+++ b/gcc/ada/libgnat/g-wispch.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-wispch.ads b/gcc/ada/libgnat/g-wispch.ads
index 1a3b569..cfff62e 100644
--- a/gcc/ada/libgnat/g-wispch.ads
+++ b/gcc/ada/libgnat/g-wispch.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-wistsp.ads b/gcc/ada/libgnat/g-wistsp.ads
index 2026718..da64a6d 100644
--- a/gcc/ada/libgnat/g-wistsp.ads
+++ b/gcc/ada/libgnat/g-wistsp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-zspche.adb b/gcc/ada/libgnat/g-zspche.adb
index 0014d49..38684f3 100644
--- a/gcc/ada/libgnat/g-zspche.adb
+++ b/gcc/ada/libgnat/g-zspche.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-zspche.ads b/gcc/ada/libgnat/g-zspche.ads
index cd9c85a..47f5772 100644
--- a/gcc/ada/libgnat/g-zspche.ads
+++ b/gcc/ada/libgnat/g-zspche.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/g-zstspl.ads b/gcc/ada/libgnat/g-zstspl.ads
index 16400fd..9a8b5f9 100644
--- a/gcc/ada/libgnat/g-zstspl.ads
+++ b/gcc/ada/libgnat/g-zstspl.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/gnat.ads b/gcc/ada/libgnat/gnat.ads
index ffcb725..c3217a6 100644
--- a/gcc/ada/libgnat/gnat.ads
+++ b/gcc/ada/libgnat/gnat.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, AdaCore --
+-- Copyright (C) 1992-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/i-c.adb b/gcc/ada/libgnat/i-c.adb
index 2e651b6..028e5cb 100644
--- a/gcc/ada/libgnat/i-c.adb
+++ b/gcc/ada/libgnat/i-c.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/i-c.ads b/gcc/ada/libgnat/i-c.ads
index 1088836..279c75a 100644
--- a/gcc/ada/libgnat/i-c.ads
+++ b/gcc/ada/libgnat/i-c.ads
@@ -36,13 +36,15 @@ package Interfaces.C is
type short is new Short_Integer;
type long is range -(2 ** (System.Parameters.long_bits - Integer'(1)))
.. +(2 ** (System.Parameters.long_bits - Integer'(1))) - 1;
+ type long_long is new Long_Long_Integer;
type signed_char is range SCHAR_MIN .. SCHAR_MAX;
for signed_char'Size use CHAR_BIT;
- type unsigned is mod 2 ** int'Size;
- type unsigned_short is mod 2 ** short'Size;
- type unsigned_long is mod 2 ** long'Size;
+ type unsigned is mod 2 ** int'Size;
+ type unsigned_short is mod 2 ** short'Size;
+ type unsigned_long is mod 2 ** long'Size;
+ type unsigned_long_long is mod 2 ** long_long'Size;
type unsigned_char is mod (UCHAR_MAX + 1);
for unsigned_char'Size use CHAR_BIT;
diff --git a/gcc/ada/libgnat/i-cexten.ads b/gcc/ada/libgnat/i-cexten.ads
index d0a0747..2772860 100644
--- a/gcc/ada/libgnat/i-cexten.ads
+++ b/gcc/ada/libgnat/i-cexten.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -61,8 +61,8 @@ package Interfaces.C.Extensions is
-- 64-bit integer types
- subtype long_long is Long_Long_Integer;
- type unsigned_long_long is mod 2 ** 64;
+ subtype long_long is Interfaces.C.long_long;
+ subtype unsigned_long_long is Interfaces.C.unsigned_long_long;
-- 128-bit integer type available on 64-bit platforms:
-- typedef int signed_128 __attribute__ ((mode (TI)));
diff --git a/gcc/ada/libgnat/i-cobol.adb b/gcc/ada/libgnat/i-cobol.adb
index 807a3a1..d69ef9d 100644
--- a/gcc/ada/libgnat/i-cobol.adb
+++ b/gcc/ada/libgnat/i-cobol.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -240,11 +240,6 @@ package body Interfaces.COBOL is
(COBOL_Character'Pos (K) -
COBOL_Character'Pos (COBOL_Digits'First));
- elsif K in COBOL_Plus_Digits then
- Result := Result * 10 +
- (COBOL_Character'Pos (K) -
- COBOL_Character'Pos (COBOL_Plus_Digits'First));
-
elsif K in COBOL_Minus_Digits then
Result := Result * 10 +
(COBOL_Character'Pos (K) -
diff --git a/gcc/ada/libgnat/i-cobol.ads b/gcc/ada/libgnat/i-cobol.ads
index 1741474..21eecf8 100644
--- a/gcc/ada/libgnat/i-cobol.ads
+++ b/gcc/ada/libgnat/i-cobol.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (ASCII Version) --
-- --
--- Copyright (C) 1993-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1993-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/i-cpoint.adb b/gcc/ada/libgnat/i-cpoint.adb
index 6f3c530..6e5a2d2 100644
--- a/gcc/ada/libgnat/i-cpoint.adb
+++ b/gcc/ada/libgnat/i-cpoint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/i-cpoint.ads b/gcc/ada/libgnat/i-cpoint.ads
index 03ca369..a3caca8 100644
--- a/gcc/ada/libgnat/i-cpoint.ads
+++ b/gcc/ada/libgnat/i-cpoint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1993-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1993-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/i-cstrea.adb b/gcc/ada/libgnat/i-cstrea.adb
index 5574908..4cd4bed 100644
--- a/gcc/ada/libgnat/i-cstrea.adb
+++ b/gcc/ada/libgnat/i-cstrea.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/i-cstrea.ads b/gcc/ada/libgnat/i-cstrea.ads
index 2b78a9a..4277042 100644
--- a/gcc/ada/libgnat/i-cstrea.ads
+++ b/gcc/ada/libgnat/i-cstrea.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/i-cstrin.adb b/gcc/ada/libgnat/i-cstrin.adb
index 3d20294..17f4585 100644
--- a/gcc/ada/libgnat/i-cstrin.adb
+++ b/gcc/ada/libgnat/i-cstrin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/i-cstrin.ads b/gcc/ada/libgnat/i-cstrin.ads
index 0272136..fae8e97 100644
--- a/gcc/ada/libgnat/i-cstrin.ads
+++ b/gcc/ada/libgnat/i-cstrin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1993-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1993-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/i-fortra.adb b/gcc/ada/libgnat/i-fortra.adb
index f74d632..b529717 100644
--- a/gcc/ada/libgnat/i-fortra.adb
+++ b/gcc/ada/libgnat/i-fortra.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/i-pacdec.adb b/gcc/ada/libgnat/i-pacdec.adb
index 4f86f5b..e6eb790 100644
--- a/gcc/ada/libgnat/i-pacdec.adb
+++ b/gcc/ada/libgnat/i-pacdec.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- (Version for IBM Mainframe Packed Decimal Format) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/i-pacdec.ads b/gcc/ada/libgnat/i-pacdec.ads
index 43381ac..389dc3a 100644
--- a/gcc/ada/libgnat/i-pacdec.ads
+++ b/gcc/ada/libgnat/i-pacdec.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Version for IBM Mainframe Packed Decimal Format) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/i-vxwoio.adb b/gcc/ada/libgnat/i-vxwoio.adb
index 4b75364..4ae2245 100644
--- a/gcc/ada/libgnat/i-vxwoio.adb
+++ b/gcc/ada/libgnat/i-vxwoio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/i-vxwoio.ads b/gcc/ada/libgnat/i-vxwoio.ads
index 052626e..fc6c10f 100644
--- a/gcc/ada/libgnat/i-vxwoio.ads
+++ b/gcc/ada/libgnat/i-vxwoio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/i-vxwork.ads b/gcc/ada/libgnat/i-vxwork.ads
index 5285a8c..4f25bbd 100644
--- a/gcc/ada/libgnat/i-vxwork.ads
+++ b/gcc/ada/libgnat/i-vxwork.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/i-vxwork__x86.ads b/gcc/ada/libgnat/i-vxwork__x86.ads
index 8dc81d2..641f9fe 100644
--- a/gcc/ada/libgnat/i-vxwork__x86.ads
+++ b/gcc/ada/libgnat/i-vxwork__x86.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/interfac.ads b/gcc/ada/libgnat/interfac.ads
index 829cd8e..9fe7aac 100644
--- a/gcc/ada/libgnat/interfac.ads
+++ b/gcc/ada/libgnat/interfac.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/libada.gpr b/gcc/ada/libgnat/libada.gpr
new file mode 100644
index 0000000..9453cae
--- /dev/null
+++ b/gcc/ada/libgnat/libada.gpr
@@ -0,0 +1,77 @@
+-- This is a project file used to rebuild the GNAT run-time for debug
+-- or instrumentation purposes.
+--
+-- Here is how to use this project file:
+--
+-- 1. Create a new directory (e.g. "rts-debug"), then copy the adainclude
+-- directory from the reference runtime that you want to rebuild.
+-- You can find the relevant adainclude directory by running the command
+-- gprls [--target=<target>] [--RTS=<runtime>] and using the adainclude
+-- directory listed. For example:
+-- $ cd <reference directory>
+-- $ mkdir rts-debug
+-- $ cd rts-debug
+-- $ cp -a `gprls -v | grep adainclude` .
+-- $ cd adainclude
+--
+-- or under Windows:
+--
+-- $ mkdir adainclude
+-- $ xcopy /s /path/to/adainclude adainclude
+-- $ cd adainclude
+--
+-- 2. If needed (e.g for pragma Normalize_Scalars), create a file called
+-- gnat.adc in the adainclude directory containing the configuration pragmas
+-- you want to use to build the library, e.g.
+--
+-- $ echo "pragma Normalize_Scalars;" > gnat.adc
+--
+-- Note that this step is usually not needed, and most pragmas are not
+-- relevant to the GNAT run time.
+--
+-- 3. Determine the values of the following variables
+-- CFLAGS (back end compilation flags such as -g -O2)
+-- ADAFLAGS (front end compilation flags such as -gnatn)
+--
+-- 4. Run gprbuild on libada.gpr, e.g:
+-- $ gprbuild -p -Plibada -j0 -XCFLAGS="-O2 -g" -XADAFLAGS="-gnatn"
+--
+-- or for a cross target:
+--
+-- $ gprbuild --target=powerpc-elf -p -Plibada -j0 [...]
+--
+-- if you created a gnat.adc file at step 2, add "-XCONFIG_FILE=gnat.adc" to
+-- the gprbuild switches.
+--
+-- The above command will build libgnat.a and libgnarl.a with the given
+-- switches.
+--
+-- 4b. In order to generate shared libraries instead, add
+-- "-XLIBRARY_KIND=dynamic" to the gprbuild switches, and if you want to
+-- build both shared and static libraries, you can run gprbuild twice in
+-- a row, e.g:
+--
+-- $ gprbuild -p -Plibada -j0 -XLIBRARY_KIND=dynamic [...]
+-- $ gprbuild -p -Plibada -j0 -XLIBRARY_KIND=static [...]
+--
+-- 5. Once the above gprbuild command is successful, you can use this new
+-- runtime directory by specifying it either via the --RTS= switch on the
+-- command line or via the attribute Runtime ("Ada") in the main project
+-- file:
+-- $ gprbuild --RTS=.../rts-debug ...
+-- or
+-- for Runtime ("Ada") use ".../rts-debug";
+
+aggregate project Libada is
+ for Project_Files use ("libgnat.gpr", "libgnarl.gpr");
+
+ Config_File := External ("CONFIG_FILE", "");
+
+ package Builder is
+ case Config_File is
+ when "" => null;
+ when others => for Global_Configuration_Pragmas use Config_File;
+ end case;
+ end Builder;
+
+end Libada;
diff --git a/gcc/ada/libgnat/libgnat.gpr b/gcc/ada/libgnat/libgnat.gpr
new file mode 100644
index 0000000..006ff2d
--- /dev/null
+++ b/gcc/ada/libgnat/libgnat.gpr
@@ -0,0 +1,69 @@
+with "libgnat_common";
+
+library project Libgnat is
+
+ for Languages use ("Ada", "C");
+ for Source_Dirs use (".");
+ for Source_List_File use "libgnat.lst";
+ for Object_Dir use "../obj-" & Libgnat_Common.Library_Kind;
+
+ for Library_Name use "gnat";
+ for Library_Dir use "../adalib";
+ for Library_Kind use Libgnat_Common.Library_Kind;
+
+ package Compiler is
+
+ for Switches ("C") use Libgnat_Common.C_Flags;
+ for Switches ("Ada") use Libgnat_Common.Ada_Flags;
+
+ for Switches ("s-traceb.adb") use
+ Libgnat_Common.Ada_Flags & Libgnat_Common.Force_Debug &
+ Libgnat_Common.No_Inline & Libgnat_Common.No_Sibling;
+ -- Force no sibling call optimization on s-traceb.o so the number of
+ -- stack frames to be skipped when computing a call chain is not
+ -- modified by optimization. We don.t want inlining, either.
+
+ for Switches ("a-except.adb") use
+ Libgnat_Common.Ada_Flags & ("-O1") &
+ Libgnat_Common.Force_Debug & Libgnat_Common.No_Inline &
+ Libgnat_Common.No_Reorder;
+ -- Force no function reordering because of the exclusion bounds
+ -- mechanism (see the source file for more detailed information).
+ -- Force debugging information so that it is always possible to set
+ -- conditional breakpoints on exceptions.
+ -- Use -O1 otherwise gdb isn.t able to get a full backtrace on mips
+ -- targets.
+
+ for Switches ("s-excdeb.adb") use
+ Libgnat_Common.Ada_Flags & Libgnat_Common.Force_Debug &
+ Libgnat_Common.No_Opt;
+ -- Compile without optimization and with debug info to let the debugger
+ -- set breakpoints and inspect subprogram parameters on exception
+ -- related events.
+
+ for Switches ("s-assert.adb") use
+ Libgnat_Common.Ada_Flags & Libgnat_Common.Force_Debug;
+ -- Force debugging information on s-assert.o so that it is always
+ -- possible to set breakpoint on assert failures.
+
+ for Switches ("a-tags.adb") use
+ Libgnat_Common.Ada_Flags & Libgnat_Common.Force_Debug;
+ -- Force debugging information on a-tags.o so that the debugger can find
+ -- the description of Ada.Tags.Type_Specific_Data.
+
+ for Switches ("s-memory.adb") use
+ Libgnat_Common.Ada_Flags & Libgnat_Common.No_Sibling;
+ -- Force no sibling call optimization on s-memory.o to avoid turning the
+ -- tail recursion in Alloc into a loop that confuses branch prediction.
+
+ for Switches ("g-debpoo.adb") use
+ Libgnat_Common.Ada_Flags & Libgnat_Common.No_Reorder;
+ -- Need to keep functions ordered on g-debpoo.o since labels are used to
+ -- exclude subprograms from traceback computation.
+
+ for Switches ("traceback.c") use
+ Libgnat_Common.C_Flags & Libgnat_Common.No_Omit;
+
+ end Compiler;
+
+end Libgnat;
diff --git a/gcc/ada/libgnat/libgnat_common.gpr b/gcc/ada/libgnat/libgnat_common.gpr
new file mode 100644
index 0000000..6303928
--- /dev/null
+++ b/gcc/ada/libgnat/libgnat_common.gpr
@@ -0,0 +1,19 @@
+abstract project Libgnat_Common is
+
+ Common_Flags := Split (External ("CFLAGS", "-O2 -g"), " ");
+ C_Flags := Common_Flags &
+ ("-I../include", "-DIN_RTS=1", "-fexceptions",
+ "-DSTANDALONE") &
+ External_As_List ("EXTRALIBFLAGS", " ");
+ Ada_Flags := Common_Flags & ("-nostdinc", "-I../adainclude")
+ & Split (External ("ADAFLAGS", "-gnatpg"), " ");
+ Library_Kind := External ("LIBRARY_KIND", "static");
+
+ No_Opt := ("-O0");
+ Force_Debug := ("-g");
+ No_Inline := ("-fno-inline");
+ No_Omit := ("-fno-omit-frame-pointer");
+ No_Sibling := ("-fno-optimize-sibling-calls");
+ No_Reorder := ("-fno-toplevel-reorder", "-O0");
+
+end Libgnat_Common;
diff --git a/gcc/ada/libgnat/memtrack.adb b/gcc/ada/libgnat/memtrack.adb
index 04f3f0f..bd34796 100644
--- a/gcc/ada/libgnat/memtrack.adb
+++ b/gcc/ada/libgnat/memtrack.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-addima.adb b/gcc/ada/libgnat/s-addima.adb
index 6a7ab7e..a231be2 100644
--- a/gcc/ada/libgnat/s-addima.adb
+++ b/gcc/ada/libgnat/s-addima.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-addima.ads b/gcc/ada/libgnat/s-addima.ads
index 04bf964..281655d 100644
--- a/gcc/ada/libgnat/s-addima.ads
+++ b/gcc/ada/libgnat/s-addima.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-addope.adb b/gcc/ada/libgnat/s-addope.adb
index edda33d..5c3fd4a 100644
--- a/gcc/ada/libgnat/s-addope.adb
+++ b/gcc/ada/libgnat/s-addope.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-addope.ads b/gcc/ada/libgnat/s-addope.ads
index fc71956e..881882a 100644
--- a/gcc/ada/libgnat/s-addope.ads
+++ b/gcc/ada/libgnat/s-addope.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-atopar.adb b/gcc/ada/libgnat/s-aoinar.adb
index 82cfbd3..b05134f 100644
--- a/gcc/ada/libgnat/s-atopar.adb
+++ b/gcc/ada/libgnat/s-aoinar.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- System.Atomic_Operations.Arithmetic --
+-- System.Atomic_Operations.Integer_Arithmetic --
-- --
-- B o d y --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,9 +30,12 @@
------------------------------------------------------------------------------
with System.Atomic_Primitives; use System.Atomic_Primitives;
+with System.Atomic_Operations.Exchange;
with Interfaces.C;
-package body System.Atomic_Operations.Arithmetic is
+package body System.Atomic_Operations.Integer_Arithmetic is
+
+ package Exchange is new System.Atomic_Operations.Exchange (Atomic_Type);
----------------
-- Atomic_Add --
@@ -88,13 +91,42 @@ package body System.Atomic_Operations.Arithmetic is
pragma Warnings (On);
begin
- case Item'Size is
- when 8 => return Atomic_Fetch_Add_1 (Item'Address, Value);
- when 16 => return Atomic_Fetch_Add_2 (Item'Address, Value);
- when 32 => return Atomic_Fetch_Add_4 (Item'Address, Value);
- when 64 => return Atomic_Fetch_Add_8 (Item'Address, Value);
- when others => raise Program_Error;
- end case;
+ -- Use the direct intrinsics when possible, and fallback to
+ -- compare-and-exchange otherwise.
+
+ if Atomic_Type'Base'Last = Atomic_Type'Last
+ and then Atomic_Type'Base'First = Atomic_Type'First
+ and then Atomic_Type'Last
+ in 2 ** 7 - 1 | 2 ** 15 - 1 | 2 ** 31 - 1 | 2 ** 63 - 1
+ then
+ case Long_Long_Integer (Atomic_Type'Last) is
+ when 2 ** 7 - 1 =>
+ return Atomic_Fetch_Add_1 (Item'Address, Value);
+ when 2 ** 15 - 1 =>
+ return Atomic_Fetch_Add_2 (Item'Address, Value);
+ when 2 ** 31 - 1 =>
+ return Atomic_Fetch_Add_4 (Item'Address, Value);
+ when 2 ** 63 - 1 =>
+ return Atomic_Fetch_Add_8 (Item'Address, Value);
+ when others =>
+ raise Program_Error;
+ end case;
+ else
+ declare
+ Old_Value : aliased Atomic_Type := Item;
+ New_Value : Atomic_Type := Old_Value + Value;
+ begin
+ -- Keep iterating until the exchange succeeds
+
+ while not Exchange.Atomic_Compare_And_Exchange
+ (Item, Old_Value, New_Value)
+ loop
+ New_Value := Old_Value + Value;
+ end loop;
+
+ return Old_Value;
+ end;
+ end if;
end Atomic_Fetch_And_Add;
-------------------------------
@@ -125,13 +157,42 @@ package body System.Atomic_Operations.Arithmetic is
pragma Warnings (On);
begin
- case Item'Size is
- when 8 => return Atomic_Fetch_Sub_1 (Item'Address, Value);
- when 16 => return Atomic_Fetch_Sub_2 (Item'Address, Value);
- when 32 => return Atomic_Fetch_Sub_4 (Item'Address, Value);
- when 64 => return Atomic_Fetch_Sub_8 (Item'Address, Value);
- when others => raise Program_Error;
- end case;
+ -- Use the direct intrinsics when possible, and fallback to
+ -- compare-and-exchange otherwise.
+
+ if Atomic_Type'Base'Last = Atomic_Type'Last
+ and then Atomic_Type'Base'First = Atomic_Type'First
+ and then Atomic_Type'Last
+ in 2 ** 7 - 1 | 2 ** 15 - 1 | 2 ** 31 - 1 | 2 ** 63 - 1
+ then
+ case Long_Long_Integer (Atomic_Type'Last) is
+ when 2 ** 7 - 1 =>
+ return Atomic_Fetch_Sub_1 (Item'Address, Value);
+ when 2 ** 15 - 1 =>
+ return Atomic_Fetch_Sub_2 (Item'Address, Value);
+ when 2 ** 31 - 1 =>
+ return Atomic_Fetch_Sub_4 (Item'Address, Value);
+ when 2 ** 63 - 1 =>
+ return Atomic_Fetch_Sub_8 (Item'Address, Value);
+ when others =>
+ raise Program_Error;
+ end case;
+ else
+ declare
+ Old_Value : aliased Atomic_Type := Item;
+ New_Value : Atomic_Type := Old_Value - Value;
+ begin
+ -- Keep iterating until the exchange succeeds
+
+ while not Exchange.Atomic_Compare_And_Exchange
+ (Item, Old_Value, New_Value)
+ loop
+ New_Value := Old_Value - Value;
+ end loop;
+
+ return Old_Value;
+ end;
+ end if;
end Atomic_Fetch_And_Subtract;
------------------
@@ -139,9 +200,10 @@ package body System.Atomic_Operations.Arithmetic is
------------------
function Is_Lock_Free (Item : aliased Atomic_Type) return Boolean is
+ pragma Unreferenced (Item);
use type Interfaces.C.size_t;
begin
- return Boolean (Atomic_Always_Lock_Free (Item'Size / 8));
+ return Boolean (Atomic_Always_Lock_Free (Atomic_Type'Object_Size / 8));
end Is_Lock_Free;
-end System.Atomic_Operations.Arithmetic;
+end System.Atomic_Operations.Integer_Arithmetic;
diff --git a/gcc/ada/libgnat/s-atopar.ads b/gcc/ada/libgnat/s-aoinar.ads
index 73c2447..558754f 100644
--- a/gcc/ada/libgnat/s-atopar.ads
+++ b/gcc/ada/libgnat/s-aoinar.ads
@@ -2,11 +2,15 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- System.Atomic_Operations.Arithmetic --
+-- System.Atomic_Operations.Integer_Arithmetic --
-- --
-- S p e c --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,13 +33,10 @@
-- --
------------------------------------------------------------------------------
-pragma Ada_2020;
-
generic
type Atomic_Type is range <> with Atomic;
-package System.Atomic_Operations.Arithmetic
+package System.Atomic_Operations.Integer_Arithmetic
with Pure
--- Nonblocking
is
procedure Atomic_Add
(Item : aliased in out Atomic_Type;
@@ -62,4 +63,4 @@ private
pragma Inline_Always (Atomic_Fetch_And_Add);
pragma Inline_Always (Atomic_Fetch_And_Subtract);
pragma Inline_Always (Is_Lock_Free);
-end System.Atomic_Operations.Arithmetic;
+end System.Atomic_Operations.Integer_Arithmetic;
diff --git a/gcc/ada/libgnat/s-aomoar.adb b/gcc/ada/libgnat/s-aomoar.adb
new file mode 100644
index 0000000..9f350c1
--- /dev/null
+++ b/gcc/ada/libgnat/s-aomoar.adb
@@ -0,0 +1,215 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- System.Atomic_Operations.Modular_Arithmetic --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Atomic_Primitives; use System.Atomic_Primitives;
+with System.Atomic_Operations.Exchange;
+with Interfaces.C; use Interfaces;
+
+package body System.Atomic_Operations.Modular_Arithmetic is
+
+ package Exchange is new System.Atomic_Operations.Exchange (Atomic_Type);
+
+ ----------------
+ -- Atomic_Add --
+ ----------------
+
+ procedure Atomic_Add
+ (Item : aliased in out Atomic_Type;
+ Value : Atomic_Type)
+ is
+ Ignore : constant Atomic_Type := Atomic_Fetch_And_Add (Item, Value);
+ begin
+ null;
+ end Atomic_Add;
+
+ ---------------------
+ -- Atomic_Subtract --
+ ---------------------
+
+ procedure Atomic_Subtract
+ (Item : aliased in out Atomic_Type;
+ Value : Atomic_Type)
+ is
+ Ignore : constant Atomic_Type := Atomic_Fetch_And_Subtract (Item, Value);
+ begin
+ null;
+ end Atomic_Subtract;
+
+ --------------------------
+ -- Atomic_Fetch_And_Add --
+ --------------------------
+
+ function Atomic_Fetch_And_Add
+ (Item : aliased in out Atomic_Type;
+ Value : Atomic_Type) return Atomic_Type
+ is
+ pragma Warnings (Off);
+ function Atomic_Fetch_Add_1
+ (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
+ return Atomic_Type;
+ pragma Import (Intrinsic, Atomic_Fetch_Add_1, "__atomic_fetch_add_1");
+ function Atomic_Fetch_Add_2
+ (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
+ return Atomic_Type;
+ pragma Import (Intrinsic, Atomic_Fetch_Add_2, "__atomic_fetch_add_2");
+ function Atomic_Fetch_Add_4
+ (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
+ return Atomic_Type;
+ pragma Import (Intrinsic, Atomic_Fetch_Add_4, "__atomic_fetch_add_4");
+ function Atomic_Fetch_Add_8
+ (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
+ return Atomic_Type;
+ pragma Import (Intrinsic, Atomic_Fetch_Add_8, "__atomic_fetch_add_8");
+ pragma Warnings (On);
+
+ begin
+ -- Use the direct intrinsics when possible, and fallback to
+ -- compare-and-exchange otherwise.
+ -- Also suppress spurious warnings.
+
+ pragma Warnings (Off);
+ if Atomic_Type'Base'Last = Atomic_Type'Last
+ and then Atomic_Type'First = 0
+ and then Atomic_Type'Last
+ in 2 ** 8 - 1 | 2 ** 16 - 1 | 2 ** 32 - 1 | 2 ** 64 - 1
+ then
+ pragma Warnings (On);
+ case Unsigned_64 (Atomic_Type'Last) is
+ when 2 ** 8 - 1 =>
+ return Atomic_Fetch_Add_1 (Item'Address, Value);
+ when 2 ** 16 - 1 =>
+ return Atomic_Fetch_Add_2 (Item'Address, Value);
+ when 2 ** 32 - 1 =>
+ return Atomic_Fetch_Add_4 (Item'Address, Value);
+ when 2 ** 64 - 1 =>
+ return Atomic_Fetch_Add_8 (Item'Address, Value);
+ when others =>
+ raise Program_Error;
+ end case;
+ else
+ declare
+ Old_Value : aliased Atomic_Type := Item;
+ New_Value : Atomic_Type := Old_Value + Value;
+ begin
+ -- Keep iterating until the exchange succeeds
+
+ while not Exchange.Atomic_Compare_And_Exchange
+ (Item, Old_Value, New_Value)
+ loop
+ New_Value := Old_Value + Value;
+ end loop;
+
+ return Old_Value;
+ end;
+ end if;
+ end Atomic_Fetch_And_Add;
+
+ -------------------------------
+ -- Atomic_Fetch_And_Subtract --
+ -------------------------------
+
+ function Atomic_Fetch_And_Subtract
+ (Item : aliased in out Atomic_Type;
+ Value : Atomic_Type) return Atomic_Type
+ is
+ pragma Warnings (Off);
+ function Atomic_Fetch_Sub_1
+ (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
+ return Atomic_Type;
+ pragma Import (Intrinsic, Atomic_Fetch_Sub_1, "__atomic_fetch_sub_1");
+ function Atomic_Fetch_Sub_2
+ (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
+ return Atomic_Type;
+ pragma Import (Intrinsic, Atomic_Fetch_Sub_2, "__atomic_fetch_sub_2");
+ function Atomic_Fetch_Sub_4
+ (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
+ return Atomic_Type;
+ pragma Import (Intrinsic, Atomic_Fetch_Sub_4, "__atomic_fetch_sub_4");
+ function Atomic_Fetch_Sub_8
+ (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
+ return Atomic_Type;
+ pragma Import (Intrinsic, Atomic_Fetch_Sub_8, "__atomic_fetch_sub_8");
+ pragma Warnings (On);
+
+ begin
+ -- Use the direct intrinsics when possible, and fallback to
+ -- compare-and-exchange otherwise.
+ -- Also suppress spurious warnings.
+
+ pragma Warnings (Off);
+ if Atomic_Type'Base'Last = Atomic_Type'Last
+ and then Atomic_Type'First = 0
+ and then Atomic_Type'Last
+ in 2 ** 8 - 1 | 2 ** 16 - 1 | 2 ** 32 - 1 | 2 ** 64 - 1
+ then
+ pragma Warnings (On);
+ case Unsigned_64 (Atomic_Type'Last) is
+ when 2 ** 8 - 1 =>
+ return Atomic_Fetch_Sub_1 (Item'Address, Value);
+ when 2 ** 16 - 1 =>
+ return Atomic_Fetch_Sub_2 (Item'Address, Value);
+ when 2 ** 32 - 1 =>
+ return Atomic_Fetch_Sub_4 (Item'Address, Value);
+ when 2 ** 64 - 1 =>
+ return Atomic_Fetch_Sub_8 (Item'Address, Value);
+ when others =>
+ raise Program_Error;
+ end case;
+ else
+ declare
+ Old_Value : aliased Atomic_Type := Item;
+ New_Value : Atomic_Type := Old_Value - Value;
+ begin
+ -- Keep iterating until the exchange succeeds
+
+ while not Exchange.Atomic_Compare_And_Exchange
+ (Item, Old_Value, New_Value)
+ loop
+ New_Value := Old_Value - Value;
+ end loop;
+
+ return Old_Value;
+ end;
+ end if;
+ end Atomic_Fetch_And_Subtract;
+
+ ------------------
+ -- Is_Lock_Free --
+ ------------------
+
+ function Is_Lock_Free (Item : aliased Atomic_Type) return Boolean is
+ pragma Unreferenced (Item);
+ use type Interfaces.C.size_t;
+ begin
+ return Boolean (Atomic_Always_Lock_Free (Atomic_Type'Object_Size / 8));
+ end Is_Lock_Free;
+
+end System.Atomic_Operations.Modular_Arithmetic;
diff --git a/gcc/ada/libgnat/s-aomoar.ads b/gcc/ada/libgnat/s-aomoar.ads
new file mode 100644
index 0000000..4062d1a
--- /dev/null
+++ b/gcc/ada/libgnat/s-aomoar.ads
@@ -0,0 +1,66 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- System.Atomic_Operations.Modular_Arithmetic --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+generic
+ type Atomic_Type is mod <> with Atomic;
+package System.Atomic_Operations.Modular_Arithmetic
+ with Pure
+is
+ procedure Atomic_Add
+ (Item : aliased in out Atomic_Type;
+ Value : Atomic_Type) with Convention => Intrinsic;
+
+ procedure Atomic_Subtract
+ (Item : aliased in out Atomic_Type;
+ Value : Atomic_Type) with Convention => Intrinsic;
+
+ function Atomic_Fetch_And_Add
+ (Item : aliased in out Atomic_Type;
+ Value : Atomic_Type) return Atomic_Type with Convention => Intrinsic;
+
+ function Atomic_Fetch_And_Subtract
+ (Item : aliased in out Atomic_Type;
+ Value : Atomic_Type) return Atomic_Type with Convention => Intrinsic;
+
+ function Is_Lock_Free
+ (Item : aliased Atomic_Type) return Boolean with Convention => Intrinsic;
+
+private
+ pragma Inline_Always (Atomic_Add);
+ pragma Inline_Always (Atomic_Subtract);
+ pragma Inline_Always (Atomic_Fetch_And_Add);
+ pragma Inline_Always (Atomic_Fetch_And_Subtract);
+ pragma Inline_Always (Is_Lock_Free);
+end System.Atomic_Operations.Modular_Arithmetic;
diff --git a/gcc/ada/libgnat/s-aotase.adb b/gcc/ada/libgnat/s-aotase.adb
index 7ed6ab8..84a1a6e 100644
--- a/gcc/ada/libgnat/s-aotase.adb
+++ b/gcc/ada/libgnat/s-aotase.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-aotase.ads b/gcc/ada/libgnat/s-aotase.ads
index 0406630..f979788 100644
--- a/gcc/ada/libgnat/s-aotase.ads
+++ b/gcc/ada/libgnat/s-aotase.ads
@@ -6,7 +6,11 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,7 +35,6 @@
package System.Atomic_Operations.Test_And_Set
with Pure
--- Nonblocking
is
type Test_And_Set_Flag is mod 2 ** 8
with Atomic, Default_Value => 0, Size => 8;
diff --git a/gcc/ada/libgnat/s-arit64.adb b/gcc/ada/libgnat/s-arit64.adb
index ede7562..060f352 100644
--- a/gcc/ada/libgnat/s-arit64.adb
+++ b/gcc/ada/libgnat/s-arit64.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-arit64.ads b/gcc/ada/libgnat/s-arit64.ads
index bc9d5a6..479515f 100644
--- a/gcc/ada/libgnat/s-arit64.ads
+++ b/gcc/ada/libgnat/s-arit64.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-assert.adb b/gcc/ada/libgnat/s-assert.adb
index 412b5b7..55020b9 100644
--- a/gcc/ada/libgnat/s-assert.adb
+++ b/gcc/ada/libgnat/s-assert.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-assert.ads b/gcc/ada/libgnat/s-assert.ads
index a5dc808..7dcd93a 100644
--- a/gcc/ada/libgnat/s-assert.ads
+++ b/gcc/ada/libgnat/s-assert.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-atacco.adb b/gcc/ada/libgnat/s-atacco.adb
index 892d6d7..11857b9 100644
--- a/gcc/ada/libgnat/s-atacco.adb
+++ b/gcc/ada/libgnat/s-atacco.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-atacco.ads b/gcc/ada/libgnat/s-atacco.ads
index 2609998..e9076cc 100644
--- a/gcc/ada/libgnat/s-atacco.ads
+++ b/gcc/ada/libgnat/s-atacco.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/s-atocou.adb b/gcc/ada/libgnat/s-atocou.adb
index cb6ead4..5d7f98e 100644
--- a/gcc/ada/libgnat/s-atocou.adb
+++ b/gcc/ada/libgnat/s-atocou.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-atocou.ads b/gcc/ada/libgnat/s-atocou.ads
index 51930e6..b64f947 100644
--- a/gcc/ada/libgnat/s-atocou.ads
+++ b/gcc/ada/libgnat/s-atocou.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-atocou__builtin.adb b/gcc/ada/libgnat/s-atocou__builtin.adb
index cf60e68..2f2a5f6 100644
--- a/gcc/ada/libgnat/s-atocou__builtin.adb
+++ b/gcc/ada/libgnat/s-atocou__builtin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-atocou__x86.adb b/gcc/ada/libgnat/s-atocou__x86.adb
index 322b03f..217cdec 100644
--- a/gcc/ada/libgnat/s-atocou__x86.adb
+++ b/gcc/ada/libgnat/s-atocou__x86.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-atoope.ads b/gcc/ada/libgnat/s-atoope.ads
index cbe089b..a0f0eb8 100644
--- a/gcc/ada/libgnat/s-atoope.ads
+++ b/gcc/ada/libgnat/s-atoope.ads
@@ -6,7 +6,11 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-atopex.adb b/gcc/ada/libgnat/s-atopex.adb
index 624d3d5..4fb2824 100644
--- a/gcc/ada/libgnat/s-atopex.adb
+++ b/gcc/ada/libgnat/s-atopex.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -66,7 +66,7 @@ package body System.Atomic_Operations.Exchange is
pragma Warnings (On);
begin
- case Item'Size is
+ case Atomic_Type'Object_Size is
when 8 => return Atomic_Exchange_1 (Item'Address, Value);
when 16 => return Atomic_Exchange_2 (Item'Address, Value);
when 32 => return Atomic_Exchange_4 (Item'Address, Value);
@@ -124,7 +124,7 @@ package body System.Atomic_Operations.Exchange is
pragma Warnings (On);
begin
- case Item'Size is
+ case Atomic_Type'Object_Size is
when 8 =>
return Boolean
(Atomic_Compare_Exchange_1
@@ -151,9 +151,10 @@ package body System.Atomic_Operations.Exchange is
------------------
function Is_Lock_Free (Item : aliased Atomic_Type) return Boolean is
+ pragma Unreferenced (Item);
use type Interfaces.C.size_t;
begin
- return Boolean (Atomic_Always_Lock_Free (Item'Size / 8));
+ return Boolean (Atomic_Always_Lock_Free (Atomic_Type'Object_Size / 8));
end Is_Lock_Free;
end System.Atomic_Operations.Exchange;
diff --git a/gcc/ada/libgnat/s-atopex.ads b/gcc/ada/libgnat/s-atopex.ads
index 51db0b9..996883c 100644
--- a/gcc/ada/libgnat/s-atopex.ads
+++ b/gcc/ada/libgnat/s-atopex.ads
@@ -6,7 +6,11 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,13 +33,10 @@
-- --
------------------------------------------------------------------------------
-pragma Ada_2020;
-
generic
type Atomic_Type is private with Atomic;
package System.Atomic_Operations.Exchange
with Pure
--- Blocking
is
function Atomic_Exchange
(Item : aliased in out Atomic_Type;
diff --git a/gcc/ada/libgnat/s-atopri.adb b/gcc/ada/libgnat/s-atopri.adb
index f1b8a55..fa40d20 100644
--- a/gcc/ada/libgnat/s-atopri.adb
+++ b/gcc/ada/libgnat/s-atopri.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2012-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-atopri.ads b/gcc/ada/libgnat/s-atopri.ads
index b65156a..603793f 100644
--- a/gcc/ada/libgnat/s-atopri.ads
+++ b/gcc/ada/libgnat/s-atopri.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2012-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-auxdec.adb b/gcc/ada/libgnat/s-auxdec.adb
index 51c0c33..19741ea 100644
--- a/gcc/ada/libgnat/s-auxdec.adb
+++ b/gcc/ada/libgnat/s-auxdec.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/Or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-auxdec.ads b/gcc/ada/libgnat/s-auxdec.ads
index f8defb2..66a9c9e 100644
--- a/gcc/ada/libgnat/s-auxdec.ads
+++ b/gcc/ada/libgnat/s-auxdec.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -198,6 +198,8 @@ package System.Aux_DEC is
type Unsigned_Quadword_Array is
array (Integer range <>) of Unsigned_Quadword;
+ subtype Address_Int is Integer;
+
function To_Address (X : Integer) return Address;
pragma Pure_Function (To_Address);
diff --git a/gcc/ada/libgnat/s-bignum.adb b/gcc/ada/libgnat/s-bignum.adb
index bde6c1f..5e85c4a 100644
--- a/gcc/ada/libgnat/s-bignum.adb
+++ b/gcc/ada/libgnat/s-bignum.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2012-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,68 +29,121 @@
-- --
------------------------------------------------------------------------------
-with System.Generic_Bignums;
with Ada.Unchecked_Conversion;
+with System.Generic_Bignums;
+with System.Secondary_Stack; use System.Secondary_Stack;
+with System.Shared_Bignums; use System.Shared_Bignums;
+with System.Storage_Elements; use System.Storage_Elements;
package body System.Bignums is
- package Sec_Stack_Bignums is new
- System.Generic_Bignums (Use_Secondary_Stack => True);
- use Sec_Stack_Bignums;
+ function Allocate_Bignum (D : Digit_Vector; Neg : Boolean) return Bignum;
+ -- Allocate Bignum value with the given contents
+
+ procedure Free_Bignum (X : in out Bignum) is null;
+ -- No op when using the secondary stack
+
+ function To_Bignum (X : aliased in out Bignum) return Bignum is (X);
+
+ ---------------------
+ -- Allocate_Bignum --
+ ---------------------
+
+ function Allocate_Bignum (D : Digit_Vector; Neg : Boolean) return Bignum is
+ Addr : aliased Address;
+ begin
+ -- Note: The approach used here is designed to avoid strict aliasing
+ -- warnings that appeared previously using unchecked conversion.
+
+ SS_Allocate (Addr, Storage_Offset (4 + 4 * D'Length));
+
+ declare
+ B : Bignum;
+ for B'Address use Addr'Address;
+ pragma Import (Ada, B);
+
+ BD : Bignum_Data (D'Length);
+ for BD'Address use Addr;
+ pragma Import (Ada, BD);
+
+ -- Expose a writable view of discriminant BD.Len so that we can
+ -- initialize it. We need to use the exact layout of the record
+ -- to ensure that the Length field has 24 bits as expected.
+
+ type Bignum_Data_Header is record
+ Len : Length;
+ Neg : Boolean;
+ end record;
+
+ for Bignum_Data_Header use record
+ Len at 0 range 0 .. 23;
+ Neg at 3 range 0 .. 7;
+ end record;
+
+ BDH : Bignum_Data_Header;
+ for BDH'Address use BD'Address;
+ pragma Import (Ada, BDH);
+
+ pragma Assert (BDH.Len'Size = BD.Len'Size);
- function "+" is new Ada.Unchecked_Conversion
- (Bignum, Sec_Stack_Bignums.Bignum);
+ begin
+ BDH.Len := D'Length;
+ BDH.Neg := Neg;
+ B.D := D;
+ return B;
+ end;
+ end Allocate_Bignum;
- function "-" is new Ada.Unchecked_Conversion
- (Sec_Stack_Bignums.Bignum, Bignum);
+ package Sec_Stack_Bignums is new System.Generic_Bignums
+ (Bignum, Allocate_Bignum, Free_Bignum, To_Bignum);
- function Big_Add (X, Y : Bignum) return Bignum is
- (-Sec_Stack_Bignums.Big_Add (+X, +Y));
+ function Big_Add (X, Y : Bignum) return Bignum
+ renames Sec_Stack_Bignums.Big_Add;
- function Big_Sub (X, Y : Bignum) return Bignum is
- (-Sec_Stack_Bignums.Big_Sub (+X, +Y));
+ function Big_Sub (X, Y : Bignum) return Bignum
+ renames Sec_Stack_Bignums.Big_Sub;
- function Big_Mul (X, Y : Bignum) return Bignum is
- (-Sec_Stack_Bignums.Big_Mul (+X, +Y));
+ function Big_Mul (X, Y : Bignum) return Bignum
+ renames Sec_Stack_Bignums.Big_Mul;
- function Big_Div (X, Y : Bignum) return Bignum is
- (-Sec_Stack_Bignums.Big_Div (+X, +Y));
+ function Big_Div (X, Y : Bignum) return Bignum
+ renames Sec_Stack_Bignums.Big_Div;
- function Big_Exp (X, Y : Bignum) return Bignum is
- (-Sec_Stack_Bignums.Big_Exp (+X, +Y));
+ function Big_Exp (X, Y : Bignum) return Bignum
+ renames Sec_Stack_Bignums.Big_Exp;
- function Big_Mod (X, Y : Bignum) return Bignum is
- (-Sec_Stack_Bignums.Big_Mod (+X, +Y));
+ function Big_Mod (X, Y : Bignum) return Bignum
+ renames Sec_Stack_Bignums.Big_Mod;
- function Big_Rem (X, Y : Bignum) return Bignum is
- (-Sec_Stack_Bignums.Big_Rem (+X, +Y));
+ function Big_Rem (X, Y : Bignum) return Bignum
+ renames Sec_Stack_Bignums.Big_Rem;
- function Big_Neg (X : Bignum) return Bignum is
- (-Sec_Stack_Bignums.Big_Neg (+X));
+ function Big_Neg (X : Bignum) return Bignum
+ renames Sec_Stack_Bignums.Big_Neg;
- function Big_Abs (X : Bignum) return Bignum is
- (-Sec_Stack_Bignums.Big_Abs (+X));
+ function Big_Abs (X : Bignum) return Bignum
+ renames Sec_Stack_Bignums.Big_Abs;
- function Big_EQ (X, Y : Bignum) return Boolean is
- (Sec_Stack_Bignums.Big_EQ (+X, +Y));
- function Big_NE (X, Y : Bignum) return Boolean is
- (Sec_Stack_Bignums.Big_NE (+X, +Y));
- function Big_GE (X, Y : Bignum) return Boolean is
- (Sec_Stack_Bignums.Big_GE (+X, +Y));
- function Big_LE (X, Y : Bignum) return Boolean is
- (Sec_Stack_Bignums.Big_LE (+X, +Y));
- function Big_GT (X, Y : Bignum) return Boolean is
- (Sec_Stack_Bignums.Big_GT (+X, +Y));
- function Big_LT (X, Y : Bignum) return Boolean is
- (Sec_Stack_Bignums.Big_LT (+X, +Y));
+ function Big_EQ (X, Y : Bignum) return Boolean
+ renames Sec_Stack_Bignums.Big_EQ;
+ function Big_NE (X, Y : Bignum) return Boolean
+ renames Sec_Stack_Bignums.Big_NE;
+ function Big_GE (X, Y : Bignum) return Boolean
+ renames Sec_Stack_Bignums.Big_GE;
+ function Big_LE (X, Y : Bignum) return Boolean
+ renames Sec_Stack_Bignums.Big_LE;
+ function Big_GT (X, Y : Bignum) return Boolean
+ renames Sec_Stack_Bignums.Big_GT;
+ function Big_LT (X, Y : Bignum) return Boolean
+ renames Sec_Stack_Bignums.Big_LT;
- function Bignum_In_LLI_Range (X : Bignum) return Boolean is
- (Sec_Stack_Bignums.Bignum_In_LLI_Range (+X));
+ function Bignum_In_LLI_Range (X : Bignum) return Boolean
+ renames Sec_Stack_Bignums.Bignum_In_LLI_Range;
- function To_Bignum (X : Long_Long_Integer) return Bignum is
- (-Sec_Stack_Bignums.To_Bignum (X));
+ function To_Bignum (X : Long_Long_Integer) return Bignum
+ renames Sec_Stack_Bignums.To_Bignum;
- function From_Bignum (X : Bignum) return Long_Long_Integer is
- (Sec_Stack_Bignums.From_Bignum (+X));
+ function From_Bignum (X : Bignum) return Long_Long_Integer
+ renames Sec_Stack_Bignums.From_Bignum;
end System.Bignums;
diff --git a/gcc/ada/libgnat/s-bignum.ads b/gcc/ada/libgnat/s-bignum.ads
index 5edb62c..728e5438 100644
--- a/gcc/ada/libgnat/s-bignum.ads
+++ b/gcc/ada/libgnat/s-bignum.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2012-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -36,10 +36,12 @@
-- Note that we cannot use a straight instantiation of System.Generic_Bignums
-- because the rtsfind mechanism is not ready to handle instantiations.
+with System.Shared_Bignums;
+
package System.Bignums is
pragma Preelaborate;
- type Bignum is private;
+ subtype Bignum is System.Shared_Bignums.Bignum;
function Big_Add (X, Y : Bignum) return Bignum; -- "+"
function Big_Sub (X, Y : Bignum) return Bignum; -- "-"
@@ -77,8 +79,6 @@ package System.Bignums is
private
- type Bignum is new System.Address;
-
pragma Inline (Big_Add);
pragma Inline (Big_Sub);
pragma Inline (Big_Mul);
diff --git a/gcc/ada/libgnat/s-bitfie.ads b/gcc/ada/libgnat/s-bitfie.ads
index a90605b..4f17a9c 100644
--- a/gcc/ada/libgnat/s-bitfie.ads
+++ b/gcc/ada/libgnat/s-bitfie.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-bitops.adb b/gcc/ada/libgnat/s-bitops.adb
index 7535810..19bf14f 100644
--- a/gcc/ada/libgnat/s-bitops.adb
+++ b/gcc/ada/libgnat/s-bitops.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-bitops.ads b/gcc/ada/libgnat/s-bitops.ads
index b7f8b0a..8caf77c 100644
--- a/gcc/ada/libgnat/s-bitops.ads
+++ b/gcc/ada/libgnat/s-bitops.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-bituti.adb b/gcc/ada/libgnat/s-bituti.adb
index b425e9f..e3bd70a 100644
--- a/gcc/ada/libgnat/s-bituti.adb
+++ b/gcc/ada/libgnat/s-bituti.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-bituti.ads b/gcc/ada/libgnat/s-bituti.ads
index 1e446c1..305133b 100644
--- a/gcc/ada/libgnat/s-bituti.ads
+++ b/gcc/ada/libgnat/s-bituti.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-boarop.ads b/gcc/ada/libgnat/s-boarop.ads
index c648413..3f3656d 100644
--- a/gcc/ada/libgnat/s-boarop.ads
+++ b/gcc/ada/libgnat/s-boarop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-boustr.adb b/gcc/ada/libgnat/s-boustr.adb
index 3b878a9..d153f10 100644
--- a/gcc/ada/libgnat/s-boustr.adb
+++ b/gcc/ada/libgnat/s-boustr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2016-2019, AdaCore --
+-- Copyright (C) 2016-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-boustr.ads b/gcc/ada/libgnat/s-boustr.ads
index af88c23..e49c5aa 100644
--- a/gcc/ada/libgnat/s-boustr.ads
+++ b/gcc/ada/libgnat/s-boustr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2016-2019, AdaCore --
+-- Copyright (C) 2016-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-bytswa.ads b/gcc/ada/libgnat/s-bytswa.ads
index 7ba6047..76d8ded 100644
--- a/gcc/ada/libgnat/s-bytswa.ads
+++ b/gcc/ada/libgnat/s-bytswa.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2019, AdaCore --
+-- Copyright (C) 2006-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-carsi8.adb b/gcc/ada/libgnat/s-carsi8.adb
index 8ffdb67..11ec460 100644
--- a/gcc/ada/libgnat/s-carsi8.adb
+++ b/gcc/ada/libgnat/s-carsi8.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-carsi8.ads b/gcc/ada/libgnat/s-carsi8.ads
index 7830859..a515aad 100644
--- a/gcc/ada/libgnat/s-carsi8.ads
+++ b/gcc/ada/libgnat/s-carsi8.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-carun8.adb b/gcc/ada/libgnat/s-carun8.adb
index 3304769..412410e 100644
--- a/gcc/ada/libgnat/s-carun8.adb
+++ b/gcc/ada/libgnat/s-carun8.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-carun8.ads b/gcc/ada/libgnat/s-carun8.ads
index f4694d1..f74c1e3 100644
--- a/gcc/ada/libgnat/s-carun8.ads
+++ b/gcc/ada/libgnat/s-carun8.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-casi16.adb b/gcc/ada/libgnat/s-casi16.adb
index 40741f4..17f8429 100644
--- a/gcc/ada/libgnat/s-casi16.adb
+++ b/gcc/ada/libgnat/s-casi16.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-casi16.ads b/gcc/ada/libgnat/s-casi16.ads
index 83b5fc9..cdb9b51 100644
--- a/gcc/ada/libgnat/s-casi16.ads
+++ b/gcc/ada/libgnat/s-casi16.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-casi32.adb b/gcc/ada/libgnat/s-casi32.adb
index b125d25..9d54fe3 100644
--- a/gcc/ada/libgnat/s-casi32.adb
+++ b/gcc/ada/libgnat/s-casi32.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-casi32.ads b/gcc/ada/libgnat/s-casi32.ads
index f497fbb..90ffaf0 100644
--- a/gcc/ada/libgnat/s-casi32.ads
+++ b/gcc/ada/libgnat/s-casi32.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-casi64.adb b/gcc/ada/libgnat/s-casi64.adb
index 4ec7161..464f99e 100644
--- a/gcc/ada/libgnat/s-casi64.adb
+++ b/gcc/ada/libgnat/s-casi64.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-casi64.ads b/gcc/ada/libgnat/s-casi64.ads
index f512c56..7296dd8 100644
--- a/gcc/ada/libgnat/s-casi64.ads
+++ b/gcc/ada/libgnat/s-casi64.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-casuti.adb b/gcc/ada/libgnat/s-casuti.adb
index 712b2b4..a8982f2 100644
--- a/gcc/ada/libgnat/s-casuti.adb
+++ b/gcc/ada/libgnat/s-casuti.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-casuti.ads b/gcc/ada/libgnat/s-casuti.ads
index 09b8ae0..4204b5e 100644
--- a/gcc/ada/libgnat/s-casuti.ads
+++ b/gcc/ada/libgnat/s-casuti.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-caun16.adb b/gcc/ada/libgnat/s-caun16.adb
index df3dcc1..ef016b5 100644
--- a/gcc/ada/libgnat/s-caun16.adb
+++ b/gcc/ada/libgnat/s-caun16.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-caun16.ads b/gcc/ada/libgnat/s-caun16.ads
index 8efac8a..beb6322 100644
--- a/gcc/ada/libgnat/s-caun16.ads
+++ b/gcc/ada/libgnat/s-caun16.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-caun32.adb b/gcc/ada/libgnat/s-caun32.adb
index d0ae97d..6979dfc 100644
--- a/gcc/ada/libgnat/s-caun32.adb
+++ b/gcc/ada/libgnat/s-caun32.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-caun32.ads b/gcc/ada/libgnat/s-caun32.ads
index e4fb4f9..8f07450b 100644
--- a/gcc/ada/libgnat/s-caun32.ads
+++ b/gcc/ada/libgnat/s-caun32.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-caun64.adb b/gcc/ada/libgnat/s-caun64.adb
index 2184721..32e3749 100644
--- a/gcc/ada/libgnat/s-caun64.adb
+++ b/gcc/ada/libgnat/s-caun64.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-caun64.ads b/gcc/ada/libgnat/s-caun64.ads
index 5d1413f..e732fc7 100644
--- a/gcc/ada/libgnat/s-caun64.ads
+++ b/gcc/ada/libgnat/s-caun64.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-chepoo.ads b/gcc/ada/libgnat/s-chepoo.ads
index b253df7..47ea922 100644
--- a/gcc/ada/libgnat/s-chepoo.ads
+++ b/gcc/ada/libgnat/s-chepoo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-commun.adb b/gcc/ada/libgnat/s-commun.adb
index 65b2a14..0e924be 100644
--- a/gcc/ada/libgnat/s-commun.adb
+++ b/gcc/ada/libgnat/s-commun.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-commun.ads b/gcc/ada/libgnat/s-commun.ads
index 4528415..b338343 100644
--- a/gcc/ada/libgnat/s-commun.ads
+++ b/gcc/ada/libgnat/s-commun.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, AdaCore --
+-- Copyright (C) 2001-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-conca2.adb b/gcc/ada/libgnat/s-conca2.adb
index 37ec804..3b6639c 100644
--- a/gcc/ada/libgnat/s-conca2.adb
+++ b/gcc/ada/libgnat/s-conca2.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-conca2.ads b/gcc/ada/libgnat/s-conca2.ads
index 2250e09..d120d47 100644
--- a/gcc/ada/libgnat/s-conca2.ads
+++ b/gcc/ada/libgnat/s-conca2.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-conca3.adb b/gcc/ada/libgnat/s-conca3.adb
index 4685218..1115434 100644
--- a/gcc/ada/libgnat/s-conca3.adb
+++ b/gcc/ada/libgnat/s-conca3.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-conca3.ads b/gcc/ada/libgnat/s-conca3.ads
index 4c0c454..6935974 100644
--- a/gcc/ada/libgnat/s-conca3.ads
+++ b/gcc/ada/libgnat/s-conca3.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-conca4.adb b/gcc/ada/libgnat/s-conca4.adb
index 81e47b8..b170b1f 100644
--- a/gcc/ada/libgnat/s-conca4.adb
+++ b/gcc/ada/libgnat/s-conca4.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-conca4.ads b/gcc/ada/libgnat/s-conca4.ads
index cca1844..64157df 100644
--- a/gcc/ada/libgnat/s-conca4.ads
+++ b/gcc/ada/libgnat/s-conca4.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-conca5.adb b/gcc/ada/libgnat/s-conca5.adb
index 9612681..0b14a5c 100644
--- a/gcc/ada/libgnat/s-conca5.adb
+++ b/gcc/ada/libgnat/s-conca5.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-conca5.ads b/gcc/ada/libgnat/s-conca5.ads
index 8dfbda9..ec6c326 100644
--- a/gcc/ada/libgnat/s-conca5.ads
+++ b/gcc/ada/libgnat/s-conca5.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-conca6.adb b/gcc/ada/libgnat/s-conca6.adb
index d56523c..43a15b9 100644
--- a/gcc/ada/libgnat/s-conca6.adb
+++ b/gcc/ada/libgnat/s-conca6.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-conca6.ads b/gcc/ada/libgnat/s-conca6.ads
index 95b377d..20a9075 100644
--- a/gcc/ada/libgnat/s-conca6.ads
+++ b/gcc/ada/libgnat/s-conca6.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-conca7.adb b/gcc/ada/libgnat/s-conca7.adb
index 418c637..9691ec0 100644
--- a/gcc/ada/libgnat/s-conca7.adb
+++ b/gcc/ada/libgnat/s-conca7.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-conca7.ads b/gcc/ada/libgnat/s-conca7.ads
index 859e63a..2a382c2 100644
--- a/gcc/ada/libgnat/s-conca7.ads
+++ b/gcc/ada/libgnat/s-conca7.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-conca8.adb b/gcc/ada/libgnat/s-conca8.adb
index 53e3f19..44968ac 100644
--- a/gcc/ada/libgnat/s-conca8.adb
+++ b/gcc/ada/libgnat/s-conca8.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-conca8.ads b/gcc/ada/libgnat/s-conca8.ads
index 027f3c0..1bee3cf 100644
--- a/gcc/ada/libgnat/s-conca8.ads
+++ b/gcc/ada/libgnat/s-conca8.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-conca9.adb b/gcc/ada/libgnat/s-conca9.adb
index 9b3f33d..b5c4ade 100644
--- a/gcc/ada/libgnat/s-conca9.adb
+++ b/gcc/ada/libgnat/s-conca9.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-conca9.ads b/gcc/ada/libgnat/s-conca9.ads
index 632a002..fc900c6 100644
--- a/gcc/ada/libgnat/s-conca9.ads
+++ b/gcc/ada/libgnat/s-conca9.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-crc32.adb b/gcc/ada/libgnat/s-crc32.adb
index ae415e3..49df8c2 100644
--- a/gcc/ada/libgnat/s-crc32.adb
+++ b/gcc/ada/libgnat/s-crc32.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-crc32.ads b/gcc/ada/libgnat/s-crc32.ads
index 065ac1b..3591120 100644
--- a/gcc/ada/libgnat/s-crc32.ads
+++ b/gcc/ada/libgnat/s-crc32.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-crtl.ads b/gcc/ada/libgnat/s-crtl.ads
index 306a607..a3299ef 100644
--- a/gcc/ada/libgnat/s-crtl.ads
+++ b/gcc/ada/libgnat/s-crtl.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-dfmkio.ads b/gcc/ada/libgnat/s-dfmkio.ads
index 1629edb..cad07fe 100644
--- a/gcc/ada/libgnat/s-dfmkio.ads
+++ b/gcc/ada/libgnat/s-dfmkio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2018-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-dfmopr.ads b/gcc/ada/libgnat/s-dfmopr.ads
index be71b4f..f9e24bb 100644
--- a/gcc/ada/libgnat/s-dfmopr.ads
+++ b/gcc/ada/libgnat/s-dfmopr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2018-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-dgmgop.ads b/gcc/ada/libgnat/s-dgmgop.ads
index 5f38c65..3141ddb 100644
--- a/gcc/ada/libgnat/s-dgmgop.ads
+++ b/gcc/ada/libgnat/s-dgmgop.ads
@@ -7,7 +7,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-diflio.adb b/gcc/ada/libgnat/s-diflio.adb
index 20afccc..222679ef 100644
--- a/gcc/ada/libgnat/s-diflio.adb
+++ b/gcc/ada/libgnat/s-diflio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-diflio.ads b/gcc/ada/libgnat/s-diflio.ads
index fb92ea9..67bce0f 100644
--- a/gcc/ada/libgnat/s-diflio.ads
+++ b/gcc/ada/libgnat/s-diflio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-diflmk.ads b/gcc/ada/libgnat/s-diflmk.ads
index fcd5938..6ba1e01 100644
--- a/gcc/ada/libgnat/s-diflmk.ads
+++ b/gcc/ada/libgnat/s-diflmk.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2018-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-digemk.ads b/gcc/ada/libgnat/s-digemk.ads
index 6a2798a..5013083 100644
--- a/gcc/ada/libgnat/s-digemk.ads
+++ b/gcc/ada/libgnat/s-digemk.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-diinio.adb b/gcc/ada/libgnat/s-diinio.adb
index 2439769..a067ccc 100644
--- a/gcc/ada/libgnat/s-diinio.adb
+++ b/gcc/ada/libgnat/s-diinio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-diinio.ads b/gcc/ada/libgnat/s-diinio.ads
index a54804b..ddcd716 100644
--- a/gcc/ada/libgnat/s-diinio.ads
+++ b/gcc/ada/libgnat/s-diinio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-dilomk.ads b/gcc/ada/libgnat/s-dilomk.ads
index 0666b2d..df3d28f 100644
--- a/gcc/ada/libgnat/s-dilomk.ads
+++ b/gcc/ada/libgnat/s-dilomk.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2018-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-dim.ads b/gcc/ada/libgnat/s-dim.ads
index d119371..9780a85 100644
--- a/gcc/ada/libgnat/s-dim.ads
+++ b/gcc/ada/libgnat/s-dim.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2012-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-dimkio.ads b/gcc/ada/libgnat/s-dimkio.ads
index bb87bdf..4293103 100644
--- a/gcc/ada/libgnat/s-dimkio.ads
+++ b/gcc/ada/libgnat/s-dimkio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-dimmks.ads b/gcc/ada/libgnat/s-dimmks.ads
index 5a3f8e4..24eb0b9 100644
--- a/gcc/ada/libgnat/s-dimmks.ads
+++ b/gcc/ada/libgnat/s-dimmks.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-direio.adb b/gcc/ada/libgnat/s-direio.adb
index 23b1157..0ebc2bc 100644
--- a/gcc/ada/libgnat/s-direio.adb
+++ b/gcc/ada/libgnat/s-direio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-direio.ads b/gcc/ada/libgnat/s-direio.ads
index c2672ca..aa93797 100644
--- a/gcc/ada/libgnat/s-direio.ads
+++ b/gcc/ada/libgnat/s-direio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-dlmkio.ads b/gcc/ada/libgnat/s-dlmkio.ads
index 2a13299..fccfd8b 100644
--- a/gcc/ada/libgnat/s-dlmkio.ads
+++ b/gcc/ada/libgnat/s-dlmkio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2018-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-dlmopr.ads b/gcc/ada/libgnat/s-dlmopr.ads
index 53dc586..ee743d5 100644
--- a/gcc/ada/libgnat/s-dlmopr.ads
+++ b/gcc/ada/libgnat/s-dlmopr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2018-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-dmotpr.ads b/gcc/ada/libgnat/s-dmotpr.ads
index 0208341..04d6ca4 100644
--- a/gcc/ada/libgnat/s-dmotpr.ads
+++ b/gcc/ada/libgnat/s-dmotpr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-dsaser.ads b/gcc/ada/libgnat/s-dsaser.ads
index 2275669..4f38d8b 100644
--- a/gcc/ada/libgnat/s-dsaser.ads
+++ b/gcc/ada/libgnat/s-dsaser.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb
index 5307eae..dbd4c53 100644
--- a/gcc/ada/libgnat/s-dwalin.adb
+++ b/gcc/ada/libgnat/s-dwalin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -440,6 +440,10 @@ package body System.Dwarf_Lines is
or else Info_Sec = Null_Section
or else Aranges_Sec = Null_Section
then
+ pragma Annotate
+ (CodePeer, False_Positive,
+ "test always true", "codepeer got confused");
+
C.Has_Debug := False;
return;
end if;
@@ -883,6 +887,7 @@ package body System.Dwarf_Lines is
Success : out Boolean)
is
begin
+ Info_Offset := 0;
Seek (C.Aranges, 0);
while Tell (C.Aranges) < Length (C.Aranges) loop
@@ -905,6 +910,7 @@ package body System.Dwarf_Lines is
end;
end loop;
end loop;
+
Success := False;
end Aranges_Lookup;
@@ -1028,6 +1034,7 @@ package body System.Dwarf_Lines is
Has_Child : uint8;
pragma Unreferenced (Has_Child);
begin
+ Line_Offset := 0;
Success := False;
Seek (C.Info, Info_Offset);
@@ -1119,7 +1126,8 @@ package body System.Dwarf_Lines is
Version : uint16;
Sz : uint8;
begin
- Success := False;
+ Success := False;
+ Info_Offset := 0;
Read_Initial_Length (C.Aranges, Unit_Length, Is64);
@@ -1407,6 +1415,7 @@ package body System.Dwarf_Lines is
Success : Boolean;
Done : Boolean;
S : Object_Symbol;
+
begin
-- Initialize result
Dir_Name := null;
@@ -1422,6 +1431,8 @@ package body System.Dwarf_Lines is
begin
First := C.Cache'First;
Last := C.Cache'Last;
+ Mid := First;
+
while First <= Last loop
Mid := First + (Last - First) / 2;
if Addr_Off < C.Cache (Mid).First then
@@ -1432,6 +1443,7 @@ package body System.Dwarf_Lines is
exit;
end if;
end loop;
+
if Addr_Off >= C.Cache (Mid).First
and then Addr_Off < C.Cache (Mid).First + C.Cache (Mid).Size
then
@@ -1474,6 +1486,7 @@ package body System.Dwarf_Lines is
C.Next_Prologue := 0;
Initialize_State_Machine (C);
Parse_Prologue (C);
+ Previous_Row.Line := 0;
-- Advance to the first entry
@@ -1535,7 +1548,7 @@ package body System.Dwarf_Lines is
(Cin : Dwarf_Context;
Traceback : AET.Tracebacks_Array;
Suppress_Hex : Boolean;
- Symbol_Found : in out Boolean;
+ Symbol_Found : out Boolean;
Res : in out System.Bounded_Strings.Bounded_String)
is
use Ada.Characters.Handling;
diff --git a/gcc/ada/libgnat/s-dwalin.ads b/gcc/ada/libgnat/s-dwalin.ads
index 297fd8e..2753be3 100644
--- a/gcc/ada/libgnat/s-dwalin.ads
+++ b/gcc/ada/libgnat/s-dwalin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -93,7 +93,7 @@ package System.Dwarf_Lines is
(Cin : Dwarf_Context;
Traceback : AET.Tracebacks_Array;
Suppress_Hex : Boolean;
- Symbol_Found : in out Boolean;
+ Symbol_Found : out Boolean;
Res : in out System.Bounded_Strings.Bounded_String);
-- Generate a string for a traceback suitable for displaying to the user.
-- If one or more symbols are found, Symbol_Found is set to True. This
diff --git a/gcc/ada/libgnat/s-elaall.adb b/gcc/ada/libgnat/s-elaall.adb
index 24fc0ff..03ed66c 100644
--- a/gcc/ada/libgnat/s-elaall.adb
+++ b/gcc/ada/libgnat/s-elaall.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-elaall.ads b/gcc/ada/libgnat/s-elaall.ads
index 3773b72..27344bf 100644
--- a/gcc/ada/libgnat/s-elaall.ads
+++ b/gcc/ada/libgnat/s-elaall.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-excdeb.adb b/gcc/ada/libgnat/s-excdeb.adb
index 8e48caf..56efde6 100644
--- a/gcc/ada/libgnat/s-excdeb.adb
+++ b/gcc/ada/libgnat/s-excdeb.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2006-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-excdeb.ads b/gcc/ada/libgnat/s-excdeb.ads
index 7afdb6c..c1836b2 100644
--- a/gcc/ada/libgnat/s-excdeb.ads
+++ b/gcc/ada/libgnat/s-excdeb.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-except.adb b/gcc/ada/libgnat/s-except.adb
index b742226..228cf2b 100644
--- a/gcc/ada/libgnat/s-except.adb
+++ b/gcc/ada/libgnat/s-except.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2006-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-except.ads b/gcc/ada/libgnat/s-except.ads
index 02a139f..29d960e 100644
--- a/gcc/ada/libgnat/s-except.ads
+++ b/gcc/ada/libgnat/s-except.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-excmac__arm.adb b/gcc/ada/libgnat/s-excmac__arm.adb
index 5571245..faf53b7 100644
--- a/gcc/ada/libgnat/s-excmac__arm.adb
+++ b/gcc/ada/libgnat/s-excmac__arm.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2013-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-excmac__arm.ads b/gcc/ada/libgnat/s-excmac__arm.ads
index 380c116..65269ae 100644
--- a/gcc/ada/libgnat/s-excmac__arm.ads
+++ b/gcc/ada/libgnat/s-excmac__arm.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2013-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-excmac__gcc.adb b/gcc/ada/libgnat/s-excmac__gcc.adb
index add7c3a..ead0550 100644
--- a/gcc/ada/libgnat/s-excmac__gcc.adb
+++ b/gcc/ada/libgnat/s-excmac__gcc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2013-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-excmac__gcc.ads b/gcc/ada/libgnat/s-excmac__gcc.ads
index bdb2648..f7148a3 100644
--- a/gcc/ada/libgnat/s-excmac__gcc.ads
+++ b/gcc/ada/libgnat/s-excmac__gcc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2013-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exctab.adb b/gcc/ada/libgnat/s-exctab.adb
index 09f494e..ec5e0a7 100644
--- a/gcc/ada/libgnat/s-exctab.adb
+++ b/gcc/ada/libgnat/s-exctab.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exctab.ads b/gcc/ada/libgnat/s-exctab.ads
index 4063b15..d0ead62 100644
--- a/gcc/ada/libgnat/s-exctab.ads
+++ b/gcc/ada/libgnat/s-exctab.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exctra.adb b/gcc/ada/libgnat/s-exctra.adb
index 3254d10..2ada43b 100644
--- a/gcc/ada/libgnat/s-exctra.adb
+++ b/gcc/ada/libgnat/s-exctra.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exctra.ads b/gcc/ada/libgnat/s-exctra.ads
index 73380b2..e3b360f 100644
--- a/gcc/ada/libgnat/s-exctra.ads
+++ b/gcc/ada/libgnat/s-exctra.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exnint.adb b/gcc/ada/libgnat/s-exnint.adb
index 46bb82d..fccd675 100644
--- a/gcc/ada/libgnat/s-exnint.adb
+++ b/gcc/ada/libgnat/s-exnint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exnint.ads b/gcc/ada/libgnat/s-exnint.ads
index 3e99a39..29303a3 100644
--- a/gcc/ada/libgnat/s-exnint.ads
+++ b/gcc/ada/libgnat/s-exnint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exnllf.adb b/gcc/ada/libgnat/s-exnllf.adb
index 84bf7f9..7ca2675 100644
--- a/gcc/ada/libgnat/s-exnllf.adb
+++ b/gcc/ada/libgnat/s-exnllf.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exnllf.ads b/gcc/ada/libgnat/s-exnllf.ads
index b023bd8..6a334de 100644
--- a/gcc/ada/libgnat/s-exnllf.ads
+++ b/gcc/ada/libgnat/s-exnllf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exnlli.adb b/gcc/ada/libgnat/s-exnlli.adb
index 6e77b09..dc486d6 100644
--- a/gcc/ada/libgnat/s-exnlli.adb
+++ b/gcc/ada/libgnat/s-exnlli.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exnlli.ads b/gcc/ada/libgnat/s-exnlli.ads
index 2e716d4..f6d94de 100644
--- a/gcc/ada/libgnat/s-exnlli.ads
+++ b/gcc/ada/libgnat/s-exnlli.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-expint.adb b/gcc/ada/libgnat/s-expint.adb
index 1cc2181..aa3445c 100644
--- a/gcc/ada/libgnat/s-expint.adb
+++ b/gcc/ada/libgnat/s-expint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-expint.ads b/gcc/ada/libgnat/s-expint.ads
index f6c9f83..584564a 100644
--- a/gcc/ada/libgnat/s-expint.ads
+++ b/gcc/ada/libgnat/s-expint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-explli.adb b/gcc/ada/libgnat/s-explli.adb
index 782d881..4f244cd 100644
--- a/gcc/ada/libgnat/s-explli.adb
+++ b/gcc/ada/libgnat/s-explli.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-explli.ads b/gcc/ada/libgnat/s-explli.ads
index be37781..f1283cd 100644
--- a/gcc/ada/libgnat/s-explli.ads
+++ b/gcc/ada/libgnat/s-explli.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-expllu.adb b/gcc/ada/libgnat/s-expllu.adb
index ad28a24..5615e4a 100644
--- a/gcc/ada/libgnat/s-expllu.adb
+++ b/gcc/ada/libgnat/s-expllu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-expllu.ads b/gcc/ada/libgnat/s-expllu.ads
index 683aae2..2127aaad 100644
--- a/gcc/ada/libgnat/s-expllu.ads
+++ b/gcc/ada/libgnat/s-expllu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-expmod.adb b/gcc/ada/libgnat/s-expmod.adb
index 713a6e7..1d6b404 100644
--- a/gcc/ada/libgnat/s-expmod.adb
+++ b/gcc/ada/libgnat/s-expmod.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-expmod.ads b/gcc/ada/libgnat/s-expmod.ads
index d221a2b..925ae11 100644
--- a/gcc/ada/libgnat/s-expmod.ads
+++ b/gcc/ada/libgnat/s-expmod.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-expuns.adb b/gcc/ada/libgnat/s-expuns.adb
index 4bf3f3f..da43763 100644
--- a/gcc/ada/libgnat/s-expuns.adb
+++ b/gcc/ada/libgnat/s-expuns.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-expuns.ads b/gcc/ada/libgnat/s-expuns.ads
index 69dd64f..a0d8085 100644
--- a/gcc/ada/libgnat/s-expuns.ads
+++ b/gcc/ada/libgnat/s-expuns.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-fatflt.ads b/gcc/ada/libgnat/s-fatflt.ads
index 3e9abfa..615e5f4 100644
--- a/gcc/ada/libgnat/s-fatflt.ads
+++ b/gcc/ada/libgnat/s-fatflt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-fatgen.adb b/gcc/ada/libgnat/s-fatgen.adb
index 93237fb..b544587 100644
--- a/gcc/ada/libgnat/s-fatgen.adb
+++ b/gcc/ada/libgnat/s-fatgen.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -219,6 +219,10 @@ package body System.Fat_Gen is
Ax := Ax * R_Power (Expbits'Last);
Ex := Ex - Log_Power (Expbits'Last);
end loop;
+ pragma Annotate
+ (CodePeer, Intentional,
+ "test always false",
+ "expected for some instantiations");
-- Rad ** -64 <= Ax < 1
diff --git a/gcc/ada/libgnat/s-fatgen.ads b/gcc/ada/libgnat/s-fatgen.ads
index d338a45..b84d23b 100644
--- a/gcc/ada/libgnat/s-fatgen.ads
+++ b/gcc/ada/libgnat/s-fatgen.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-fatlfl.ads b/gcc/ada/libgnat/s-fatlfl.ads
index 48539c6..2be41118 100644
--- a/gcc/ada/libgnat/s-fatlfl.ads
+++ b/gcc/ada/libgnat/s-fatlfl.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-fatllf.ads b/gcc/ada/libgnat/s-fatllf.ads
index b352ecc..6361296 100644
--- a/gcc/ada/libgnat/s-fatllf.ads
+++ b/gcc/ada/libgnat/s-fatllf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-fatsfl.ads b/gcc/ada/libgnat/s-fatsfl.ads
index ad7a810..45b13e1 100644
--- a/gcc/ada/libgnat/s-fatsfl.ads
+++ b/gcc/ada/libgnat/s-fatsfl.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-ficobl.ads b/gcc/ada/libgnat/s-ficobl.ads
index 5098d6b..1532cdb 100644
--- a/gcc/ada/libgnat/s-ficobl.ads
+++ b/gcc/ada/libgnat/s-ficobl.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-filatt.ads b/gcc/ada/libgnat/s-filatt.ads
index 8588458..d969cec 100644
--- a/gcc/ada/libgnat/s-filatt.ads
+++ b/gcc/ada/libgnat/s-filatt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2013-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-fileio.adb b/gcc/ada/libgnat/s-fileio.adb
index 6339532..b6377e3 100644
--- a/gcc/ada/libgnat/s-fileio.adb
+++ b/gcc/ada/libgnat/s-fileio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-fileio.ads b/gcc/ada/libgnat/s-fileio.ads
index f4aa52a..de464d8 100644
--- a/gcc/ada/libgnat/s-fileio.ads
+++ b/gcc/ada/libgnat/s-fileio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-finmas.adb b/gcc/ada/libgnat/s-finmas.adb
index 9004d76..5a6583a 100644
--- a/gcc/ada/libgnat/s-finmas.adb
+++ b/gcc/ada/libgnat/s-finmas.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2015-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-finmas.ads b/gcc/ada/libgnat/s-finmas.ads
index 5b2fc39..ae0276f 100644
--- a/gcc/ada/libgnat/s-finmas.ads
+++ b/gcc/ada/libgnat/s-finmas.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-finroo.adb b/gcc/ada/libgnat/s-finroo.adb
index e4184c1..c56f8fa 100644
--- a/gcc/ada/libgnat/s-finroo.adb
+++ b/gcc/ada/libgnat/s-finroo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-finroo.ads b/gcc/ada/libgnat/s-finroo.ads
index 0a32ecf..c3b36c0 100644
--- a/gcc/ada/libgnat/s-finroo.ads
+++ b/gcc/ada/libgnat/s-finroo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-flocon.adb b/gcc/ada/libgnat/s-flocon.adb
index f50359a..9eabefc 100644
--- a/gcc/ada/libgnat/s-flocon.adb
+++ b/gcc/ada/libgnat/s-flocon.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, AdaCore --
+-- Copyright (C) 2011-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-flocon.ads b/gcc/ada/libgnat/s-flocon.ads
index af4eef5..a5617c0 100644
--- a/gcc/ada/libgnat/s-flocon.ads
+++ b/gcc/ada/libgnat/s-flocon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, AdaCore --
+-- Copyright (C) 2000-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-flocon__none.adb b/gcc/ada/libgnat/s-flocon__none.adb
index 435363a..1dc3132 100644
--- a/gcc/ada/libgnat/s-flocon__none.adb
+++ b/gcc/ada/libgnat/s-flocon__none.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, AdaCore --
+-- Copyright (C) 2011-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-fore.adb b/gcc/ada/libgnat/s-fore.adb
index 43afbef..2a4aa81 100644
--- a/gcc/ada/libgnat/s-fore.adb
+++ b/gcc/ada/libgnat/s-fore.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-fore.ads b/gcc/ada/libgnat/s-fore.ads
index 7f06b0d..7d78952 100644
--- a/gcc/ada/libgnat/s-fore.ads
+++ b/gcc/ada/libgnat/s-fore.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-gearop.adb b/gcc/ada/libgnat/s-gearop.adb
index 4064571..3eaeec2 100644
--- a/gcc/ada/libgnat/s-gearop.adb
+++ b/gcc/ada/libgnat/s-gearop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2006-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -240,6 +240,8 @@ package body System.Generic_Array_Operations is
for J in N'Range (2) loop
N (Row - M'First (1) + N'First (1), J) :=
N (Row - M'First (1) + N'First (1), J) / Scale;
+ pragma Annotate
+ (CodePeer, False_Positive, "divide by zero", "Scale /= 0");
end loop;
end Divide_Row;
@@ -602,6 +604,9 @@ package body System.Generic_Array_Operations is
end if;
elsif X > Real'Base'Last then
+ pragma Annotate
+ (CodePeer, Intentional,
+ "test always false", "test for infinity");
-- X is infinity, which is its own square root
@@ -627,6 +632,8 @@ package body System.Generic_Array_Operations is
-- of precision.
for J in 1 .. 8 loop
+ pragma Assert (Root /= 0.0);
+
Next := (Root + X / Root) / 2.0;
exit when Root = Next;
Root := Next;
diff --git a/gcc/ada/libgnat/s-gearop.ads b/gcc/ada/libgnat/s-gearop.ads
index b25d40e..2ee455c 100644
--- a/gcc/ada/libgnat/s-gearop.ads
+++ b/gcc/ada/libgnat/s-gearop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-genbig.adb b/gcc/ada/libgnat/s-genbig.adb
index 0a92dfb..71aff9b 100644
--- a/gcc/ada/libgnat/s-genbig.adb
+++ b/gcc/ada/libgnat/s-genbig.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2012-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,15 +31,13 @@
-- This package provides arbitrary precision signed integer arithmetic.
-with System; use System;
-with System.Secondary_Stack; use System.Secondary_Stack;
-with System.Storage_Elements; use System.Storage_Elements;
-
package body System.Generic_Bignums is
use Interfaces;
-- So that operations on Unsigned_32/Unsigned_64 are available
+ use Shared_Bignums;
+
type DD is mod Base ** 2;
-- Double length digit used for intermediate computations
@@ -65,18 +63,13 @@ package body System.Generic_Bignums is
function Add
(X, Y : Digit_Vector;
X_Neg : Boolean;
- Y_Neg : Boolean) return Bignum
+ Y_Neg : Boolean) return Big_Integer
with
Pre => X'First = 1 and then Y'First = 1;
-- This procedure adds two signed numbers returning the Sum, it is used
-- for both addition and subtraction. The value computed is X + Y, with
-- X_Neg and Y_Neg giving the signs of the operands.
- function Allocate_Bignum (Len : Length) return Bignum with
- Post => Allocate_Bignum'Result.Len = Len;
- -- Allocate Bignum value of indicated length on secondary stack. On return
- -- the Neg and D fields are left uninitialized.
-
type Compare_Result is (LT, EQ, GT);
-- Indicates result of comparison in following call
@@ -90,8 +83,8 @@ package body System.Generic_Bignums is
procedure Div_Rem
(X, Y : Bignum;
- Quotient : out Bignum;
- Remainder : out Bignum;
+ Quotient : out Big_Integer;
+ Remainder : out Big_Integer;
Discard_Quotient : Boolean := False;
Discard_Remainder : Boolean := False);
-- Returns the Quotient and Remainder from dividing abs (X) by abs (Y). The
@@ -99,18 +92,16 @@ package body System.Generic_Bignums is
-- Quotient is undefined on return, and if Discard_Remainder is True, then
-- Remainder is undefined on return. Service routine for Big_Div/Rem/Mod.
- procedure Free_Bignum (X : Bignum) is null;
- -- Called to free a Bignum value used in intermediate computations. In
- -- this implementation using the secondary stack, it does nothing at all,
- -- because we rely on Mark/Release, but it may be of use for some
- -- alternative implementation.
-
function Normalize
(X : Digit_Vector;
- Neg : Boolean := False) return Bignum;
- -- Given a digit vector and sign, allocate and construct a Bignum value.
- -- Note that X may have leading zeroes which must be removed, and if the
- -- result is zero, the sign is forced positive.
+ Neg : Boolean := False) return Big_Integer;
+ -- Given a digit vector and sign, allocate and construct a big integer
+ -- value. Note that X may have leading zeroes which must be removed, and if
+ -- the result is zero, the sign is forced positive.
+ -- If X is too big, Storage_Error is raised.
+
+ function "**" (X : Bignum; Y : SD) return Big_Integer;
+ -- Exponentiation routine where we know right operand is one word
---------
-- Add --
@@ -119,7 +110,7 @@ package body System.Generic_Bignums is
function Add
(X, Y : Digit_Vector;
X_Neg : Boolean;
- Y_Neg : Boolean) return Bignum
+ Y_Neg : Boolean) return Big_Integer
is
begin
-- If signs are the same, we are doing an addition, it is convenient to
@@ -202,73 +193,11 @@ package body System.Generic_Bignums is
end if;
end Add;
- ---------------------
- -- Allocate_Bignum --
- ---------------------
-
- function Allocate_Bignum (Len : Length) return Bignum is
- Addr : Address;
-
- begin
- -- Allocation on the heap
-
- if not Use_Secondary_Stack then
- declare
- B : Bignum;
- begin
- B := new Bignum_Data'(Len, False, (others => 0));
- return B;
- end;
-
- -- Allocation on the secondary stack
-
- else
- -- Note: The approach used here is designed to avoid strict aliasing
- -- warnings that appeared previously using unchecked conversion.
-
- SS_Allocate (Addr, Storage_Offset (4 + 4 * Len));
-
- declare
- B : Bignum;
- for B'Address use Addr'Address;
- pragma Import (Ada, B);
-
- BD : Bignum_Data (Len);
- for BD'Address use Addr;
- pragma Import (Ada, BD);
-
- -- Expose a writable view of discriminant BD.Len so that we can
- -- initialize it. We need to use the exact layout of the record
- -- to ensure that the Length field has 24 bits as expected.
-
- type Bignum_Data_Header is record
- Len : Length;
- Neg : Boolean;
- end record;
-
- for Bignum_Data_Header use record
- Len at 0 range 0 .. 23;
- Neg at 3 range 0 .. 7;
- end record;
-
- BDH : Bignum_Data_Header;
- for BDH'Address use BD'Address;
- pragma Import (Ada, BDH);
-
- pragma Assert (BDH.Len'Size = BD.Len'Size);
-
- begin
- BDH.Len := Len;
- return B;
- end;
- end if;
- end Allocate_Bignum;
-
-------------
-- Big_Abs --
-------------
- function Big_Abs (X : Bignum) return Bignum is
+ function Big_Abs (X : Bignum) return Big_Integer is
begin
return Normalize (X.D);
end Big_Abs;
@@ -277,7 +206,7 @@ package body System.Generic_Bignums is
-- Big_Add --
-------------
- function Big_Add (X, Y : Bignum) return Bignum is
+ function Big_Add (X, Y : Bignum) return Big_Integer is
begin
return Add (X.D, Y.D, X.Neg, Y.Neg);
end Big_Add;
@@ -305,85 +234,69 @@ package body System.Generic_Bignums is
-- 13 -5 -2 -13 -5 2
-- 14 -5 -2 -14 -5 2
- function Big_Div (X, Y : Bignum) return Bignum is
- Q, R : Bignum;
+ function Big_Div (X, Y : Bignum) return Big_Integer is
+ Q, R : aliased Big_Integer;
begin
Div_Rem (X, Y, Q, R, Discard_Remainder => True);
- Q.Neg := Q.Len > 0 and then (X.Neg xor Y.Neg);
+ To_Bignum (Q).Neg := To_Bignum (Q).Len > 0 and then (X.Neg xor Y.Neg);
return Q;
end Big_Div;
- -------------
- -- Big_Exp --
- -------------
-
- function Big_Exp (X, Y : Bignum) return Bignum is
-
- function "**" (X : Bignum; Y : SD) return Bignum;
- -- Internal routine where we know right operand is one word
-
- ----------
- -- "**" --
- ----------
-
- function "**" (X : Bignum; Y : SD) return Bignum is
- begin
- case Y is
-
- -- X ** 0 is 1
-
- when 0 =>
- return Normalize (One_Data);
-
- -- X ** 1 is X
-
- when 1 =>
- return Normalize (X.D);
+ ----------
+ -- "**" --
+ ----------
- -- X ** 2 is X * X
+ function "**" (X : Bignum; Y : SD) return Big_Integer is
+ begin
+ case Y is
- when 2 =>
- return Big_Mul (X, X);
+ -- X ** 0 is 1
- -- For X greater than 2, use the recursion
+ when 0 =>
+ return Normalize (One_Data);
- -- X even, X ** Y = (X ** (Y/2)) ** 2;
- -- X odd, X ** Y = (X ** (Y/2)) ** 2 * X;
+ -- X ** 1 is X
- when others =>
- declare
- XY2 : constant Bignum := X ** (Y / 2);
- XY2S : constant Bignum := Big_Mul (XY2, XY2);
- Res : Bignum;
+ when 1 =>
+ return Normalize (X.D);
- begin
- Free_Bignum (XY2);
+ -- X ** 2 is X * X
- -- Raise storage error if intermediate value is getting too
- -- large, which we arbitrarily define as 200 words for now.
+ when 2 =>
+ return Big_Mul (X, X);
- if XY2S.Len > 200 then
- Free_Bignum (XY2S);
- raise Storage_Error with
- "exponentiation result is too large";
- end if;
+ -- For X greater than 2, use the recursion
- -- Otherwise take care of even/odd cases
+ -- X even, X ** Y = (X ** (Y/2)) ** 2;
+ -- X odd, X ** Y = (X ** (Y/2)) ** 2 * X;
- if (Y and 1) = 0 then
- return XY2S;
+ when others =>
+ declare
+ XY2 : aliased Big_Integer := X ** (Y / 2);
+ XY2S : aliased Big_Integer :=
+ Big_Mul (To_Bignum (XY2), To_Bignum (XY2));
- else
- Res := Big_Mul (XY2S, X);
- Free_Bignum (XY2S);
- return Res;
- end if;
- end;
- end case;
- end "**";
+ begin
+ Free_Big_Integer (XY2);
+
+ if (Y and 1) = 0 then
+ return XY2S;
+ else
+ return Res : constant Big_Integer :=
+ Big_Mul (To_Bignum (XY2S), X)
+ do
+ Free_Big_Integer (XY2S);
+ end return;
+ end if;
+ end;
+ end case;
+ end "**";
- -- Start of processing for Big_Exp
+ -------------
+ -- Big_Exp --
+ -------------
+ function Big_Exp (X, Y : Bignum) return Big_Integer is
begin
-- Error if right operand negative
@@ -431,6 +344,127 @@ package body System.Generic_Bignums is
end if;
end Big_Exp;
+ -------------
+ -- Big_And --
+ -------------
+
+ function Big_And (X, Y : Bignum) return Big_Integer is
+ begin
+ if X.Len > Y.Len then
+ return Big_And (X => Y, Y => X);
+ end if;
+
+ -- X is the smallest integer
+
+ declare
+ Result : Digit_Vector (1 .. X.Len);
+ Diff : constant Length := Y.Len - X.Len;
+ begin
+ for J in 1 .. X.Len loop
+ Result (J) := X.D (J) and Y.D (J + Diff);
+ end loop;
+
+ return Normalize (Result, X.Neg and Y.Neg);
+ end;
+ end Big_And;
+
+ ------------
+ -- Big_Or --
+ ------------
+
+ function Big_Or (X, Y : Bignum) return Big_Integer is
+ begin
+ if X.Len < Y.Len then
+ return Big_Or (X => Y, Y => X);
+ end if;
+
+ -- X is the largest integer
+
+ declare
+ Result : Digit_Vector (1 .. X.Len);
+ Index : Length;
+ Diff : constant Length := X.Len - Y.Len;
+
+ begin
+ Index := 1;
+
+ while Index <= Diff loop
+ Result (Index) := X.D (Index);
+ Index := Index + 1;
+ end loop;
+
+ for J in 1 .. Y.Len loop
+ Result (Index) := X.D (Index) or Y.D (J);
+ Index := Index + 1;
+ end loop;
+
+ return Normalize (Result, X.Neg or Y.Neg);
+ end;
+ end Big_Or;
+
+ --------------------
+ -- Big_Shift_Left --
+ --------------------
+
+ function Big_Shift_Left (X : Bignum; Amount : Natural) return Big_Integer is
+ begin
+ if X.Neg then
+ raise Constraint_Error;
+ elsif Amount = 0 then
+ return Allocate_Big_Integer (X.D, False);
+ end if;
+
+ declare
+ Shift : constant Natural := Amount rem SD'Size;
+ Result : Digit_Vector (0 .. X.Len + Amount / SD'Size);
+ Carry : SD := 0;
+
+ begin
+ for J in X.Len + 1 .. Result'Last loop
+ Result (J) := 0;
+ end loop;
+
+ for J in reverse 1 .. X.Len loop
+ Result (J) := Shift_Left (X.D (J), Shift) or Carry;
+ Carry := Shift_Right (X.D (J), SD'Size - Shift);
+ end loop;
+
+ Result (0) := Carry;
+ return Normalize (Result, False);
+ end;
+ end Big_Shift_Left;
+
+ ---------------------
+ -- Big_Shift_Right --
+ ---------------------
+
+ function Big_Shift_Right
+ (X : Bignum; Amount : Natural) return Big_Integer is
+ begin
+ if X.Neg then
+ raise Constraint_Error;
+ elsif Amount = 0 then
+ return Allocate_Big_Integer (X.D, False);
+ end if;
+
+ declare
+ Shift : constant Natural := Amount rem SD'Size;
+ Result : Digit_Vector (1 .. X.Len - Amount / SD'Size);
+ Carry : SD := 0;
+
+ begin
+ for J in 1 .. Result'Last - 1 loop
+ Result (J) := Shift_Right (X.D (J), Shift) or Carry;
+ Carry := Shift_Left (X.D (J), SD'Size - Shift);
+ end loop;
+
+ Result (Result'Last) :=
+ Shift_Right (X.D (Result'Last), Shift) or Carry;
+
+ return Normalize (Result, False);
+ end;
+ end Big_Shift_Right;
+
------------
-- Big_EQ --
------------
@@ -499,8 +533,8 @@ package body System.Generic_Bignums is
-- 13 -5 -2 3 -13 -5 -3 -3
-- 14 -5 -1 4 -14 -5 -4 -4
- function Big_Mod (X, Y : Bignum) return Bignum is
- Q, R : Bignum;
+ function Big_Mod (X, Y : Bignum) return Big_Integer is
+ Q, R : aliased Big_Integer;
begin
-- If signs are same, result is same as Rem
@@ -517,17 +551,17 @@ package body System.Generic_Bignums is
-- Zero result is unchanged
- if R.Len = 0 then
+ if To_Bignum (R).Len = 0 then
return R;
-- Otherwise adjust result
else
declare
- T1 : constant Bignum := Big_Sub (Y, R);
+ T1 : aliased Big_Integer := Big_Sub (Y, To_Bignum (R));
begin
- T1.Neg := Y.Neg;
- Free_Bignum (R);
+ To_Bignum (T1).Neg := Y.Neg;
+ Free_Big_Integer (R);
return T1;
end;
end if;
@@ -538,7 +572,7 @@ package body System.Generic_Bignums is
-- Big_Mul --
-------------
- function Big_Mul (X, Y : Bignum) return Bignum is
+ function Big_Mul (X, Y : Bignum) return Big_Integer is
Result : Digit_Vector (1 .. X.Len + Y.Len) := (others => 0);
-- Accumulate result (max length of result is sum of operand lengths)
@@ -589,7 +623,7 @@ package body System.Generic_Bignums is
-- Big_Neg --
-------------
- function Big_Neg (X : Bignum) return Bignum is
+ function Big_Neg (X : Bignum) return Big_Integer is
begin
return Normalize (X.D, not X.Neg);
end Big_Neg;
@@ -617,11 +651,11 @@ package body System.Generic_Bignums is
-- 13 -5 3 -13 -5 -3
-- 14 -5 4 -14 -5 -4
- function Big_Rem (X, Y : Bignum) return Bignum is
- Q, R : Bignum;
+ function Big_Rem (X, Y : Bignum) return Big_Integer is
+ Q, R : aliased Big_Integer;
begin
Div_Rem (X, Y, Q, R, Discard_Quotient => True);
- R.Neg := R.Len > 0 and then X.Neg;
+ To_Bignum (R).Neg := To_Bignum (R).Len > 0 and then X.Neg;
return R;
end Big_Rem;
@@ -629,7 +663,7 @@ package body System.Generic_Bignums is
-- Big_Sub --
-------------
- function Big_Sub (X, Y : Bignum) return Bignum is
+ function Big_Sub (X, Y : Bignum) return Big_Integer is
begin
-- If right operand zero, return left operand (avoiding sharing)
@@ -681,11 +715,10 @@ package body System.Generic_Bignums is
procedure Div_Rem
(X, Y : Bignum;
- Quotient : out Bignum;
- Remainder : out Bignum;
+ Quotient : out Big_Integer;
+ Remainder : out Big_Integer;
Discard_Quotient : Boolean := False;
- Discard_Remainder : Boolean := False)
- is
+ Discard_Remainder : Boolean := False) is
begin
-- Error if division by zero
@@ -698,8 +731,14 @@ package body System.Generic_Bignums is
-- If X < Y then quotient is zero and remainder is X
if Compare (X.D, Y.D, False, False) = LT then
- Remainder := Normalize (X.D);
- Quotient := Normalize (Zero_Data);
+ if not Discard_Quotient then
+ Quotient := Normalize (Zero_Data);
+ end if;
+
+ if not Discard_Remainder then
+ Remainder := Normalize (X.D);
+ end if;
+
return;
-- If both X and Y are less than 2**63-1, we can use Long_Long_Integer
@@ -714,8 +753,14 @@ package body System.Generic_Bignums is
A : constant LLI := abs (From_Bignum (X));
B : constant LLI := abs (From_Bignum (Y));
begin
- Quotient := To_Bignum (A / B);
- Remainder := To_Bignum (A rem B);
+ if not Discard_Quotient then
+ Quotient := To_Bignum (A / B);
+ end if;
+
+ if not Discard_Remainder then
+ Remainder := To_Bignum (A rem B);
+ end if;
+
return;
end;
@@ -733,13 +778,20 @@ package body System.Generic_Bignums is
ND := 0;
for J in 1 .. X.Len loop
ND := Base * ND + DD (X.D (J));
+ pragma Assert (Div /= 0);
Result (J) := SD (ND / Div);
ND := ND rem Div;
end loop;
- Quotient := Normalize (Result);
- Remdr (1) := SD (ND);
- Remainder := Normalize (Remdr);
+ if not Discard_Quotient then
+ Quotient := Normalize (Result);
+ end if;
+
+ if not Discard_Remainder then
+ Remdr (1) := SD (ND);
+ Remainder := Normalize (Remdr);
+ end if;
+
return;
end;
end if;
@@ -968,9 +1020,9 @@ package body System.Generic_Bignums is
if not Discard_Remainder then
declare
Remdr : DD;
-
begin
Remdr := 0;
+
for K in 1 .. n loop
Remdr := Base * Remdr + DD (u (m + K));
r (K) := SD (Remdr / d);
@@ -1043,11 +1095,12 @@ package body System.Generic_Bignums is
-- Normalize --
---------------
+ Bignum_Limit : constant := 200;
+
function Normalize
(X : Digit_Vector;
- Neg : Boolean := False) return Bignum
+ Neg : Boolean := False) return Big_Integer
is
- B : Bignum;
J : Length;
begin
@@ -1056,73 +1109,163 @@ package body System.Generic_Bignums is
J := J + 1;
end loop;
- B := Allocate_Bignum (X'Last - J + 1);
- B.Neg := B.Len > 0 and then Neg;
- B.D := X (J .. X'Last);
- return B;
+ if X'Last - J > Bignum_Limit then
+ raise Storage_Error with "big integer limit exceeded";
+ end if;
+
+ return Allocate_Big_Integer (X (J .. X'Last), J <= X'Last and then Neg);
end Normalize;
---------------
-- To_Bignum --
---------------
- function To_Bignum (X : Long_Long_Integer) return Bignum is
- R : Bignum;
-
+ function To_Bignum (X : Long_Long_Integer) return Big_Integer is
begin
if X = 0 then
- R := Allocate_Bignum (0);
+ return Allocate_Big_Integer ((1 .. 0 => <>), False);
-- One word result
elsif X in -(2 ** 32 - 1) .. +(2 ** 32 - 1) then
- R := Allocate_Bignum (1);
- R.D (1) := SD (abs (X));
+ return Allocate_Big_Integer ((1 => SD (abs X)), X < 0);
-- Largest negative number annoyance
elsif X = Long_Long_Integer'First then
- R := Allocate_Bignum (2);
- R.D (1) := 2 ** 31;
- R.D (2) := 0;
+ return Allocate_Big_Integer ((2 ** 31, 0), True);
+
+ -- Other negative numbers
- -- Normal two word case
+ elsif X < 0 then
+ return Allocate_Big_Integer
+ ((SD ((-X) / Base), SD ((-X) mod Base)), True);
+ -- Positive numbers
else
- R := Allocate_Bignum (2);
- R.D (2) := SD (abs (X) mod Base);
- R.D (1) := SD (abs (X) / Base);
+ return Allocate_Big_Integer ((SD (X / Base), SD (X mod Base)), False);
end if;
-
- R.Neg := X < 0;
- return R;
end To_Bignum;
- function To_Bignum (X : Unsigned_64) return Bignum is
- R : Bignum;
-
+ function To_Bignum (X : Unsigned_64) return Big_Integer is
begin
if X = 0 then
- R := Allocate_Bignum (0);
+ return Allocate_Big_Integer ((1 .. 0 => <>), False);
-- One word result
elsif X < 2 ** 32 then
- R := Allocate_Bignum (1);
- R.D (1) := SD (X);
+ return Allocate_Big_Integer ((1 => SD (X)), False);
-- Two word result
else
- R := Allocate_Bignum (2);
- R.D (2) := SD (X mod Base);
- R.D (1) := SD (X / Base);
+ return Allocate_Big_Integer ((SD (X / Base), SD (X mod Base)), False);
end if;
-
- R.Neg := False;
- return R;
end To_Bignum;
+ ---------------
+ -- To_String --
+ ---------------
+
+ Hex_Chars : constant array (0 .. 15) of Character := "0123456789ABCDEF";
+
+ function To_String
+ (X : Bignum; Width : Natural := 0; Base : Positive := 10) return String
+ is
+ Big_Base : aliased Bignum_Data := (1, False, (1 => SD (Base)));
+
+ function Add_Base (S : String) return String;
+ -- Add base information if Base /= 10
+
+ function Leading_Padding
+ (Str : String;
+ Min_Length : Natural;
+ Char : Character := ' ') return String;
+ -- Return padding of Char concatenated with Str so that the resulting
+ -- string is at least Min_Length long.
+
+ function Image (Arg : Bignum) return String;
+ -- Return image of Arg, assuming Arg is positive.
+
+ function Image (N : Natural) return String;
+ -- Return image of N, with no leading space.
+
+ --------------
+ -- Add_Base --
+ --------------
+
+ function Add_Base (S : String) return String is
+ begin
+ if Base = 10 then
+ return S;
+ else
+ return Image (Base) & "#" & S & "#";
+ end if;
+ end Add_Base;
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (N : Natural) return String is
+ S : constant String := Natural'Image (N);
+ begin
+ return S (2 .. S'Last);
+ end Image;
+
+ function Image (Arg : Bignum) return String is
+ begin
+ if Big_LT (Arg, Big_Base'Unchecked_Access) then
+ return (1 => Hex_Chars (Natural (From_Bignum (Arg))));
+ else
+ declare
+ Div : aliased Big_Integer;
+ Remain : aliased Big_Integer;
+ R : Natural;
+
+ begin
+ Div_Rem (Arg, Big_Base'Unchecked_Access, Div, Remain);
+ R := Natural (From_Bignum (To_Bignum (Remain)));
+ Free_Big_Integer (Remain);
+
+ return S : constant String :=
+ Image (To_Bignum (Div)) & Hex_Chars (R)
+ do
+ Free_Big_Integer (Div);
+ end return;
+ end;
+ end if;
+ end Image;
+
+ ---------------------
+ -- Leading_Padding --
+ ---------------------
+
+ function Leading_Padding
+ (Str : String;
+ Min_Length : Natural;
+ Char : Character := ' ') return String is
+ begin
+ return (1 .. Integer'Max (Integer (Min_Length) - Str'Length, 0)
+ => Char) & Str;
+ end Leading_Padding;
+
+ Zero : aliased Bignum_Data := (0, False, D => Zero_Data);
+
+ begin
+ if Big_LT (X, Zero'Unchecked_Access) then
+ declare
+ X_Pos : aliased Bignum_Data := (X.Len, not X.Neg, X.D);
+ begin
+ return Leading_Padding
+ ("-" & Add_Base (Image (X_Pos'Unchecked_Access)), Width);
+ end;
+ else
+ return Leading_Padding (" " & Add_Base (Image (X)), Width);
+ end if;
+ end To_String;
+
-------------
-- Is_Zero --
-------------
diff --git a/gcc/ada/libgnat/s-genbig.ads b/gcc/ada/libgnat/s-genbig.ads
index d9408af..003a8fd 100644
--- a/gcc/ada/libgnat/s-genbig.ads
+++ b/gcc/ada/libgnat/s-genbig.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2012-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,77 +33,57 @@
-- and can be used either built into the compiler via System.Bignums or to
-- implement a default version of Ada.Numerics.Big_Numbers.Big_Integers.
--- If Use_Secondary_Stack is True then all Bignum values are allocated on the
--- secondary stack. If False, the heap is used and the caller is responsible
--- for memory management.
-
-with Ada.Unchecked_Conversion;
with Interfaces;
+with System.Shared_Bignums;
generic
- Use_Secondary_Stack : Boolean;
-package System.Generic_Bignums is
- pragma Preelaborate;
-
- pragma Assert (Long_Long_Integer'Size = 64);
- -- This package assumes that Long_Long_Integer size is 64 bit (i.e. that it
- -- has a range of -2**63 to 2**63-1). The front end ensures that the mode
- -- ELIMINATED is not allowed for overflow checking if this is not the case.
-
- subtype Length is Natural range 0 .. 2 ** 23 - 1;
- -- Represent number of words in Digit_Vector
-
- Base : constant := 2 ** 32;
- -- Digit vectors use this base
-
- subtype SD is Interfaces.Unsigned_32;
- -- Single length digit
+ type Big_Integer is private;
- type Digit_Vector is array (Length range <>) of SD;
- -- Represent digits of a number (most significant digit first)
+ with function Allocate_Big_Integer
+ (D : Shared_Bignums.Digit_Vector; Neg : Boolean) return Big_Integer;
+ -- Allocate Bignum value with the given contents
- type Bignum_Data (Len : Length) is record
- Neg : Boolean;
- -- Set if value is negative, never set for zero
+ with procedure Free_Big_Integer (X : in out Big_Integer);
+ -- Free the memory associated with X
- D : Digit_Vector (1 .. Len);
- -- Digits of number, most significant first, represented in base
- -- 2**Base. No leading zeroes are stored, and the value of zero is
- -- represented using an empty vector for D.
- end record;
+ with function To_Bignum
+ (X : aliased in out Big_Integer) return Shared_Bignums.Bignum;
+ -- Convert the given Big_Integer to a Bignum
- for Bignum_Data use record
- Len at 0 range 0 .. 23;
- Neg at 3 range 0 .. 7;
- end record;
+package System.Generic_Bignums is
+ pragma Preelaborate;
- type Bignum is access all Bignum_Data;
- -- This is the type that is used externally. Possibly this could be a
- -- private type, but we leave the structure exposed for now. For one
- -- thing it helps with debugging. Note that this package never shares
- -- an allocated Bignum value, so for example for X + 0, a copy of X is
- -- returned, not X itself.
+ subtype Bignum is Shared_Bignums.Bignum;
- function To_Bignum is new Ada.Unchecked_Conversion (System.Address, Bignum);
- function To_Address is new
- Ada.Unchecked_Conversion (Bignum, System.Address);
+ -- Note that this package never shares an allocated Big_Integer value, so
+ -- so for example for X + 0, a copy of X is returned, not X itself.
-- Note: none of the subprograms in this package modify the Bignum_Data
-- records referenced by Bignum arguments of mode IN.
- function Big_Add (X, Y : Bignum) return Bignum; -- "+"
- function Big_Sub (X, Y : Bignum) return Bignum; -- "-"
- function Big_Mul (X, Y : Bignum) return Bignum; -- "*"
- function Big_Div (X, Y : Bignum) return Bignum; -- "/"
- function Big_Exp (X, Y : Bignum) return Bignum; -- "**"
- function Big_Mod (X, Y : Bignum) return Bignum; -- "mod"
- function Big_Rem (X, Y : Bignum) return Bignum; -- "rem"
- function Big_Neg (X : Bignum) return Bignum; -- "-"
- function Big_Abs (X : Bignum) return Bignum; -- "abs"
+ function Big_Add (X, Y : Bignum) return Big_Integer; -- "+"
+ function Big_Sub (X, Y : Bignum) return Big_Integer; -- "-"
+ function Big_Mul (X, Y : Bignum) return Big_Integer; -- "*"
+ function Big_Div (X, Y : Bignum) return Big_Integer; -- "/"
+ function Big_Exp (X, Y : Bignum) return Big_Integer; -- "**"
+ function Big_Mod (X, Y : Bignum) return Big_Integer; -- "mod"
+ function Big_Rem (X, Y : Bignum) return Big_Integer; -- "rem"
+ function Big_Neg (X : Bignum) return Big_Integer; -- "-"
+ function Big_Abs (X : Bignum) return Big_Integer; -- "abs"
-- Perform indicated arithmetic operation on bignum values. No exception
-- raised except for Div/Mod/Rem by 0 which raises Constraint_Error with
-- an appropriate message.
+ function Big_And (X, Y : Bignum) return Big_Integer; -- "and"
+ function Big_Or (X, Y : Bignum) return Big_Integer; -- "or"
+ -- Perform indicated bitwise operation on big num values.
+ -- The negative flags of X and Y are also combined.
+
+ function Big_Shift_Left (X : Bignum; Amount : Natural) return Big_Integer;
+ function Big_Shift_Right (X : Bignum; Amount : Natural) return Big_Integer;
+ -- Perform indicated bitwise operation on big num values.
+ -- Constraint_Error is raised if X is negative.
+
function Big_EQ (X, Y : Bignum) return Boolean; -- "="
function Big_NE (X, Y : Bignum) return Boolean; -- "/="
function Big_GE (X, Y : Bignum) return Boolean; -- ">="
@@ -117,18 +97,24 @@ package System.Generic_Bignums is
-- Returns True if the Bignum value is in the range of Long_Long_Integer,
-- so that a call to From_Bignum is guaranteed not to raise an exception.
- function To_Bignum (X : Long_Long_Integer) return Bignum;
- -- Convert Long_Long_Integer to Bignum. No exception can be raised for any
- -- input argument.
+ function To_Bignum (X : Long_Long_Integer) return Big_Integer;
+ -- Convert Long_Long_Integer to a big integer. No exception can be raised
+ -- for any input argument.
- function To_Bignum (X : Interfaces.Unsigned_64) return Bignum;
- -- Convert Unsigned_64 to Bignum. No exception can be raised for any
+ function To_Bignum (X : Interfaces.Unsigned_64) return Big_Integer;
+ -- Convert Unsigned_64 to a big integer. No exception can be raised for any
-- input argument.
function From_Bignum (X : Bignum) return Long_Long_Integer;
-- Convert Bignum to Long_Long_Integer. Constraint_Error raised with
-- appropriate message if value is out of range of Long_Long_Integer.
+ function To_String
+ (X : Bignum; Width : Natural := 0; Base : Positive := 10)
+ return String;
+ -- Return the image of X, based on the given Width and Base, as defined
+ -- in the RM for Ada.Text_IO. Base should really be in the range 2 .. 16.
+
function Is_Zero (X : Bignum) return Boolean;
-- Return True if X = 0
diff --git a/gcc/ada/libgnat/s-geveop.adb b/gcc/ada/libgnat/s-geveop.adb
index 01f7862..8e59b30 100644
--- a/gcc/ada/libgnat/s-geveop.adb
+++ b/gcc/ada/libgnat/s-geveop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-geveop.ads b/gcc/ada/libgnat/s-geveop.ads
index 11952c1..33f4e69 100644
--- a/gcc/ada/libgnat/s-geveop.ads
+++ b/gcc/ada/libgnat/s-geveop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-gloloc.adb b/gcc/ada/libgnat/s-gloloc.adb
index a8efd8e..9c859cf 100644
--- a/gcc/ada/libgnat/s-gloloc.adb
+++ b/gcc/ada/libgnat/s-gloloc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-gloloc.ads b/gcc/ada/libgnat/s-gloloc.ads
index 2af8f54..e95884f 100644
--- a/gcc/ada/libgnat/s-gloloc.ads
+++ b/gcc/ada/libgnat/s-gloloc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-gloloc__mingw.adb b/gcc/ada/libgnat/s-gloloc__mingw.adb
index abb97e7..d8c180e 100644
--- a/gcc/ada/libgnat/s-gloloc__mingw.adb
+++ b/gcc/ada/libgnat/s-gloloc__mingw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-htable.adb b/gcc/ada/libgnat/s-htable.adb
index 4618981..476f4aa 100644
--- a/gcc/ada/libgnat/s-htable.adb
+++ b/gcc/ada/libgnat/s-htable.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-htable.ads b/gcc/ada/libgnat/s-htable.ads
index 87834d5..6313ab3 100644
--- a/gcc/ada/libgnat/s-htable.ads
+++ b/gcc/ada/libgnat/s-htable.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imenne.adb b/gcc/ada/libgnat/s-imenne.adb
index 30df1a4..605b85b 100644
--- a/gcc/ada/libgnat/s-imenne.adb
+++ b/gcc/ada/libgnat/s-imenne.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imenne.ads b/gcc/ada/libgnat/s-imenne.ads
index 0e661bf..e150891 100644
--- a/gcc/ada/libgnat/s-imenne.ads
+++ b/gcc/ada/libgnat/s-imenne.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgbiu.adb b/gcc/ada/libgnat/s-imgbiu.adb
index e1022b9..7b765c0 100644
--- a/gcc/ada/libgnat/s-imgbiu.adb
+++ b/gcc/ada/libgnat/s-imgbiu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgbiu.ads b/gcc/ada/libgnat/s-imgbiu.ads
index c9adaae..524e582 100644
--- a/gcc/ada/libgnat/s-imgbiu.ads
+++ b/gcc/ada/libgnat/s-imgbiu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgboo.adb b/gcc/ada/libgnat/s-imgboo.adb
index e4bd5ca..35ae001 100644
--- a/gcc/ada/libgnat/s-imgboo.adb
+++ b/gcc/ada/libgnat/s-imgboo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgboo.ads b/gcc/ada/libgnat/s-imgboo.ads
index cd422c4..1bf8449 100644
--- a/gcc/ada/libgnat/s-imgboo.ads
+++ b/gcc/ada/libgnat/s-imgboo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgcha.adb b/gcc/ada/libgnat/s-imgcha.adb
index 69883d3..a2d7c46 100644
--- a/gcc/ada/libgnat/s-imgcha.adb
+++ b/gcc/ada/libgnat/s-imgcha.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgcha.ads b/gcc/ada/libgnat/s-imgcha.ads
index ff067d0..5c9ead8 100644
--- a/gcc/ada/libgnat/s-imgcha.ads
+++ b/gcc/ada/libgnat/s-imgcha.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgdec.adb b/gcc/ada/libgnat/s-imgdec.adb
index 20ef3ce..6000d44 100644
--- a/gcc/ada/libgnat/s-imgdec.adb
+++ b/gcc/ada/libgnat/s-imgdec.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgdec.ads b/gcc/ada/libgnat/s-imgdec.ads
index 5d03f22..d45a05f 100644
--- a/gcc/ada/libgnat/s-imgdec.ads
+++ b/gcc/ada/libgnat/s-imgdec.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgenu.adb b/gcc/ada/libgnat/s-imgenu.adb
index 130833a..7eae182 100644
--- a/gcc/ada/libgnat/s-imgenu.adb
+++ b/gcc/ada/libgnat/s-imgenu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgenu.ads b/gcc/ada/libgnat/s-imgenu.ads
index fe5a731..ccb1d07 100644
--- a/gcc/ada/libgnat/s-imgenu.ads
+++ b/gcc/ada/libgnat/s-imgenu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgint.adb b/gcc/ada/libgnat/s-imgint.adb
index dd29205..2b94472 100644
--- a/gcc/ada/libgnat/s-imgint.adb
+++ b/gcc/ada/libgnat/s-imgint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgint.ads b/gcc/ada/libgnat/s-imgint.ads
index df76d0b..6c2c675 100644
--- a/gcc/ada/libgnat/s-imgint.ads
+++ b/gcc/ada/libgnat/s-imgint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgllb.adb b/gcc/ada/libgnat/s-imgllb.adb
index fefa68d..30d6a3c 100644
--- a/gcc/ada/libgnat/s-imgllb.adb
+++ b/gcc/ada/libgnat/s-imgllb.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgllb.ads b/gcc/ada/libgnat/s-imgllb.ads
index dba0f40..0232315 100644
--- a/gcc/ada/libgnat/s-imgllb.ads
+++ b/gcc/ada/libgnat/s-imgllb.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imglld.adb b/gcc/ada/libgnat/s-imglld.adb
index 9f2019b1..c70f409 100644
--- a/gcc/ada/libgnat/s-imglld.adb
+++ b/gcc/ada/libgnat/s-imglld.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imglld.ads b/gcc/ada/libgnat/s-imglld.ads
index 37e9e7d..fdb25b4 100644
--- a/gcc/ada/libgnat/s-imglld.ads
+++ b/gcc/ada/libgnat/s-imglld.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imglli.adb b/gcc/ada/libgnat/s-imglli.adb
index b4e9604..4d024ee 100644
--- a/gcc/ada/libgnat/s-imglli.adb
+++ b/gcc/ada/libgnat/s-imglli.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imglli.ads b/gcc/ada/libgnat/s-imglli.ads
index a4eb6ec..b0d3cae 100644
--- a/gcc/ada/libgnat/s-imglli.ads
+++ b/gcc/ada/libgnat/s-imglli.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgllu.adb b/gcc/ada/libgnat/s-imgllu.adb
index 2220838..f62a25d 100644
--- a/gcc/ada/libgnat/s-imgllu.adb
+++ b/gcc/ada/libgnat/s-imgllu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgllu.ads b/gcc/ada/libgnat/s-imgllu.ads
index 6c0d43e..d54bb33 100644
--- a/gcc/ada/libgnat/s-imgllu.ads
+++ b/gcc/ada/libgnat/s-imgllu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgllw.adb b/gcc/ada/libgnat/s-imgllw.adb
index 385e1f1..cfd4fc2 100644
--- a/gcc/ada/libgnat/s-imgllw.adb
+++ b/gcc/ada/libgnat/s-imgllw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgllw.ads b/gcc/ada/libgnat/s-imgllw.ads
index 5aaac58..e6e5fb0 100644
--- a/gcc/ada/libgnat/s-imgllw.ads
+++ b/gcc/ada/libgnat/s-imgllw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgrea.adb b/gcc/ada/libgnat/s-imgrea.adb
index 467c482..68b1fdc 100644
--- a/gcc/ada/libgnat/s-imgrea.adb
+++ b/gcc/ada/libgnat/s-imgrea.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -151,14 +151,9 @@ package body System.Img_Real is
Scale : Integer;
Expon : Integer;
- Field_Max : constant := 255;
- -- This should be the same value as Ada.[Wide_]Text_IO.Field'Last.
- -- It is not worth dragging in Ada.Text_IO to pick up this value,
- -- since it really should never be necessary to change it.
-
- Digs : String (1 .. 2 * Field_Max + 16);
- -- Array used to hold digits of converted integer value. This is a
- -- large enough buffer to accommodate ludicrous values of Fore and Aft.
+ Digs : String (1 .. Max_Real_Image_Length);
+ -- Array used to hold digits of converted integer value. This is a large
+ -- enough buffer to accommodate ludicrous Fore/Aft/Exp combinations.
Ndigs : Natural;
-- Number of digits stored in Digs (and also subscript of last digit)
@@ -289,6 +284,8 @@ package body System.Img_Real is
-- What we are looking for is a power of ten to divide X by
-- so that the result lies within the required range.
+ pragma Assert (Powten (Maxpow) /= 0.0);
+
loop
XP := X / Powten (Maxpow);
exit when XP < Powten (S) or else Scale > Maxscaling;
@@ -490,6 +487,9 @@ package body System.Img_Real is
-- an infinite value, so we print Inf.
if V > Long_Long_Float'Last then
+ pragma Annotate
+ (CodePeer, Intentional, "test always true", "test for infinity");
+
Set ('+');
Set ('I');
Set ('n');
diff --git a/gcc/ada/libgnat/s-imgrea.ads b/gcc/ada/libgnat/s-imgrea.ads
index c17d35c..9711516 100644
--- a/gcc/ada/libgnat/s-imgrea.ads
+++ b/gcc/ada/libgnat/s-imgrea.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -73,4 +73,9 @@ package System.Img_Real is
-- can be set to any valid values for the case of use from Text_IO. Note
-- that no space is stored at the start for non-negative values.
+ Max_Real_Image_Length : constant := 5200;
+ -- If Exp is set to zero and Aft is set to Text_IO.Field'Last (i.e., 255)
+ -- then Long_Long_Float'Last generates an image whose length is
+ -- slightly less than 5200.
+
end System.Img_Real;
diff --git a/gcc/ada/libgnat/s-imguns.adb b/gcc/ada/libgnat/s-imguns.adb
index 779c41c..914121d 100644
--- a/gcc/ada/libgnat/s-imguns.adb
+++ b/gcc/ada/libgnat/s-imguns.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imguns.ads b/gcc/ada/libgnat/s-imguns.ads
index 84cb609..86e6d99 100644
--- a/gcc/ada/libgnat/s-imguns.ads
+++ b/gcc/ada/libgnat/s-imguns.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgwch.adb b/gcc/ada/libgnat/s-imgwch.adb
index 3892c77..499a513 100644
--- a/gcc/ada/libgnat/s-imgwch.adb
+++ b/gcc/ada/libgnat/s-imgwch.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgwch.ads b/gcc/ada/libgnat/s-imgwch.ads
index 349ff1e..efc1463 100644
--- a/gcc/ada/libgnat/s-imgwch.ads
+++ b/gcc/ada/libgnat/s-imgwch.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgwiu.adb b/gcc/ada/libgnat/s-imgwiu.adb
index 319410c..90a8f41 100644
--- a/gcc/ada/libgnat/s-imgwiu.adb
+++ b/gcc/ada/libgnat/s-imgwiu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgwiu.ads b/gcc/ada/libgnat/s-imgwiu.ads
index ae67de0..6d33599 100644
--- a/gcc/ada/libgnat/s-imgwiu.ads
+++ b/gcc/ada/libgnat/s-imgwiu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-io.adb b/gcc/ada/libgnat/s-io.adb
index 18edf63..23301e9 100644
--- a/gcc/ada/libgnat/s-io.adb
+++ b/gcc/ada/libgnat/s-io.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -65,16 +65,16 @@ package body System.IO is
end Put;
procedure Put (C : Character) is
- procedure Put_Char (C : Character);
+ procedure Put_Char (C : Integer);
pragma Import (C, Put_Char, "put_char");
- procedure Put_Char_Stderr (C : Character);
+ procedure Put_Char_Stderr (C : Integer);
pragma Import (C, Put_Char_Stderr, "put_char_stderr");
begin
case Current_Out is
- when Stdout => Put_Char (C);
- when Stderr => Put_Char_Stderr (C);
+ when Stdout => Put_Char (Character'Pos (C));
+ when Stderr => Put_Char_Stderr (Character'Pos (C));
end case;
end Put;
diff --git a/gcc/ada/libgnat/s-io.ads b/gcc/ada/libgnat/s-io.ads
index 4e515e5..6b733b6 100644
--- a/gcc/ada/libgnat/s-io.ads
+++ b/gcc/ada/libgnat/s-io.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-llflex.ads b/gcc/ada/libgnat/s-llflex.ads
index 70cd9ce..bbc79a8 100644
--- a/gcc/ada/libgnat/s-llflex.ads
+++ b/gcc/ada/libgnat/s-llflex.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-maccod.ads b/gcc/ada/libgnat/s-maccod.ads
index 9f0dc46..d2465f6 100644
--- a/gcc/ada/libgnat/s-maccod.ads
+++ b/gcc/ada/libgnat/s-maccod.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-mantis.adb b/gcc/ada/libgnat/s-mantis.adb
index da4e6ba8..48eb280 100644
--- a/gcc/ada/libgnat/s-mantis.adb
+++ b/gcc/ada/libgnat/s-mantis.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-mantis.ads b/gcc/ada/libgnat/s-mantis.ads
index 4204732..7ad511e 100644
--- a/gcc/ada/libgnat/s-mantis.ads
+++ b/gcc/ada/libgnat/s-mantis.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-mastop.adb b/gcc/ada/libgnat/s-mastop.adb
index 7848fff..cf87731 100644
--- a/gcc/ada/libgnat/s-mastop.adb
+++ b/gcc/ada/libgnat/s-mastop.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- (Dummy version) --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-mastop.ads b/gcc/ada/libgnat/s-mastop.ads
index 10e5616..c2c23d3 100644
--- a/gcc/ada/libgnat/s-mastop.ads
+++ b/gcc/ada/libgnat/s-mastop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-memcop.ads b/gcc/ada/libgnat/s-memcop.ads
index 7c6045e..db33a57 100644
--- a/gcc/ada/libgnat/s-memcop.ads
+++ b/gcc/ada/libgnat/s-memcop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/s-memory.adb b/gcc/ada/libgnat/s-memory.adb
index ebc168e..f6ecf47 100644
--- a/gcc/ada/libgnat/s-memory.adb
+++ b/gcc/ada/libgnat/s-memory.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-memory.ads b/gcc/ada/libgnat/s-memory.ads
index 68b49aa..57e8b24 100644
--- a/gcc/ada/libgnat/s-memory.ads
+++ b/gcc/ada/libgnat/s-memory.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-mmap.adb b/gcc/ada/libgnat/s-mmap.adb
index 079f021..0e1f4f7 100644
--- a/gcc/ada/libgnat/s-mmap.adb
+++ b/gcc/ada/libgnat/s-mmap.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
diff --git a/gcc/ada/libgnat/s-mmap.ads b/gcc/ada/libgnat/s-mmap.ads
index 7f68cb5..305d1f8 100644
--- a/gcc/ada/libgnat/s-mmap.ads
+++ b/gcc/ada/libgnat/s-mmap.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
@@ -223,13 +223,11 @@ package System.Mmap is
-- (File); such accesses may cause Storage_Error to be raised.
function Data (Region : Mapped_Region) return Str_Access;
- pragma Inline (Data);
-- The data mapped in Region as requested. The result is an unconstrained
-- string, so you cannot use the usual 'First and 'Last attributes.
-- Instead, these are respectively 1 and Size.
function Data (File : Mapped_File) return Str_Access;
- pragma Inline (Data);
-- Likewise for the region contained in File
function Is_Mutable (Region : Mapped_Region) return Boolean;
diff --git a/gcc/ada/libgnat/s-mmauni__long.ads b/gcc/ada/libgnat/s-mmauni__long.ads
index d12b154..4fbd00a 100644
--- a/gcc/ada/libgnat/s-mmauni__long.ads
+++ b/gcc/ada/libgnat/s-mmauni__long.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
diff --git a/gcc/ada/libgnat/s-mmosin__mingw.adb b/gcc/ada/libgnat/s-mmosin__mingw.adb
index ea993d7..631e0dd 100644
--- a/gcc/ada/libgnat/s-mmosin__mingw.adb
+++ b/gcc/ada/libgnat/s-mmosin__mingw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
diff --git a/gcc/ada/libgnat/s-mmosin__mingw.ads b/gcc/ada/libgnat/s-mmosin__mingw.ads
index 390709f..8c3a472 100644
--- a/gcc/ada/libgnat/s-mmosin__mingw.ads
+++ b/gcc/ada/libgnat/s-mmosin__mingw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
diff --git a/gcc/ada/libgnat/s-mmosin__unix.adb b/gcc/ada/libgnat/s-mmosin__unix.adb
index bb68849..e0b369f 100644
--- a/gcc/ada/libgnat/s-mmosin__unix.adb
+++ b/gcc/ada/libgnat/s-mmosin__unix.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
diff --git a/gcc/ada/libgnat/s-mmosin__unix.ads b/gcc/ada/libgnat/s-mmosin__unix.ads
index b0832f0..234ce42 100644
--- a/gcc/ada/libgnat/s-mmosin__unix.ads
+++ b/gcc/ada/libgnat/s-mmosin__unix.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, AdaCore --
+-- Copyright (C) 2007-2020, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
diff --git a/gcc/ada/libgnat/s-multip.adb b/gcc/ada/libgnat/s-multip.adb
index 62dc988..e17872c 100644
--- a/gcc/ada/libgnat/s-multip.adb
+++ b/gcc/ada/libgnat/s-multip.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-objrea.adb b/gcc/ada/libgnat/s-objrea.adb
index 89b58a6..d64e285 100644
--- a/gcc/ada/libgnat/s-objrea.adb
+++ b/gcc/ada/libgnat/s-objrea.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-objrea.ads b/gcc/ada/libgnat/s-objrea.ads
index 372ad96..bd4fbd5 100644
--- a/gcc/ada/libgnat/s-objrea.ads
+++ b/gcc/ada/libgnat/s-objrea.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-optide.adb b/gcc/ada/libgnat/s-optide.adb
index f0d46f8..c979797 100644
--- a/gcc/ada/libgnat/s-optide.adb
+++ b/gcc/ada/libgnat/s-optide.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2012-2019, AdaCore --
+-- Copyright (C) 2012-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-os_lib.adb b/gcc/ada/libgnat/s-os_lib.adb
index 258cd64..288325c 100644
--- a/gcc/ada/libgnat/s-os_lib.adb
+++ b/gcc/ada/libgnat/s-os_lib.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, AdaCore --
+-- Copyright (C) 1995-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -63,6 +63,11 @@ package body System.OS_Lib is
-- Mode = 1 - copy time stamps and read/write/execute attributes
-- Mode = 2 - copy read/write/execute attributes
+ function Is_Dirsep (C : Character) return Boolean;
+ pragma Inline (Is_Dirsep);
+ -- Returns True if C is a directory separator. On Windows we
+ -- accept both \ and / as a directory separator.
+
On_Windows : constant Boolean := Directory_Separator = '\';
-- An indication that we are on Windows. Used in Normalize_Pathname, to
-- deal with drive letters in the beginning of absolute paths.
@@ -336,22 +341,6 @@ package body System.OS_Lib is
----------------
function Build_Path (Dir : String; File : String) return String is
- function Is_Dirsep (C : Character) return Boolean;
- pragma Inline (Is_Dirsep);
- -- Returns True if C is a directory separator. On Windows we
- -- handle both styles of directory separator.
-
- ---------------
- -- Is_Dirsep --
- ---------------
-
- function Is_Dirsep (C : Character) return Boolean is
- begin
- return C = Directory_Separator or else C = '/';
- end Is_Dirsep;
-
- -- Local variables
-
Base_File_Ptr : Integer;
-- The base file name is File (Base_File_Ptr + 1 .. File'Last)
@@ -574,14 +563,15 @@ package body System.OS_Lib is
-- touch destination file at all.
From := Open_Read (Name, Binary);
- if From /= Invalid_FD then
+
+ if From = Invalid_FD then
+ Success := False;
+ else
To := Open_Read_Write (Pathname, Binary);
+ Lseek (To, 0, Seek_End);
+ Copy (From, To);
end if;
- Lseek (To, 0, Seek_End);
-
- Copy (From, To);
-
-- Appending to directory, not allowed
elsif Is_Directory (Pathname) then
@@ -1471,6 +1461,15 @@ package body System.OS_Lib is
return Is_Absolute_Path (Name'Address, Name'Length) /= 0;
end Is_Absolute_Path;
+ ---------------
+ -- Is_Dirsep --
+ ---------------
+
+ function Is_Dirsep (C : Character) return Boolean is
+ begin
+ return C = Directory_Separator or else C = '/';
+ end Is_Dirsep;
+
------------------
-- Is_Directory --
------------------
@@ -1999,6 +1998,8 @@ package body System.OS_Lib is
-- If the string ends with \, double it
+ pragma Annotate (CodePeer, Modified, Res (J - 1));
+
if Res (J - 1) = '\' then
Res (J) := '\';
J := J + 1;
@@ -2082,17 +2083,61 @@ package body System.OS_Lib is
Fold_To_Lower_Case : constant Boolean :=
not Case_Sensitive
- and then Get_File_Names_Case_Sensitive = 0;
+ and then Get_File_Names_Case_Sensitive = 0;
+
+ Cur_Dir_Len : Natural := 0;
+ End_Path : Natural := Name'Length;
+ Last : Positive := 1;
+ Path_Buffer : String (1 .. End_Path + 2 * Max_Path + 4);
+ -- We need to potentially store in this buffer the following elements:
+ -- the path itself, the current directory if the path is relative,
+ -- and additional fragments up to Max_Path in length in case
+ -- there are any symlinks.
function Final_Value (S : String) return String;
-- Make final adjustment to the returned string. This function strips
-- trailing directory separators, and folds returned string to lower
-- case if required.
- function Get_Directory (Dir : String) return String;
- -- If Dir is not empty, return it, adding a directory separator
- -- if not already present, otherwise return current working directory
- -- with terminating directory separator.
+ procedure Fill_Directory (Drive_Only : Boolean := False);
+ -- Fill Cur_Dir and Cur_Dir_Len with Directory and ending directory
+ -- separator or with current directory if Directory is not defined.
+ -- If Drive_Only is True takes only Drive letter with colon and
+ -- directory separator from Directory parameter or from current
+ -- directory if Directory parameter is empty.
+
+ function Is_With_Drive (Name : String) return Boolean;
+ pragma Inline (Is_With_Drive);
+ -- Returns True only if the Name is including a drive
+ -- letter at start.
+
+ function Missed_Drive_Letter (Name : String) return Boolean;
+ -- Missed drive letter at start of the normalized pathname
+
+ -------------------
+ -- Is_With_Drive --
+ -------------------
+
+ function Is_With_Drive (Name : String) return Boolean is
+ begin
+ return Name'Length > 1
+ and then Name (Name'First + 1) = ':'
+ and then (Name (Name'First) in 'a' .. 'z'
+ or else Name (Name'First) in 'A' .. 'Z');
+ end Is_With_Drive;
+
+ -------------------------
+ -- Missed_Drive_Letter --
+ -------------------------
+
+ function Missed_Drive_Letter (Name : String) return Boolean is
+ begin
+ return On_Windows
+ and then not Is_With_Drive (Name)
+ and then (Name'Length < 2 -- not \\name case
+ or else Name (Name'First .. Name'First + 1)
+ /= Directory_Separator & Directory_Separator);
+ end Missed_Drive_Letter;
-----------------
-- Final_Value --
@@ -2113,22 +2158,14 @@ package body System.OS_Lib is
Last := S1'Last;
- if Last > 1
- and then (S1 (Last) = '/'
- or else
- S1 (Last) = Directory_Separator)
- then
- -- Special case for Windows: C:\
-
- if Last = 3
+ if Last > 1 and then Is_Dirsep (S1 (Last))
+ and then not
+ (On_Windows -- Special case for Windows: C:\
+ and then Last = 3
and then S1 (1) /= Directory_Separator
- and then S1 (2) = ':'
- then
- null;
-
- else
- Last := Last - 1;
- end if;
+ and then S1 (2) = ':')
+ then
+ Last := Last - 1;
end if;
-- And ensure that there is a trailing directory separator if the
@@ -2145,90 +2182,80 @@ package body System.OS_Lib is
end if;
end Final_Value;
- -------------------
- -- Get_Directory --
- -------------------
+ --------------------
+ -- Fill_Directory --
+ --------------------
- function Get_Directory (Dir : String) return String is
+ procedure Fill_Directory (Drive_Only : Boolean := False) is
begin
- -- Directory given, add directory separator if needed
+ if Drive_Only and then Is_With_Drive (Directory) then
+ Path_Buffer (1 .. 3) :=
+ Directory (Directory'First .. Directory'First + 2);
- if Dir'Length > 0 then
- declare
- Result : String :=
- Normalize_Pathname
- (Dir, "", Resolve_Links, Case_Sensitive)
- & Directory_Separator;
- Last : Positive := Result'Last - 1;
+ elsif Directory = ""
+ or else not Is_Absolute_Path (Directory)
+ or else Missed_Drive_Letter (Directory)
+ then
+ -- Directory name not given or it is not absolute or without drive
+ -- letter on Windows, get current directory.
- begin
- -- On Windows, change all '/' to '\'
-
- if On_Windows then
- for J in Result'First .. Last - 1 loop
- if Result (J) = '/' then
- Result (J) := Directory_Separator;
- end if;
- end loop;
- end if;
+ Cur_Dir_Len := Max_Path;
- -- Include additional directory separator, if needed
+ Get_Current_Dir (Path_Buffer'Address, Cur_Dir_Len'Address);
- if Result (Last) /= Directory_Separator then
- Last := Last + 1;
- end if;
+ if Cur_Dir_Len = 0 then
+ raise Program_Error;
+ end if;
- return Result (Result'First .. Last);
- end;
+ if not Resolve_Links then
+ Last := Cur_Dir_Len;
+ end if;
- -- Directory name not given, get current directory
+ if not Drive_Only and then Directory /= "" then
+ if On_Windows and then Is_Absolute_Path (Directory) then
+ -- Drive letter taken from current directory but directory
+ -- itself taken from Directory parameter.
- else
- declare
- Buffer : String (1 .. Max_Path + 2);
- Path_Len : Natural := Max_Path;
+ Path_Buffer (3 .. Directory'Length + 2) := Directory;
+ Cur_Dir_Len := Directory'Length + 2;
+ Last := 3;
- begin
- Get_Current_Dir (Buffer'Address, Path_Len'Address);
+ else
+ -- Append relative Directory to current directory
- if Path_Len = 0 then
- raise Program_Error;
+ Path_Buffer
+ (Cur_Dir_Len + 1 .. Cur_Dir_Len + Directory'Length) :=
+ Directory;
+ Cur_Dir_Len := Cur_Dir_Len + Directory'Length;
end if;
+ end if;
- if Buffer (Path_Len) /= Directory_Separator then
- Path_Len := Path_Len + 1;
- Buffer (Path_Len) := Directory_Separator;
- end if;
+ elsif Directory'Length >= Path_Buffer'Length then
+ raise Constraint_Error with "Directory name to big";
- -- By default, the drive letter on Windows is in upper case
+ else
+ Path_Buffer (1 .. Directory'Length) := Directory;
+ Cur_Dir_Len := Directory'Length;
+ end if;
- if On_Windows
- and then Path_Len >= 2
- and then Buffer (2) = ':'
- then
- System.Case_Util.To_Upper (Buffer (1 .. 1));
- end if;
+ if Drive_Only then
+ -- When we need only drive letter from current directory on
+ -- Windows
- return Buffer (1 .. Path_Len);
- end;
+ Cur_Dir_Len := 3;
+ Last := Cur_Dir_Len;
+
+ elsif not Is_Dirsep (Path_Buffer (Cur_Dir_Len)) then
+ Cur_Dir_Len := Cur_Dir_Len + 1;
+ Path_Buffer (Cur_Dir_Len) := Directory_Separator;
end if;
- end Get_Directory;
+ end Fill_Directory;
-- Local variables
Max_Iterations : constant := 500;
- Cur_Dir : constant String := Get_Directory (Directory);
- Cur_Dir_Len : constant Natural := Cur_Dir'Length;
-
- End_Path : Natural := Name'Length;
- Last : Positive := 1;
Link_Buffer : String (1 .. Max_Path + 2);
- Path_Buffer : String (1 .. End_Path + Cur_Dir_Len + Max_Path + 2);
- -- We need to potentially store in this buffer the following elements:
- -- the path itself, the current directory if the path is relative,
- -- and additional fragments up to Max_Path in length in case
- -- there are any symlinks.
Finish : Positive;
Start : Positive;
@@ -2244,14 +2271,23 @@ package body System.OS_Lib is
end if;
if Is_Absolute_Path (Name) then
- Path_Buffer (1 .. End_Path) := Name;
+ if Missed_Drive_Letter (Name) then
+ Fill_Directory (Drive_Only => True);
+
+ -- Take only drive letter part with colon
+
+ End_Path := End_Path + 2;
+ Path_Buffer (3 .. End_Path) := Name;
+
+ else
+ Path_Buffer (1 .. End_Path) := Name;
+ end if;
else
-- If this is a relative pathname, prepend current directory
- Path_Buffer (1 .. Cur_Dir_Len) := Cur_Dir;
+ Fill_Directory;
Path_Buffer (Cur_Dir_Len + 1 .. Cur_Dir_Len + End_Path) := Name;
End_Path := Cur_Dir_Len + End_Path;
- Last := Cur_Dir_Len;
end if;
-- Special handling for Windows:
@@ -2268,30 +2304,11 @@ package body System.OS_Lib is
end if;
end loop;
- -- If we have an absolute path starting with a directory
- -- separator (but not a UNC path), we need to have the drive letter
- -- in front of the path. Get_Current_Dir returns a path starting
- -- with a drive letter. So we take this drive letter and prepend it
- -- to the current path.
+ -- Ensure drive letter is upper-case
- if Path_Buffer (1) = Directory_Separator
- and then Path_Buffer (2) /= Directory_Separator
- then
- if Cur_Dir'Length > 2
- and then Cur_Dir (Cur_Dir'First + 1) = ':'
- then
- Path_Buffer (3 .. End_Path + 2) :=
- Path_Buffer (1 .. End_Path);
- Path_Buffer (1 .. 2) :=
- Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1);
- End_Path := End_Path + 2;
- end if;
+ pragma Assert (Path_Buffer (2) = ':');
- -- We have a drive letter already, ensure it is upper-case
-
- elsif Path_Buffer (1) in 'a' .. 'z'
- and then Path_Buffer (2) = ':'
- then
+ if Path_Buffer (1) in 'a' .. 'z' then
System.Case_Util.To_Upper (Path_Buffer (1 .. 1));
end if;
diff --git a/gcc/ada/libgnat/s-os_lib.ads b/gcc/ada/libgnat/s-os_lib.ads
index 99406e9..f786cca 100644
--- a/gcc/ada/libgnat/s-os_lib.ads
+++ b/gcc/ada/libgnat/s-os_lib.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-osprim.ads b/gcc/ada/libgnat/s-osprim.ads
index 101a573..fce4203 100644
--- a/gcc/ada/libgnat/s-osprim.ads
+++ b/gcc/ada/libgnat/s-osprim.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-osprim__darwin.adb b/gcc/ada/libgnat/s-osprim__darwin.adb
index dbd4fc7..8e85871 100644
--- a/gcc/ada/libgnat/s-osprim__darwin.adb
+++ b/gcc/ada/libgnat/s-osprim__darwin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-osprim__lynxos.ads b/gcc/ada/libgnat/s-osprim__lynxos.ads
index 7a717c1..e181f7e 100644
--- a/gcc/ada/libgnat/s-osprim__lynxos.ads
+++ b/gcc/ada/libgnat/s-osprim__lynxos.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-osprim__mingw.adb b/gcc/ada/libgnat/s-osprim__mingw.adb
index 5c5c796..8e0c425 100644
--- a/gcc/ada/libgnat/s-osprim__mingw.adb
+++ b/gcc/ada/libgnat/s-osprim__mingw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-osprim__posix.adb b/gcc/ada/libgnat/s-osprim__posix.adb
index 55008de..4413616 100644
--- a/gcc/ada/libgnat/s-osprim__posix.adb
+++ b/gcc/ada/libgnat/s-osprim__posix.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-osprim__posix2008.adb b/gcc/ada/libgnat/s-osprim__posix2008.adb
index 650bb2e..87bbdc1 100644
--- a/gcc/ada/libgnat/s-osprim__posix2008.adb
+++ b/gcc/ada/libgnat/s-osprim__posix2008.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-osprim__rtems.adb b/gcc/ada/libgnat/s-osprim__rtems.adb
index 7efede8..5cdc03d 100644
--- a/gcc/ada/libgnat/s-osprim__rtems.adb
+++ b/gcc/ada/libgnat/s-osprim__rtems.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-osprim__solaris.adb b/gcc/ada/libgnat/s-osprim__solaris.adb
index 9cc7bc1..7165bc4 100644
--- a/gcc/ada/libgnat/s-osprim__solaris.adb
+++ b/gcc/ada/libgnat/s-osprim__solaris.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-osprim__unix.adb b/gcc/ada/libgnat/s-osprim__unix.adb
index 5a82d97..9a936c6 100644
--- a/gcc/ada/libgnat/s-osprim__unix.adb
+++ b/gcc/ada/libgnat/s-osprim__unix.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-osprim__vxworks.adb b/gcc/ada/libgnat/s-osprim__vxworks.adb
index 6f19644..40e7d49 100644
--- a/gcc/ada/libgnat/s-osprim__vxworks.adb
+++ b/gcc/ada/libgnat/s-osprim__vxworks.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-osprim__x32.adb b/gcc/ada/libgnat/s-osprim__x32.adb
index be86469..4a11379 100644
--- a/gcc/ada/libgnat/s-osprim__x32.adb
+++ b/gcc/ada/libgnat/s-osprim__x32.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2013-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-osvers__vxworks-653.ads b/gcc/ada/libgnat/s-osvers__vxworks-653.ads
index bbf9ca5..48b1c2a 100644
--- a/gcc/ada/libgnat/s-osvers__vxworks-653.ads
+++ b/gcc/ada/libgnat/s-osvers__vxworks-653.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2010-2019, AdaCore --
+-- Copyright (C) 2010-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack03.adb b/gcc/ada/libgnat/s-pack03.adb
index 0d60c6c..32e7c0c 100644
--- a/gcc/ada/libgnat/s-pack03.adb
+++ b/gcc/ada/libgnat/s-pack03.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack03.ads b/gcc/ada/libgnat/s-pack03.ads
index 89bc82f..47d71f0 100644
--- a/gcc/ada/libgnat/s-pack03.ads
+++ b/gcc/ada/libgnat/s-pack03.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack05.adb b/gcc/ada/libgnat/s-pack05.adb
index 96add00..78a7005 100644
--- a/gcc/ada/libgnat/s-pack05.adb
+++ b/gcc/ada/libgnat/s-pack05.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack05.ads b/gcc/ada/libgnat/s-pack05.ads
index 529a8e3..cdcacc7 100644
--- a/gcc/ada/libgnat/s-pack05.ads
+++ b/gcc/ada/libgnat/s-pack05.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack06.adb b/gcc/ada/libgnat/s-pack06.adb
index 756f806..623b955 100644
--- a/gcc/ada/libgnat/s-pack06.adb
+++ b/gcc/ada/libgnat/s-pack06.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack06.ads b/gcc/ada/libgnat/s-pack06.ads
index 004139d..0c918a0 100644
--- a/gcc/ada/libgnat/s-pack06.ads
+++ b/gcc/ada/libgnat/s-pack06.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack07.adb b/gcc/ada/libgnat/s-pack07.adb
index 73dfab8..f0a3177 100644
--- a/gcc/ada/libgnat/s-pack07.adb
+++ b/gcc/ada/libgnat/s-pack07.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack07.ads b/gcc/ada/libgnat/s-pack07.ads
index d306f67..4fa1385 100644
--- a/gcc/ada/libgnat/s-pack07.ads
+++ b/gcc/ada/libgnat/s-pack07.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack09.adb b/gcc/ada/libgnat/s-pack09.adb
index e879064..8517f4d 100644
--- a/gcc/ada/libgnat/s-pack09.adb
+++ b/gcc/ada/libgnat/s-pack09.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack09.ads b/gcc/ada/libgnat/s-pack09.ads
index f7becca..cdf62e3 100644
--- a/gcc/ada/libgnat/s-pack09.ads
+++ b/gcc/ada/libgnat/s-pack09.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack10.adb b/gcc/ada/libgnat/s-pack10.adb
index 4289067..d08751d 100644
--- a/gcc/ada/libgnat/s-pack10.adb
+++ b/gcc/ada/libgnat/s-pack10.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack10.ads b/gcc/ada/libgnat/s-pack10.ads
index 2efffdb..33ed2dd1 100644
--- a/gcc/ada/libgnat/s-pack10.ads
+++ b/gcc/ada/libgnat/s-pack10.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack11.adb b/gcc/ada/libgnat/s-pack11.adb
index 05b2e71..ca2b3ad 100644
--- a/gcc/ada/libgnat/s-pack11.adb
+++ b/gcc/ada/libgnat/s-pack11.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack11.ads b/gcc/ada/libgnat/s-pack11.ads
index ef89843..e565d80 100644
--- a/gcc/ada/libgnat/s-pack11.ads
+++ b/gcc/ada/libgnat/s-pack11.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack12.adb b/gcc/ada/libgnat/s-pack12.adb
index 2cfc9d4..d53e9a3 100644
--- a/gcc/ada/libgnat/s-pack12.adb
+++ b/gcc/ada/libgnat/s-pack12.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack12.ads b/gcc/ada/libgnat/s-pack12.ads
index 4b8f29c..84323be 100644
--- a/gcc/ada/libgnat/s-pack12.ads
+++ b/gcc/ada/libgnat/s-pack12.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack13.adb b/gcc/ada/libgnat/s-pack13.adb
index 0fa4d89..9d9ee0e 100644
--- a/gcc/ada/libgnat/s-pack13.adb
+++ b/gcc/ada/libgnat/s-pack13.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack13.ads b/gcc/ada/libgnat/s-pack13.ads
index cc6a13d..bb56cfc 100644
--- a/gcc/ada/libgnat/s-pack13.ads
+++ b/gcc/ada/libgnat/s-pack13.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack14.adb b/gcc/ada/libgnat/s-pack14.adb
index 968e064..cceb09e 100644
--- a/gcc/ada/libgnat/s-pack14.adb
+++ b/gcc/ada/libgnat/s-pack14.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack14.ads b/gcc/ada/libgnat/s-pack14.ads
index 65fa118..3c1c8e2 100644
--- a/gcc/ada/libgnat/s-pack14.ads
+++ b/gcc/ada/libgnat/s-pack14.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack15.adb b/gcc/ada/libgnat/s-pack15.adb
index 83ed344..0e91afc 100644
--- a/gcc/ada/libgnat/s-pack15.adb
+++ b/gcc/ada/libgnat/s-pack15.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack15.ads b/gcc/ada/libgnat/s-pack15.ads
index cd5c2c1..fb73d29 100644
--- a/gcc/ada/libgnat/s-pack15.ads
+++ b/gcc/ada/libgnat/s-pack15.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack17.adb b/gcc/ada/libgnat/s-pack17.adb
index 577a8db..7ba49ca 100644
--- a/gcc/ada/libgnat/s-pack17.adb
+++ b/gcc/ada/libgnat/s-pack17.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack17.ads b/gcc/ada/libgnat/s-pack17.ads
index ff60347..f47c7bd 100644
--- a/gcc/ada/libgnat/s-pack17.ads
+++ b/gcc/ada/libgnat/s-pack17.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack18.adb b/gcc/ada/libgnat/s-pack18.adb
index 2125762..e4b7d9f 100644
--- a/gcc/ada/libgnat/s-pack18.adb
+++ b/gcc/ada/libgnat/s-pack18.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack18.ads b/gcc/ada/libgnat/s-pack18.ads
index 63f38cb..2e196bf 100644
--- a/gcc/ada/libgnat/s-pack18.ads
+++ b/gcc/ada/libgnat/s-pack18.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack19.adb b/gcc/ada/libgnat/s-pack19.adb
index 0151348..50336a9 100644
--- a/gcc/ada/libgnat/s-pack19.adb
+++ b/gcc/ada/libgnat/s-pack19.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack19.ads b/gcc/ada/libgnat/s-pack19.ads
index 56170d0..58d7837 100644
--- a/gcc/ada/libgnat/s-pack19.ads
+++ b/gcc/ada/libgnat/s-pack19.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack20.adb b/gcc/ada/libgnat/s-pack20.adb
index 573490a..a2a2fda 100644
--- a/gcc/ada/libgnat/s-pack20.adb
+++ b/gcc/ada/libgnat/s-pack20.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack20.ads b/gcc/ada/libgnat/s-pack20.ads
index ad5da50..10d75e8 100644
--- a/gcc/ada/libgnat/s-pack20.ads
+++ b/gcc/ada/libgnat/s-pack20.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack21.adb b/gcc/ada/libgnat/s-pack21.adb
index 592c870..a7011ee 100644
--- a/gcc/ada/libgnat/s-pack21.adb
+++ b/gcc/ada/libgnat/s-pack21.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack21.ads b/gcc/ada/libgnat/s-pack21.ads
index a3bad14..eee9f6d 100644
--- a/gcc/ada/libgnat/s-pack21.ads
+++ b/gcc/ada/libgnat/s-pack21.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack22.adb b/gcc/ada/libgnat/s-pack22.adb
index 980bac4..d41ed28 100644
--- a/gcc/ada/libgnat/s-pack22.adb
+++ b/gcc/ada/libgnat/s-pack22.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack22.ads b/gcc/ada/libgnat/s-pack22.ads
index 64651b0..79b92d4 100644
--- a/gcc/ada/libgnat/s-pack22.ads
+++ b/gcc/ada/libgnat/s-pack22.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack23.adb b/gcc/ada/libgnat/s-pack23.adb
index 4181c7f..b15950d 100644
--- a/gcc/ada/libgnat/s-pack23.adb
+++ b/gcc/ada/libgnat/s-pack23.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack23.ads b/gcc/ada/libgnat/s-pack23.ads
index 33fe99f..ec08bd9 100644
--- a/gcc/ada/libgnat/s-pack23.ads
+++ b/gcc/ada/libgnat/s-pack23.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack24.adb b/gcc/ada/libgnat/s-pack24.adb
index 40db7ac..c2a320d 100644
--- a/gcc/ada/libgnat/s-pack24.adb
+++ b/gcc/ada/libgnat/s-pack24.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack24.ads b/gcc/ada/libgnat/s-pack24.ads
index 24fe7a8..c26a0e6 100644
--- a/gcc/ada/libgnat/s-pack24.ads
+++ b/gcc/ada/libgnat/s-pack24.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack25.adb b/gcc/ada/libgnat/s-pack25.adb
index ad5aa8a..99f1bb1 100644
--- a/gcc/ada/libgnat/s-pack25.adb
+++ b/gcc/ada/libgnat/s-pack25.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack25.ads b/gcc/ada/libgnat/s-pack25.ads
index 3111a03..2b6c7e2 100644
--- a/gcc/ada/libgnat/s-pack25.ads
+++ b/gcc/ada/libgnat/s-pack25.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack26.adb b/gcc/ada/libgnat/s-pack26.adb
index cc6ab4b..6c80c55 100644
--- a/gcc/ada/libgnat/s-pack26.adb
+++ b/gcc/ada/libgnat/s-pack26.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack26.ads b/gcc/ada/libgnat/s-pack26.ads
index 69374d7..150e331 100644
--- a/gcc/ada/libgnat/s-pack26.ads
+++ b/gcc/ada/libgnat/s-pack26.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack27.adb b/gcc/ada/libgnat/s-pack27.adb
index 0a99810..f3c51b0 100644
--- a/gcc/ada/libgnat/s-pack27.adb
+++ b/gcc/ada/libgnat/s-pack27.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack27.ads b/gcc/ada/libgnat/s-pack27.ads
index c7283a8..8ce481b 100644
--- a/gcc/ada/libgnat/s-pack27.ads
+++ b/gcc/ada/libgnat/s-pack27.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack28.adb b/gcc/ada/libgnat/s-pack28.adb
index 4805e0a..7a11643 100644
--- a/gcc/ada/libgnat/s-pack28.adb
+++ b/gcc/ada/libgnat/s-pack28.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack28.ads b/gcc/ada/libgnat/s-pack28.ads
index b7851c1..763b1d0 100644
--- a/gcc/ada/libgnat/s-pack28.ads
+++ b/gcc/ada/libgnat/s-pack28.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack29.adb b/gcc/ada/libgnat/s-pack29.adb
index b30703b..e4209a2 100644
--- a/gcc/ada/libgnat/s-pack29.adb
+++ b/gcc/ada/libgnat/s-pack29.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack29.ads b/gcc/ada/libgnat/s-pack29.ads
index 43094fc..f977d80 100644
--- a/gcc/ada/libgnat/s-pack29.ads
+++ b/gcc/ada/libgnat/s-pack29.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack30.adb b/gcc/ada/libgnat/s-pack30.adb
index fb799f0..577012f 100644
--- a/gcc/ada/libgnat/s-pack30.adb
+++ b/gcc/ada/libgnat/s-pack30.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack30.ads b/gcc/ada/libgnat/s-pack30.ads
index def31e4..fc5965b 100644
--- a/gcc/ada/libgnat/s-pack30.ads
+++ b/gcc/ada/libgnat/s-pack30.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack31.adb b/gcc/ada/libgnat/s-pack31.adb
index 1035042..debf3db 100644
--- a/gcc/ada/libgnat/s-pack31.adb
+++ b/gcc/ada/libgnat/s-pack31.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack31.ads b/gcc/ada/libgnat/s-pack31.ads
index 91dfaad..22db441 100644
--- a/gcc/ada/libgnat/s-pack31.ads
+++ b/gcc/ada/libgnat/s-pack31.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack33.adb b/gcc/ada/libgnat/s-pack33.adb
index cde21bd..f2afef0 100644
--- a/gcc/ada/libgnat/s-pack33.adb
+++ b/gcc/ada/libgnat/s-pack33.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack33.ads b/gcc/ada/libgnat/s-pack33.ads
index ca12603..5d8cb4d 100644
--- a/gcc/ada/libgnat/s-pack33.ads
+++ b/gcc/ada/libgnat/s-pack33.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack34.adb b/gcc/ada/libgnat/s-pack34.adb
index ac12ed3..2f9580a 100644
--- a/gcc/ada/libgnat/s-pack34.adb
+++ b/gcc/ada/libgnat/s-pack34.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack34.ads b/gcc/ada/libgnat/s-pack34.ads
index 489995a..cd5d7fa 100644
--- a/gcc/ada/libgnat/s-pack34.ads
+++ b/gcc/ada/libgnat/s-pack34.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack35.adb b/gcc/ada/libgnat/s-pack35.adb
index 2e9a79e..49cad6f 100644
--- a/gcc/ada/libgnat/s-pack35.adb
+++ b/gcc/ada/libgnat/s-pack35.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack35.ads b/gcc/ada/libgnat/s-pack35.ads
index a0dd33e..21ca7d4 100644
--- a/gcc/ada/libgnat/s-pack35.ads
+++ b/gcc/ada/libgnat/s-pack35.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack36.adb b/gcc/ada/libgnat/s-pack36.adb
index 8585edc..bdb3fe3 100644
--- a/gcc/ada/libgnat/s-pack36.adb
+++ b/gcc/ada/libgnat/s-pack36.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack36.ads b/gcc/ada/libgnat/s-pack36.ads
index 6b93b89..924268f 100644
--- a/gcc/ada/libgnat/s-pack36.ads
+++ b/gcc/ada/libgnat/s-pack36.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack37.adb b/gcc/ada/libgnat/s-pack37.adb
index dcad1ef..7f1ead5 100644
--- a/gcc/ada/libgnat/s-pack37.adb
+++ b/gcc/ada/libgnat/s-pack37.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack37.ads b/gcc/ada/libgnat/s-pack37.ads
index 12246af..089434f 100644
--- a/gcc/ada/libgnat/s-pack37.ads
+++ b/gcc/ada/libgnat/s-pack37.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack38.adb b/gcc/ada/libgnat/s-pack38.adb
index caee10b..f3feac3 100644
--- a/gcc/ada/libgnat/s-pack38.adb
+++ b/gcc/ada/libgnat/s-pack38.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack38.ads b/gcc/ada/libgnat/s-pack38.ads
index 0d26b9d..bb1c504 100644
--- a/gcc/ada/libgnat/s-pack38.ads
+++ b/gcc/ada/libgnat/s-pack38.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack39.adb b/gcc/ada/libgnat/s-pack39.adb
index b41caf6..821d954 100644
--- a/gcc/ada/libgnat/s-pack39.adb
+++ b/gcc/ada/libgnat/s-pack39.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack39.ads b/gcc/ada/libgnat/s-pack39.ads
index 5ef7f3f8..bac16de 100644
--- a/gcc/ada/libgnat/s-pack39.ads
+++ b/gcc/ada/libgnat/s-pack39.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack40.adb b/gcc/ada/libgnat/s-pack40.adb
index 96a9053..b7a9e02 100644
--- a/gcc/ada/libgnat/s-pack40.adb
+++ b/gcc/ada/libgnat/s-pack40.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack40.ads b/gcc/ada/libgnat/s-pack40.ads
index 638e811..bb367d6 100644
--- a/gcc/ada/libgnat/s-pack40.ads
+++ b/gcc/ada/libgnat/s-pack40.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack41.adb b/gcc/ada/libgnat/s-pack41.adb
index 51b24cb..28a0def 100644
--- a/gcc/ada/libgnat/s-pack41.adb
+++ b/gcc/ada/libgnat/s-pack41.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack41.ads b/gcc/ada/libgnat/s-pack41.ads
index fa1f780..ce92fd9 100644
--- a/gcc/ada/libgnat/s-pack41.ads
+++ b/gcc/ada/libgnat/s-pack41.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack42.adb b/gcc/ada/libgnat/s-pack42.adb
index 713ee24..c759f94 100644
--- a/gcc/ada/libgnat/s-pack42.adb
+++ b/gcc/ada/libgnat/s-pack42.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack42.ads b/gcc/ada/libgnat/s-pack42.ads
index 6934090..a1c58ab 100644
--- a/gcc/ada/libgnat/s-pack42.ads
+++ b/gcc/ada/libgnat/s-pack42.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack43.adb b/gcc/ada/libgnat/s-pack43.adb
index 9378b4bb..137ce06 100644
--- a/gcc/ada/libgnat/s-pack43.adb
+++ b/gcc/ada/libgnat/s-pack43.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack43.ads b/gcc/ada/libgnat/s-pack43.ads
index 431d14b..c586e47 100644
--- a/gcc/ada/libgnat/s-pack43.ads
+++ b/gcc/ada/libgnat/s-pack43.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack44.adb b/gcc/ada/libgnat/s-pack44.adb
index 122dc9c..d8eaaac 100644
--- a/gcc/ada/libgnat/s-pack44.adb
+++ b/gcc/ada/libgnat/s-pack44.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack44.ads b/gcc/ada/libgnat/s-pack44.ads
index 3c38b50..e3873ee 100644
--- a/gcc/ada/libgnat/s-pack44.ads
+++ b/gcc/ada/libgnat/s-pack44.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack45.adb b/gcc/ada/libgnat/s-pack45.adb
index 67736a5..3739136 100644
--- a/gcc/ada/libgnat/s-pack45.adb
+++ b/gcc/ada/libgnat/s-pack45.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack45.ads b/gcc/ada/libgnat/s-pack45.ads
index cc4a7ab..dfdd7a9 100644
--- a/gcc/ada/libgnat/s-pack45.ads
+++ b/gcc/ada/libgnat/s-pack45.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack46.adb b/gcc/ada/libgnat/s-pack46.adb
index ba63edc..1bae1b9 100644
--- a/gcc/ada/libgnat/s-pack46.adb
+++ b/gcc/ada/libgnat/s-pack46.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack46.ads b/gcc/ada/libgnat/s-pack46.ads
index dd41cff..81c00df 100644
--- a/gcc/ada/libgnat/s-pack46.ads
+++ b/gcc/ada/libgnat/s-pack46.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack47.adb b/gcc/ada/libgnat/s-pack47.adb
index e2f38e5..e5ab870 100644
--- a/gcc/ada/libgnat/s-pack47.adb
+++ b/gcc/ada/libgnat/s-pack47.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack47.ads b/gcc/ada/libgnat/s-pack47.ads
index f15bd51..0de9bc6 100644
--- a/gcc/ada/libgnat/s-pack47.ads
+++ b/gcc/ada/libgnat/s-pack47.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack48.adb b/gcc/ada/libgnat/s-pack48.adb
index 59b188c..0ca74f5 100644
--- a/gcc/ada/libgnat/s-pack48.adb
+++ b/gcc/ada/libgnat/s-pack48.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack48.ads b/gcc/ada/libgnat/s-pack48.ads
index 7c29f61..225789a 100644
--- a/gcc/ada/libgnat/s-pack48.ads
+++ b/gcc/ada/libgnat/s-pack48.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack49.adb b/gcc/ada/libgnat/s-pack49.adb
index d2b9e24..f475e62 100644
--- a/gcc/ada/libgnat/s-pack49.adb
+++ b/gcc/ada/libgnat/s-pack49.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack49.ads b/gcc/ada/libgnat/s-pack49.ads
index 6269c0d..6ad4144 100644
--- a/gcc/ada/libgnat/s-pack49.ads
+++ b/gcc/ada/libgnat/s-pack49.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack50.adb b/gcc/ada/libgnat/s-pack50.adb
index 3cad660..2e55724 100644
--- a/gcc/ada/libgnat/s-pack50.adb
+++ b/gcc/ada/libgnat/s-pack50.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack50.ads b/gcc/ada/libgnat/s-pack50.ads
index 0c85e1b..bb3049a 100644
--- a/gcc/ada/libgnat/s-pack50.ads
+++ b/gcc/ada/libgnat/s-pack50.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack51.adb b/gcc/ada/libgnat/s-pack51.adb
index 262f003..9af3cb7 100644
--- a/gcc/ada/libgnat/s-pack51.adb
+++ b/gcc/ada/libgnat/s-pack51.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack51.ads b/gcc/ada/libgnat/s-pack51.ads
index 2d19eb1..70506d2 100644
--- a/gcc/ada/libgnat/s-pack51.ads
+++ b/gcc/ada/libgnat/s-pack51.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack52.adb b/gcc/ada/libgnat/s-pack52.adb
index 4d62e1e..1d6becb 100644
--- a/gcc/ada/libgnat/s-pack52.adb
+++ b/gcc/ada/libgnat/s-pack52.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack52.ads b/gcc/ada/libgnat/s-pack52.ads
index 0c0f14c..40d9142 100644
--- a/gcc/ada/libgnat/s-pack52.ads
+++ b/gcc/ada/libgnat/s-pack52.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack53.adb b/gcc/ada/libgnat/s-pack53.adb
index e5bb1d1..a2771a1 100644
--- a/gcc/ada/libgnat/s-pack53.adb
+++ b/gcc/ada/libgnat/s-pack53.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack53.ads b/gcc/ada/libgnat/s-pack53.ads
index b7f5de3..5512185 100644
--- a/gcc/ada/libgnat/s-pack53.ads
+++ b/gcc/ada/libgnat/s-pack53.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack54.adb b/gcc/ada/libgnat/s-pack54.adb
index cf107d9..06d3aeb 100644
--- a/gcc/ada/libgnat/s-pack54.adb
+++ b/gcc/ada/libgnat/s-pack54.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack54.ads b/gcc/ada/libgnat/s-pack54.ads
index 6db7222..52b29ae 100644
--- a/gcc/ada/libgnat/s-pack54.ads
+++ b/gcc/ada/libgnat/s-pack54.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack55.adb b/gcc/ada/libgnat/s-pack55.adb
index e23f3dc..6e2b628 100644
--- a/gcc/ada/libgnat/s-pack55.adb
+++ b/gcc/ada/libgnat/s-pack55.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack55.ads b/gcc/ada/libgnat/s-pack55.ads
index 80bbaf2..97115c6 100644
--- a/gcc/ada/libgnat/s-pack55.ads
+++ b/gcc/ada/libgnat/s-pack55.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack56.adb b/gcc/ada/libgnat/s-pack56.adb
index 1a94cd3..b8ecc0b 100644
--- a/gcc/ada/libgnat/s-pack56.adb
+++ b/gcc/ada/libgnat/s-pack56.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack56.ads b/gcc/ada/libgnat/s-pack56.ads
index 8473ef6..510fc35 100644
--- a/gcc/ada/libgnat/s-pack56.ads
+++ b/gcc/ada/libgnat/s-pack56.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack57.adb b/gcc/ada/libgnat/s-pack57.adb
index b35b707..2402e8b 100644
--- a/gcc/ada/libgnat/s-pack57.adb
+++ b/gcc/ada/libgnat/s-pack57.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack57.ads b/gcc/ada/libgnat/s-pack57.ads
index 4056a9a..8ac91c7 100644
--- a/gcc/ada/libgnat/s-pack57.ads
+++ b/gcc/ada/libgnat/s-pack57.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack58.adb b/gcc/ada/libgnat/s-pack58.adb
index d8080ba..75f00a1 100644
--- a/gcc/ada/libgnat/s-pack58.adb
+++ b/gcc/ada/libgnat/s-pack58.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack58.ads b/gcc/ada/libgnat/s-pack58.ads
index 713818d..d8d6e91 100644
--- a/gcc/ada/libgnat/s-pack58.ads
+++ b/gcc/ada/libgnat/s-pack58.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack59.adb b/gcc/ada/libgnat/s-pack59.adb
index 74cbb4a..ec001fa 100644
--- a/gcc/ada/libgnat/s-pack59.adb
+++ b/gcc/ada/libgnat/s-pack59.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack59.ads b/gcc/ada/libgnat/s-pack59.ads
index e9b1fa8..ee00f65 100644
--- a/gcc/ada/libgnat/s-pack59.ads
+++ b/gcc/ada/libgnat/s-pack59.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack60.adb b/gcc/ada/libgnat/s-pack60.adb
index f4bbec5..35b93f5 100644
--- a/gcc/ada/libgnat/s-pack60.adb
+++ b/gcc/ada/libgnat/s-pack60.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack60.ads b/gcc/ada/libgnat/s-pack60.ads
index eee3e41..95e0fd2 100644
--- a/gcc/ada/libgnat/s-pack60.ads
+++ b/gcc/ada/libgnat/s-pack60.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack61.adb b/gcc/ada/libgnat/s-pack61.adb
index dd0ec71..89b94ac 100644
--- a/gcc/ada/libgnat/s-pack61.adb
+++ b/gcc/ada/libgnat/s-pack61.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack61.ads b/gcc/ada/libgnat/s-pack61.ads
index 0e013b7..5681500 100644
--- a/gcc/ada/libgnat/s-pack61.ads
+++ b/gcc/ada/libgnat/s-pack61.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack62.adb b/gcc/ada/libgnat/s-pack62.adb
index 1505ecd..da6932a 100644
--- a/gcc/ada/libgnat/s-pack62.adb
+++ b/gcc/ada/libgnat/s-pack62.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack62.ads b/gcc/ada/libgnat/s-pack62.ads
index b82ade4..121c26f 100644
--- a/gcc/ada/libgnat/s-pack62.ads
+++ b/gcc/ada/libgnat/s-pack62.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack63.adb b/gcc/ada/libgnat/s-pack63.adb
index 8aada82..37b6767 100644
--- a/gcc/ada/libgnat/s-pack63.adb
+++ b/gcc/ada/libgnat/s-pack63.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack63.ads b/gcc/ada/libgnat/s-pack63.ads
index 720edd3..7ca3d03 100644
--- a/gcc/ada/libgnat/s-pack63.ads
+++ b/gcc/ada/libgnat/s-pack63.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-parame.adb b/gcc/ada/libgnat/s-parame.adb
index 3526109..c555a82 100644
--- a/gcc/ada/libgnat/s-parame.adb
+++ b/gcc/ada/libgnat/s-parame.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-parame.ads b/gcc/ada/libgnat/s-parame.ads
index 92ea885..f9bc3d0 100644
--- a/gcc/ada/libgnat/s-parame.ads
+++ b/gcc/ada/libgnat/s-parame.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -94,7 +94,7 @@ package System.Parameters is
Runtime_Default_Sec_Stack_Size : constant Size_Type := 10 * 1024;
-- The run-time chosen default size for secondary stacks that may be
- -- overriden by the user with the use of binder -D switch.
+ -- overridden by the user with the use of binder -D switch.
Sec_Stack_Dynamic : constant Boolean := True;
-- Indicates if secondary stacks can grow and shrink at run-time. If False,
@@ -147,19 +147,6 @@ package System.Parameters is
-- allow some optimizations and fine tuning within the tasking run time
-- based on restrictions on the tasking features.
- ----------------------
- -- Locking Strategy --
- ----------------------
-
- Single_Lock : constant Boolean := False;
- -- Indicates whether a single lock should be used within the tasking
- -- run-time to protect internal structures. If True, a single lock
- -- will be used, meaning less locking/unlocking operations, but also
- -- more global contention. In general, Single_Lock should be set to
- -- True on single processor machines, and to False to multi-processor
- -- systems, but this can vary from application to application and also
- -- depends on the scheduling policy.
-
-------------------
-- Task Abortion --
-------------------
diff --git a/gcc/ada/libgnat/s-parame__ae653.ads b/gcc/ada/libgnat/s-parame__ae653.ads
index eac44d1..3e73f5e 100644
--- a/gcc/ada/libgnat/s-parame__ae653.ads
+++ b/gcc/ada/libgnat/s-parame__ae653.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -94,7 +94,7 @@ package System.Parameters is
Runtime_Default_Sec_Stack_Size : constant Size_Type := 10 * 1024;
-- The run-time chosen default size for secondary stacks that may be
- -- overriden by the user with the use of binder -D switch.
+ -- overridden by the user with the use of binder -D switch.
Sec_Stack_Dynamic : constant Boolean := False;
-- Indicates if secondary stacks can grow and shrink at run-time. If False,
@@ -147,19 +147,6 @@ package System.Parameters is
-- allow some optimizations and fine tuning within the tasking run time
-- based on restrictions on the tasking features.
- ----------------------
- -- Locking Strategy --
- ----------------------
-
- Single_Lock : constant Boolean := False;
- -- Indicates whether a single lock should be used within the tasking
- -- run-time to protect internal structures. If True, a single lock
- -- will be used, meaning less locking/unlocking operations, but also
- -- more global contention. In general, Single_Lock should be set to
- -- True on single processor machines, and to False to multi-processor
- -- systems, but this can vary from application to application and also
- -- depends on the scheduling policy.
-
-------------------
-- Task Abortion --
-------------------
diff --git a/gcc/ada/libgnat/s-parame__hpux.ads b/gcc/ada/libgnat/s-parame__hpux.ads
index 48ad97a..e09313f 100644
--- a/gcc/ada/libgnat/s-parame__hpux.ads
+++ b/gcc/ada/libgnat/s-parame__hpux.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -92,7 +92,7 @@ package System.Parameters is
Runtime_Default_Sec_Stack_Size : constant Size_Type := 10 * 1024;
-- The run-time chosen default size for secondary stacks that may be
- -- overriden by the user with the use of binder -D switch.
+ -- overridden by the user with the use of binder -D switch.
Sec_Stack_Dynamic : constant Boolean := True;
-- Indicates if secondary stacks can grow and shrink at run-time. If False,
@@ -145,19 +145,6 @@ package System.Parameters is
-- allow some optimizations and fine tuning within the tasking run time
-- based on restrictions on the tasking features.
- ----------------------
- -- Locking Strategy --
- ----------------------
-
- Single_Lock : constant Boolean := False;
- -- Indicates whether a single lock should be used within the tasking
- -- run-time to protect internal structures. If True, a single lock
- -- will be used, meaning less locking/unlocking operations, but also
- -- more global contention. In general, Single_Lock should be set to
- -- True on single processor machines, and to False to multi-processor
- -- systems, but this can vary from application to application and also
- -- depends on the scheduling policy.
-
-------------------
-- Task Abortion --
-------------------
diff --git a/gcc/ada/libgnat/s-parame__rtems.adb b/gcc/ada/libgnat/s-parame__rtems.adb
index d900b68..f350343 100644
--- a/gcc/ada/libgnat/s-parame__rtems.adb
+++ b/gcc/ada/libgnat/s-parame__rtems.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-parame__vxworks.adb b/gcc/ada/libgnat/s-parame__vxworks.adb
index f23ef5a..7d0a206 100644
--- a/gcc/ada/libgnat/s-parame__vxworks.adb
+++ b/gcc/ada/libgnat/s-parame__vxworks.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-parame__vxworks.ads b/gcc/ada/libgnat/s-parame__vxworks.ads
index f351ee7..c836444 100644
--- a/gcc/ada/libgnat/s-parame__vxworks.ads
+++ b/gcc/ada/libgnat/s-parame__vxworks.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -147,19 +147,6 @@ package System.Parameters is
-- allow some optimizations and fine tuning within the tasking run time
-- based on restrictions on the tasking features.
- ----------------------
- -- Locking Strategy --
- ----------------------
-
- Single_Lock : constant Boolean := False;
- -- Indicates whether a single lock should be used within the tasking
- -- run-time to protect internal structures. If True, a single lock
- -- will be used, meaning less locking/unlocking operations, but also
- -- more global contention. In general, Single_Lock should be set to
- -- True on single processor machines, and to False to multi-processor
- -- systems, but this can vary from application to application and also
- -- depends on the scheduling policy.
-
-------------------
-- Task Abortion --
-------------------
diff --git a/gcc/ada/libgnat/s-parint.adb b/gcc/ada/libgnat/s-parint.adb
index a83f82c..f984a49 100644
--- a/gcc/ada/libgnat/s-parint.adb
+++ b/gcc/ada/libgnat/s-parint.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- (Dummy body for non-distributed case) --
-- --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-parint.ads b/gcc/ada/libgnat/s-parint.ads
index b1debed..b037571 100644
--- a/gcc/ada/libgnat/s-parint.ads
+++ b/gcc/ada/libgnat/s-parint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pooglo.adb b/gcc/ada/libgnat/s-pooglo.adb
index acb4441..d1eaf53 100644
--- a/gcc/ada/libgnat/s-pooglo.adb
+++ b/gcc/ada/libgnat/s-pooglo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pooglo.ads b/gcc/ada/libgnat/s-pooglo.ads
index f4fa930..8c19837 100644
--- a/gcc/ada/libgnat/s-pooglo.ads
+++ b/gcc/ada/libgnat/s-pooglo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pooloc.adb b/gcc/ada/libgnat/s-pooloc.adb
index 3e76673..04a0532 100644
--- a/gcc/ada/libgnat/s-pooloc.adb
+++ b/gcc/ada/libgnat/s-pooloc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pooloc.ads b/gcc/ada/libgnat/s-pooloc.ads
index 9ad310f..6ba152a 100644
--- a/gcc/ada/libgnat/s-pooloc.ads
+++ b/gcc/ada/libgnat/s-pooloc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-poosiz.adb b/gcc/ada/libgnat/s-poosiz.adb
index 3a6edea..bc6ae24 100644
--- a/gcc/ada/libgnat/s-poosiz.adb
+++ b/gcc/ada/libgnat/s-poosiz.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-poosiz.ads b/gcc/ada/libgnat/s-poosiz.ads
index 13e2d8b..3921b1c 100644
--- a/gcc/ada/libgnat/s-poosiz.ads
+++ b/gcc/ada/libgnat/s-poosiz.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-powtab.ads b/gcc/ada/libgnat/s-powtab.ads
index cc288bd..ef8d74a 100644
--- a/gcc/ada/libgnat/s-powtab.ads
+++ b/gcc/ada/libgnat/s-powtab.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-purexc.ads b/gcc/ada/libgnat/s-purexc.ads
index a101923..4c727d7 100644
--- a/gcc/ada/libgnat/s-purexc.ads
+++ b/gcc/ada/libgnat/s-purexc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-putaim.adb b/gcc/ada/libgnat/s-putaim.adb
new file mode 100644
index 0000000..08fa7b7
--- /dev/null
+++ b/gcc/ada/libgnat/s-putaim.adb
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- SYSTEM.PUT_TASK_IMAGES --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Conversion;
+with Ada.Strings.Text_Output.Utils;
+use Ada.Strings.Text_Output;
+use Ada.Strings.Text_Output.Utils;
+
+package body System.Put_Task_Images is
+
+ procedure Put_Image_Protected (S : in out Sink'Class) is
+ begin
+ Put_UTF_8 (S, "(protected object)");
+ end Put_Image_Protected;
+
+ procedure Put_Image_Task
+ (S : in out Sink'Class; Id : Ada.Task_Identification.Task_Id)
+ is
+ begin
+ Put_UTF_8 (S, "(task " & Ada.Task_Identification.Image (Id) & ")");
+ end Put_Image_Task;
+
+end System.Put_Task_Images;
diff --git a/gcc/ada/libgnat/a-numaux__x86.ads b/gcc/ada/libgnat/s-putaim.ads
index 8494f89..b4dd8c2 100644
--- a/gcc/ada/libgnat/a-numaux__x86.ads
+++ b/gcc/ada/libgnat/s-putaim.ads
@@ -2,12 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- A D A . N U M E R I C S . A U X --
+-- SYSTEM.PUT_TASK_IMAGES --
-- --
-- S p e c --
--- (Machine Version for x86) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,47 +29,20 @@
-- --
------------------------------------------------------------------------------
--- This version is for the x86 using the 80-bit x86 long double format with
--- inline asm statements.
+with Ada.Strings.Text_Output;
+with Ada.Task_Identification;
-package Ada.Numerics.Aux is
- pragma Pure;
+package System.Put_Task_Images is
- type Double is new Long_Long_Float;
+ -- This package contains subprograms that are called by the generated code
+ -- for the 'Put_Image attribute for protected and task types. This is
+ -- separate from System.Put_Images to avoid dragging the tasking runtimes
+ -- into nontasking programs.
- function Sin (X : Double) return Double;
+ subtype Sink is Ada.Strings.Text_Output.Sink;
- function Cos (X : Double) return Double;
+ procedure Put_Image_Protected (S : in out Sink'Class);
+ procedure Put_Image_Task
+ (S : in out Sink'Class; Id : Ada.Task_Identification.Task_Id);
- function Tan (X : Double) return Double;
-
- function Exp (X : Double) return Double;
-
- function Sqrt (X : Double) return Double;
-
- function Log (X : Double) return Double;
-
- function Atan (X : Double) return Double;
-
- function Acos (X : Double) return Double;
-
- function Asin (X : Double) return Double;
-
- function Sinh (X : Double) return Double;
-
- function Cosh (X : Double) return Double;
-
- function Tanh (X : Double) return Double;
-
- function Pow (X, Y : Double) return Double;
-
-private
- pragma Inline (Atan);
- pragma Inline (Cos);
- pragma Inline (Tan);
- pragma Inline (Exp);
- pragma Inline (Log);
- pragma Inline (Sin);
- pragma Inline (Sqrt);
-
-end Ada.Numerics.Aux;
+end System.Put_Task_Images;
diff --git a/gcc/ada/libgnat/s-putima.adb b/gcc/ada/libgnat/s-putima.adb
new file mode 100644
index 0000000..4ae612d
--- /dev/null
+++ b/gcc/ada/libgnat/s-putima.adb
@@ -0,0 +1,260 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- SYSTEM.PUT_IMAGES --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Conversion;
+with Ada.Strings.Text_Output.Utils;
+use Ada.Strings.Text_Output;
+use Ada.Strings.Text_Output.Utils;
+
+package body System.Put_Images is
+
+ generic
+ type Integer_Type is range <>;
+ type Unsigned_Type is mod <>;
+ Base : Unsigned_Type;
+ package Generic_Integer_Images is
+ pragma Assert (Integer_Type'Size = Unsigned_Type'Size);
+ pragma Assert (Base in 2 .. 36);
+ procedure Put_Image (S : in out Sink'Class; X : Integer_Type);
+ procedure Put_Image (S : in out Sink'Class; X : Unsigned_Type);
+ private
+ subtype Digit is Unsigned_Type range 0 .. Base - 1;
+ end Generic_Integer_Images;
+
+ package body Generic_Integer_Images is
+
+ A : constant := Character'Pos ('a');
+ Z : constant := Character'Pos ('0');
+ function Digit_To_Character (X : Digit) return Character is
+ (Character'Val (if X < 10 then X + Z else X + A - 10));
+
+ procedure Put_Digits (S : in out Sink'Class; X : Unsigned_Type);
+ -- Put just the digits of X, without any leading minus sign or space.
+
+ procedure Put_Digits (S : in out Sink'Class; X : Unsigned_Type) is
+ begin
+ if X >= Base then
+ Put_Digits (S, X / Base); -- recurse
+ Put_7bit (S, Digit_To_Character (X mod Base));
+ else
+ Put_7bit (S, Digit_To_Character (X));
+ end if;
+ end Put_Digits;
+
+ procedure Put_Image (S : in out Sink'Class; X : Integer_Type) is
+ begin
+ -- Put the space or the minus sign, then pass the absolute value to
+ -- Put_Digits.
+
+ if X >= 0 then
+ Put_7bit (S, ' ');
+ Put_Digits (S, Unsigned_Type (X));
+ else
+ Put_7bit (S, '-');
+ Put_Digits (S, -Unsigned_Type'Mod (X));
+ -- Convert to Unsigned_Type before negating, to avoid overflow
+ -- on Integer_Type'First.
+ end if;
+ end Put_Image;
+
+ procedure Put_Image (S : in out Sink'Class; X : Unsigned_Type) is
+ begin
+ Put_7bit (S, ' ');
+ Put_Digits (S, X);
+ end Put_Image;
+
+ end Generic_Integer_Images;
+
+ package Small is new Generic_Integer_Images (Integer, Unsigned, Base => 10);
+ package Large is new Generic_Integer_Images
+ (Long_Long_Integer, Long_Long_Unsigned, Base => 10);
+
+ procedure Put_Image_Integer (S : in out Sink'Class; X : Integer)
+ renames Small.Put_Image;
+ procedure Put_Image_Long_Long_Integer
+ (S : in out Sink'Class; X : Long_Long_Integer)
+ renames Large.Put_Image;
+
+ procedure Put_Image_Unsigned (S : in out Sink'Class; X : Unsigned)
+ renames Small.Put_Image;
+ procedure Put_Image_Long_Long_Unsigned
+ (S : in out Sink'Class; X : Long_Long_Unsigned)
+ renames Large.Put_Image;
+
+ type Signed_Address is range
+ -2**(Standard'Address_Size - 1) .. 2**(Standard'Address_Size - 1) - 1;
+ type Unsigned_Address is mod 2**Standard'Address_Size;
+ package Hex is new Generic_Integer_Images
+ (Signed_Address, Unsigned_Address, Base => 16);
+
+ generic
+ type Designated (<>) is private;
+ type Pointer is access all Designated;
+ procedure Put_Image_Pointer
+ (S : in out Sink'Class; X : Pointer; Type_Kind : String);
+
+ procedure Put_Image_Pointer
+ (S : in out Sink'Class; X : Pointer; Type_Kind : String)
+ is
+ function Cast is new Unchecked_Conversion
+ (System.Address, Unsigned_Address);
+ begin
+ if X = null then
+ Put_UTF_8 (S, "null");
+ else
+ Put_UTF_8 (S, "(");
+ Put_UTF_8 (S, Type_Kind);
+ Hex.Put_Image (S, Cast (X.all'Address));
+ Put_UTF_8 (S, ")");
+ end if;
+ end Put_Image_Pointer;
+
+ procedure Thin_Instance is new Put_Image_Pointer (Byte, Thin_Pointer);
+ procedure Put_Image_Thin_Pointer
+ (S : in out Sink'Class; X : Thin_Pointer)
+ is
+ begin
+ Thin_Instance (S, X, "access");
+ end Put_Image_Thin_Pointer;
+
+ procedure Fat_Instance is new Put_Image_Pointer (Byte_String, Fat_Pointer);
+ procedure Put_Image_Fat_Pointer
+ (S : in out Sink'Class; X : Fat_Pointer)
+ is
+ begin
+ Fat_Instance (S, X, "access");
+ end Put_Image_Fat_Pointer;
+
+ procedure Put_Image_Access_Subp (S : in out Sink'Class; X : Thin_Pointer) is
+ begin
+ Thin_Instance (S, X, "access subprogram");
+ end Put_Image_Access_Subp;
+
+ procedure Put_Image_Access_Prot_Subp
+ (S : in out Sink'Class; X : Thin_Pointer)
+ is
+ begin
+ Thin_Instance (S, X, "access protected subprogram");
+ end Put_Image_Access_Prot_Subp;
+
+ procedure Put_Image_String (S : in out Sink'Class; X : String) is
+ begin
+ Put_UTF_8 (S, """");
+ for C of X loop
+ if C = '"' then
+ Put_UTF_8 (S, """");
+ end if;
+ Put_Character (S, C);
+ end loop;
+ Put_UTF_8 (S, """");
+ end Put_Image_String;
+
+ procedure Put_Image_Wide_String (S : in out Sink'Class; X : Wide_String) is
+ begin
+ Put_UTF_8 (S, """");
+ for C of X loop
+ if C = '"' then
+ Put_UTF_8 (S, """");
+ end if;
+ Put_Wide_Character (S, C);
+ end loop;
+ Put_UTF_8 (S, """");
+ end Put_Image_Wide_String;
+
+ procedure Put_Image_Wide_Wide_String
+ (S : in out Sink'Class; X : Wide_Wide_String) is
+ begin
+ Put_UTF_8 (S, """");
+ for C of X loop
+ if C = '"' then
+ Put_UTF_8 (S, """");
+ end if;
+ Put_Wide_Wide_Character (S, C);
+ end loop;
+ Put_UTF_8 (S, """");
+ end Put_Image_Wide_Wide_String;
+
+ procedure Array_Before (S : in out Sink'Class) is
+ begin
+ New_Line (S);
+ Put_7bit (S, '[');
+ Indent (S, 1);
+ end Array_Before;
+
+ procedure Array_Between (S : in out Sink'Class) is
+ begin
+ Put_7bit (S, ',');
+ New_Line (S);
+ end Array_Between;
+
+ procedure Array_After (S : in out Sink'Class) is
+ begin
+ Outdent (S, 1);
+ Put_7bit (S, ']');
+ end Array_After;
+
+ procedure Simple_Array_Between (S : in out Sink'Class) is
+ begin
+ Put_7bit (S, ',');
+ if Column (S) > 60 then
+ New_Line (S);
+ else
+ Put_7bit (S, ' ');
+ end if;
+ end Simple_Array_Between;
+
+ procedure Record_Before (S : in out Sink'Class) is
+ begin
+ New_Line (S);
+ Put_7bit (S, '(');
+ Indent (S, 1);
+ end Record_Before;
+
+ procedure Record_Between (S : in out Sink'Class) is
+ begin
+ Put_7bit (S, ',');
+ New_Line (S);
+ end Record_Between;
+
+ procedure Record_After (S : in out Sink'Class) is
+ begin
+ Outdent (S, 1);
+ Put_7bit (S, ')');
+ end Record_After;
+
+ procedure Put_Image_Unknown (S : in out Sink'Class; Type_Name : String) is
+ begin
+ Put_UTF_8 (S, "{");
+ Put_String (S, Type_Name);
+ Put_UTF_8 (S, " object}");
+ end Put_Image_Unknown;
+
+end System.Put_Images;
diff --git a/gcc/ada/libgnat/s-putima.ads b/gcc/ada/libgnat/s-putima.ads
new file mode 100644
index 0000000..17e184a
--- /dev/null
+++ b/gcc/ada/libgnat/s-putima.ads
@@ -0,0 +1,102 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- SYSTEM.PUT_IMAGES --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Text_Output;
+with System.Unsigned_Types;
+
+package System.Put_Images is
+
+ -- This package contains subprograms that are called by the generated code
+ -- for the 'Put_Image attribute.
+ --
+ -- For an integer type that fits in Integer, the actual parameter is
+ -- converted to Integer, and Put_Image_Integer is called. For larger types,
+ -- Put_Image_Long_Long_Integer is used. Other numeric types are treated
+ -- similarly. Access values are unchecked-converted to either Thin_Pointer
+ -- or Fat_Pointer, and Put_Image_Thin_Pointer or Put_Image_Fat_Pointer is
+ -- called. The Before/Between/After procedures are called before printing
+ -- the components of a composite type, between pairs of components, and
+ -- after them. See Exp_Put_Image in the compiler for details of these
+ -- calls.
+
+ pragma Preelaborate;
+
+ subtype Sink is Ada.Strings.Text_Output.Sink;
+
+ procedure Put_Image_Integer (S : in out Sink'Class; X : Integer);
+ procedure Put_Image_Long_Long_Integer
+ (S : in out Sink'Class; X : Long_Long_Integer);
+
+ subtype Unsigned is System.Unsigned_Types.Unsigned;
+ subtype Long_Long_Unsigned is System.Unsigned_Types.Long_Long_Unsigned;
+
+ procedure Put_Image_Unsigned (S : in out Sink'Class; X : Unsigned);
+ procedure Put_Image_Long_Long_Unsigned
+ (S : in out Sink'Class; X : Long_Long_Unsigned);
+
+ type Byte is new Character with Alignment => 1;
+ type Byte_String is array (Positive range <>) of Byte with Alignment => 1;
+ type Thin_Pointer is access all Byte;
+ type Fat_Pointer is access all Byte_String;
+ procedure Put_Image_Thin_Pointer (S : in out Sink'Class; X : Thin_Pointer);
+ procedure Put_Image_Fat_Pointer (S : in out Sink'Class; X : Fat_Pointer);
+ -- Print "null", or the address of the designated object as an unsigned
+ -- hexadecimal integer.
+
+ procedure Put_Image_Access_Subp (S : in out Sink'Class; X : Thin_Pointer);
+ -- For access-to-subprogram types
+
+ procedure Put_Image_Access_Prot_Subp
+ (S : in out Sink'Class; X : Thin_Pointer);
+ -- For access-to-protected-subprogram types
+
+ procedure Put_Image_String (S : in out Sink'Class; X : String);
+ procedure Put_Image_Wide_String (S : in out Sink'Class; X : Wide_String);
+ procedure Put_Image_Wide_Wide_String
+ (S : in out Sink'Class; X : Wide_Wide_String);
+
+ procedure Array_Before (S : in out Sink'Class);
+ procedure Array_Between (S : in out Sink'Class);
+ procedure Array_After (S : in out Sink'Class);
+
+ procedure Simple_Array_Between (S : in out Sink'Class);
+ -- For "simple" arrays, where we don't want a newline between every
+ -- component.
+
+ procedure Record_Before (S : in out Sink'Class);
+ procedure Record_Between (S : in out Sink'Class);
+ procedure Record_After (S : in out Sink'Class);
+
+ procedure Put_Image_Unknown (S : in out Sink'Class; Type_Name : String);
+ -- For Put_Image of types that don't have the attribute, such as type
+ -- Sink.
+
+end System.Put_Images;
diff --git a/gcc/ada/libgnat/s-rannum.adb b/gcc/ada/libgnat/s-rannum.adb
index 0590313..01a6e91 100644
--- a/gcc/ada/libgnat/s-rannum.adb
+++ b/gcc/ada/libgnat/s-rannum.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -86,6 +86,7 @@
-- --
------------------------------------------------------------------------------
+with Ada.Strings.Text_Output.Utils;
with Ada.Unchecked_Conversion;
with System.Random_Seed;
@@ -295,6 +296,7 @@ is
K : Bit_Count; -- Next decrement to exponent
begin
+ K := 0;
Mantissa := Random (Gen) / 2**Extra_Bits;
R := Unsigned_32 (Mantissa mod 2**Extra_Bits);
R_Bits := Extra_Bits;
@@ -401,12 +403,12 @@ is
elsif Max < Min then
raise Constraint_Error;
+ -- In the 64-bit case, we have to be careful since not all 64-bit
+ -- unsigned values are representable in GNAT's universal integer.
+
elsif Result_Subtype'Base'Size > 32 then
declare
- -- In the 64-bit case, we have to be careful, since not all 64-bit
- -- unsigned values are representable in GNAT's root_integer type.
- -- Ignore different-size warnings here since GNAT's handling
- -- is correct.
+ -- Ignore unequal-size warnings since GNAT's handling is correct.
pragma Warnings ("Z");
function Conv_To_Unsigned is
@@ -436,11 +438,14 @@ is
end if;
end;
- elsif Result_Subtype'Pos (Max) - Result_Subtype'Pos (Min) =
- 2 ** 32 - 1
+ -- In the 32-bit case, we need to handle both integer and enumeration
+ -- types and, therefore, rely on 'Pos and 'Val in the computation.
+
+ elsif Result_Subtype'Pos (Max) - Result_Subtype'Pos (Min) = 2 ** 32 - 1
then
return Result_Subtype'Val
(Result_Subtype'Pos (Min) + Unsigned_32'Pos (Random (Gen)));
+
else
declare
N : constant Unsigned_32 :=
@@ -635,6 +640,16 @@ is
return Result;
end Image;
+ ---------------
+ -- Put_Image --
+ ---------------
+
+ procedure Put_Image
+ (S : in out Strings.Text_Output.Sink'Class; V : State) is
+ begin
+ Strings.Text_Output.Utils.Put_String (S, Image (V));
+ end Put_Image;
+
-----------
-- Value --
-----------
diff --git a/gcc/ada/libgnat/s-rannum.ads b/gcc/ada/libgnat/s-rannum.ads
index 75fdfeb..1851b69 100644
--- a/gcc/ada/libgnat/s-rannum.ads
+++ b/gcc/ada/libgnat/s-rannum.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -57,6 +57,8 @@
with Interfaces;
+private with Ada.Strings.Text_Output;
+
package System.Random_Numbers with
SPARK_Mode => Off
is
@@ -142,7 +144,10 @@ private
-- Feedback distance from the current position
subtype State_Val is Interfaces.Unsigned_32;
- type State is array (0 .. N - 1) of State_Val;
+ type State is array (0 .. N - 1) of State_Val with Put_Image => Put_Image;
+
+ procedure Put_Image
+ (S : in out Ada.Strings.Text_Output.Sink'Class; V : State);
type Writable_Access (Self : access Generator) is limited null record;
-- Auxiliary type to make Generator a self-referential type
diff --git a/gcc/ada/libgnat/s-ransee.adb b/gcc/ada/libgnat/s-ransee.adb
index f78279f..0c168df 100644
--- a/gcc/ada/libgnat/s-ransee.adb
+++ b/gcc/ada/libgnat/s-ransee.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-ransee.ads b/gcc/ada/libgnat/s-ransee.ads
index 3fec97b..559eaa0 100644
--- a/gcc/ada/libgnat/s-ransee.ads
+++ b/gcc/ada/libgnat/s-ransee.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-regexp.adb b/gcc/ada/libgnat/s-regexp.adb
index 2417498..f8adc4a 100644
--- a/gcc/ada/libgnat/s-regexp.adb
+++ b/gcc/ada/libgnat/s-regexp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-regexp.ads b/gcc/ada/libgnat/s-regexp.ads
index 4d9fb5b..243da67 100644
--- a/gcc/ada/libgnat/s-regexp.ads
+++ b/gcc/ada/libgnat/s-regexp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -83,8 +83,10 @@ package System.Regexp is
-- regexp ::= term
-- term ::= elmt
- -- term ::= elmt elmt ... -- concatenation (elmt then elmt)
- -- term ::= {elmt, elmt, ...} -- alternation (matches any of elmt)
+ -- term ::= seq
+ -- term ::= {seq, seq, ...} -- alternation (matches any of seq)
+
+ -- seq ::= elmt elmt ... -- concatenation (sequence of elmts)
-- elmt ::= * -- any string of 0 or more characters
-- elmt ::= ? -- matches any character
diff --git a/gcc/ada/libgnat/s-regpat.adb b/gcc/ada/libgnat/s-regpat.adb
index ae69f47..2e60ba8 100644
--- a/gcc/ada/libgnat/s-regpat.adb
+++ b/gcc/ada/libgnat/s-regpat.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1986 by University of Toronto. --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1460,19 +1460,9 @@ package body System.Regpat is
and then Expression (Parse_Pos + 1) /= ']'
then
Parse_Pos := Parse_Pos + 1;
-
- -- Do we have a range like '\d-a' and '[:space:]-a'
- -- which is not a real range
-
- if Named_Class /= ANYOF_NONE then
- Set_In_Class (Bitmap, '-');
- else
- In_Range := True;
- end if;
-
+ In_Range := True;
else
Set_In_Class (Bitmap, Value);
-
end if;
-- Else in a character range
@@ -3275,13 +3265,13 @@ package body System.Regpat is
(IP : Pointer;
Max : Natural := Natural'Last) return Natural
is
- Scan : Natural := Input_Pos;
- Last : Natural;
- Op : constant Opcode := Opcode'Val (Character'Pos (Program (IP)));
- Count : Natural;
- C : Character;
- Is_First : Boolean := True;
- Bitmap : Character_Class;
+ Scan : Natural := Input_Pos;
+ Last : Natural;
+ Op : constant Opcode :=
+ Opcode'Val (Character'Pos (Program (IP)));
+ Count : Natural;
+ C : Character;
+ Bitmap : Character_Class;
begin
if Max = Natural'Last or else Scan + Max - 1 > Last_In_Data then
@@ -3324,10 +3314,7 @@ package body System.Regpat is
end loop;
when ANYOF =>
- if Is_First then
- Bitmap_Operand (Program, IP, Bitmap);
- Is_First := False;
- end if;
+ Bitmap_Operand (Program, IP, Bitmap);
while Scan <= Last
and then Get_From_Class (Bitmap, Data (Scan))
diff --git a/gcc/ada/libgnat/s-regpat.ads b/gcc/ada/libgnat/s-regpat.ads
index 74ecdec..0a591fd 100644
--- a/gcc/ada/libgnat/s-regpat.ads
+++ b/gcc/ada/libgnat/s-regpat.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1986 by University of Toronto. --
--- Copyright (C) 1996-2019, AdaCore --
+-- Copyright (C) 1996-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-resfil.adb b/gcc/ada/libgnat/s-resfil.adb
index dd07692..145aeb0 100644
--- a/gcc/ada/libgnat/s-resfil.adb
+++ b/gcc/ada/libgnat/s-resfil.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-resfil.ads b/gcc/ada/libgnat/s-resfil.ads
index 50bc7ff..369f2f4 100644
--- a/gcc/ada/libgnat/s-resfil.ads
+++ b/gcc/ada/libgnat/s-resfil.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-restri.adb b/gcc/ada/libgnat/s-restri.adb
index d63133d..5c91d13 100644
--- a/gcc/ada/libgnat/s-restri.adb
+++ b/gcc/ada/libgnat/s-restri.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-restri.ads b/gcc/ada/libgnat/s-restri.ads
index 604431a..221b83a 100644
--- a/gcc/ada/libgnat/s-restri.ads
+++ b/gcc/ada/libgnat/s-restri.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-rident.ads b/gcc/ada/libgnat/s-rident.ads
index 1e70a38..afec9a4 100644
--- a/gcc/ada/libgnat/s-rident.ads
+++ b/gcc/ada/libgnat/s-rident.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -62,10 +62,10 @@
-- then the binder could fail to recognize the R (restrictions line) in the
-- ali file, leading to bind errors when restrictions were added or removed.
--- The latest implementation avoids both this problem by using a named
--- scheme for recording restrictions, rather than a positional scheme which
--- fails completely if restrictions are added or subtracted. Now the worst
--- that happens at bind time in inconsistent builds is that unrecognized
+-- The latest implementation avoids this problem by using a named scheme
+-- for recording restrictions, rather than a positional scheme that fails
+-- completely if restrictions are added or subtracted. Now the worst that
+-- happens at bind time in inconsistent builds is that unrecognized
-- restrictions are ignored, and the consistency checking for restrictions
-- might be incomplete, which is no big deal.
@@ -104,6 +104,7 @@ package System.Rident is
No_Dispatch, -- (RM H.4(19))
No_Dispatching_Calls, -- GNAT
No_Dynamic_Attachment, -- Ada 2012 (RM E.7(10/3))
+ No_Dynamic_CPU_Assignment, -- Ada 202x (RM D.7(10/3))
No_Dynamic_Priorities, -- (RM D.9(9))
No_Enumeration_Maps, -- GNAT
No_Entry_Calls_In_Elaboration_Code, -- GNAT
@@ -147,6 +148,7 @@ package System.Rident is
No_Task_At_Interrupt_Priority, -- GNAT
No_Task_Hierarchy, -- (RM D.7(3), H.4(3))
No_Task_Termination, -- GNAT (Ravenscar)
+ No_Tasks_Unassigned_To_CPU, -- Ada 202x (D.7(10.10/4))
No_Tasking, -- GNAT
No_Terminate_Alternatives, -- (RM D.7(6))
No_Unchecked_Access, -- (RM H.4(18))
@@ -232,7 +234,6 @@ package System.Rident is
No_Dynamic_Interrupts : Restriction_Id renames No_Dynamic_Attachment;
No_Requeue : Restriction_Id renames No_Requeue_Statements;
No_Task_Attributes : Restriction_Id renames No_Task_Attributes_Package;
- SPARK : Restriction_Id renames SPARK_05;
subtype All_Restrictions is Restriction_Id range
Simple_Barriers .. Max_Storage_At_Blocking;
@@ -382,6 +383,7 @@ package System.Rident is
Restricted_Tasking,
Restricted,
Ravenscar,
+ Jorvik,
GNAT_Extended_Ravenscar,
GNAT_Ravenscar_EDF);
-- Names of recognized profiles. No_Profile is used to indicate that a
@@ -438,6 +440,7 @@ package System.Rident is
(No_Abort_Statements => True,
No_Asynchronous_Control => True,
No_Dynamic_Attachment => True,
+ No_Dynamic_CPU_Assignment => True,
No_Dynamic_Priorities => True,
No_Local_Protected_Objects => True,
No_Protected_Type_Allocators => True,
@@ -469,6 +472,7 @@ package System.Rident is
(No_Abort_Statements => True,
No_Asynchronous_Control => True,
No_Dynamic_Attachment => True,
+ No_Dynamic_CPU_Assignment => True,
No_Dynamic_Priorities => True,
No_Entry_Queue => True,
No_Local_Protected_Objects => True,
@@ -511,6 +515,7 @@ package System.Rident is
(No_Abort_Statements => True,
No_Asynchronous_Control => True,
No_Dynamic_Attachment => True,
+ No_Dynamic_CPU_Assignment => True,
No_Dynamic_Priorities => True,
No_Entry_Queue => True,
No_Local_Protected_Objects => True,
@@ -546,6 +551,68 @@ package System.Rident is
Max_Task_Entries => 0,
others => 0)),
+ Jorvik =>
+
+ -- Restrictions for Jorvik profile ..
+
+ -- Note: the table entries here only represent the
+ -- required restriction profile for Jorvik. The
+ -- full Jorvik profile also requires:
+
+ -- pragma Dispatching_Policy (FIFO_Within_Priorities);
+ -- pragma Locking_Policy (Ceiling_Locking);
+ -- pragma Detect_Blocking;
+
+ -- The differences between Ravenscar and Jorvik are
+ -- as follows:
+ -- 1) Ravenscar includes restriction Simple_Barriers;
+ -- Jorvik includes Pure_Barriers instead.
+ -- 2) The following 6 restrictions are included in
+ -- Ravenscar but not in Jorvik:
+ -- No_Implicit_Heap_Allocations
+ -- No_Relative_Delay
+ -- Max_Entry_Queue_Length => 1
+ -- Max_Protected_Entries => 1
+ -- No_Dependence => Ada.Calendar
+ -- No_Dependence => Ada.Synchronous_Barriers
+ --
+ -- The last of those 7 (i.e., No_Dep => Ada.Synch_Bars)
+ -- is not reflected here (see sem_prag.adb).
+
+ (Set =>
+ (No_Abort_Statements => True,
+ No_Asynchronous_Control => True,
+ No_Dynamic_Attachment => True,
+ No_Dynamic_CPU_Assignment => True,
+ No_Dynamic_Priorities => True,
+ No_Local_Protected_Objects => True,
+ No_Protected_Type_Allocators => True,
+ No_Requeue_Statements => True,
+ No_Task_Allocators => True,
+ No_Task_Attributes_Package => True,
+ No_Task_Hierarchy => True,
+ No_Terminate_Alternatives => True,
+ Max_Asynchronous_Select_Nesting => True,
+ Max_Select_Alternatives => True,
+ Max_Task_Entries => True,
+
+ -- plus these additional restrictions:
+
+ No_Local_Timing_Events => True,
+ No_Select_Statements => True,
+ No_Specific_Termination_Handlers => True,
+ No_Task_Termination => True,
+ Pure_Barriers => True,
+ others => False),
+
+ -- Value settings for Ravenscar (same as Restricted)
+
+ Value =>
+ (Max_Asynchronous_Select_Nesting => 0,
+ Max_Select_Alternatives => 0,
+ Max_Task_Entries => 0,
+ others => 0)),
+
GNAT_Extended_Ravenscar =>
-- Restrictions for GNAT_Extended_Ravenscar =
@@ -555,6 +622,7 @@ package System.Rident is
(No_Abort_Statements => True,
No_Asynchronous_Control => True,
No_Dynamic_Attachment => True,
+ No_Dynamic_CPU_Assignment => True,
No_Dynamic_Priorities => True,
No_Local_Protected_Objects => True,
No_Protected_Type_Allocators => True,
@@ -605,6 +673,7 @@ package System.Rident is
(No_Abort_Statements => True,
No_Asynchronous_Control => True,
No_Dynamic_Attachment => True,
+ No_Dynamic_CPU_Assignment => True,
No_Dynamic_Priorities => True,
No_Entry_Queue => True,
No_Local_Protected_Objects => True,
diff --git a/gcc/ada/libgnat/s-rpc.adb b/gcc/ada/libgnat/s-rpc.adb
index 36b7eb6..f4c719f 100644
--- a/gcc/ada/libgnat/s-rpc.adb
+++ b/gcc/ada/libgnat/s-rpc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-rpc.ads b/gcc/ada/libgnat/s-rpc.ads
index 0eb12f9..7695b8f 100644
--- a/gcc/ada/libgnat/s-rpc.ads
+++ b/gcc/ada/libgnat/s-rpc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/s-scaval.adb b/gcc/ada/libgnat/s-scaval.adb
index 2fe66cf..9815fbd 100644
--- a/gcc/ada/libgnat/s-scaval.adb
+++ b/gcc/ada/libgnat/s-scaval.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-scaval.ads b/gcc/ada/libgnat/s-scaval.ads
index 1b24f70..bd9c9c5 100644
--- a/gcc/ada/libgnat/s-scaval.ads
+++ b/gcc/ada/libgnat/s-scaval.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-secsta.adb b/gcc/ada/libgnat/s-secsta.adb
index 44f2eed..7ec8462 100644
--- a/gcc/ada/libgnat/s-secsta.adb
+++ b/gcc/ada/libgnat/s-secsta.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -564,7 +564,7 @@ package body System.Secondary_Stack is
--------------
function Round_Up (Size : Storage_Count) return Memory_Size is
- Algn_MS : constant Memory_Size := Standard'Maximum_Alignment;
+ Algn_MS : constant Memory_Size := Memory_Alignment;
Size_MS : constant Memory_Size := Memory_Size (Size);
begin
@@ -573,7 +573,7 @@ package body System.Secondary_Stack is
-- Treat this case as secondary-stack depletion.
if Memory_Size'Last - Algn_MS < Size_MS then
- raise Storage_Error with "secondary stack exhaused";
+ raise Storage_Error with "secondary stack exhausted";
end if;
return ((Size_MS + Algn_MS - 1) / Algn_MS) * Algn_MS;
diff --git a/gcc/ada/libgnat/s-secsta.ads b/gcc/ada/libgnat/s-secsta.ads
index d36ecfc..504c891 100644
--- a/gcc/ada/libgnat/s-secsta.ads
+++ b/gcc/ada/libgnat/s-secsta.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -261,10 +261,23 @@ private
subtype Memory_Index is Memory_Size;
-- Index into the memory storage of a single chunk
+ Memory_Alignment : constant := Standard'Maximum_Alignment * 2;
+ -- The memory alignment we will want to honor on every allocation.
+ --
+ -- At this stage, gigi assumes we can accommodate any alignment requirement
+ -- there might be on the data type for which the memory gets allocated (see
+ -- build_call_alloc_dealloc).
+ --
+ -- The multiplication factor is intended to account for requirements
+ -- by user code compiled with specific arch/cpu options such as -mavx
+ -- on X86[_64] targets, which Standard'Maximum_Alignment doesn't convey
+ -- without such compilation options. * 4 would actually be needed to
+ -- support -mavx512f on X86, but this would incur more annoying memory
+ -- consumption overheads.
+
type Chunk_Memory is array (Memory_Size range <>) of SSE.Storage_Element;
- for Chunk_Memory'Alignment use Standard'Maximum_Alignment;
- -- The memory storage of a single chunk. It utilizes maximum alignment in
- -- order to guarantee efficient operations.
+ for Chunk_Memory'Alignment use Memory_Alignment;
+ -- The memory storage of a single chunk
--------------
-- SS_Chunk --
diff --git a/gcc/ada/libgnat/s-sequio.adb b/gcc/ada/libgnat/s-sequio.adb
index e0b54aa..03610e3 100644
--- a/gcc/ada/libgnat/s-sequio.adb
+++ b/gcc/ada/libgnat/s-sequio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-sequio.ads b/gcc/ada/libgnat/s-sequio.ads
index a0b75f5..17ed929 100644
--- a/gcc/ada/libgnat/s-sequio.ads
+++ b/gcc/ada/libgnat/s-sequio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-shabig.ads b/gcc/ada/libgnat/s-shabig.ads
new file mode 100644
index 0000000..c4f6944
--- /dev/null
+++ b/gcc/ada/libgnat/s-shabig.ads
@@ -0,0 +1,80 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . S H A R E D _ B I G N U M S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2012-2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides declarations shared across all instantiations of
+-- System.Generic_Bignums.
+
+with Ada.Unchecked_Conversion;
+with Interfaces;
+
+package System.Shared_Bignums is
+ pragma Preelaborate;
+
+ pragma Assert (Long_Long_Integer'Size = 64);
+ -- This package assumes that Long_Long_Integer size is 64 bit (i.e. that it
+ -- has a range of -2**63 to 2**63-1). The front end ensures that the mode
+ -- ELIMINATED is not allowed for overflow checking if this is not the case.
+
+ subtype Length is Natural range 0 .. 2 ** 23 - 1;
+ -- Represent number of words in Digit_Vector
+
+ Base : constant := 2 ** 32;
+ -- Digit vectors use this base
+
+ subtype SD is Interfaces.Unsigned_32;
+ -- Single length digit
+
+ type Digit_Vector is array (Length range <>) of SD;
+ -- Represent digits of a number (most significant digit first)
+
+ type Bignum_Data (Len : Length) is record
+ Neg : Boolean;
+ -- Set if value is negative, never set for zero
+
+ D : Digit_Vector (1 .. Len);
+ -- Digits of number, most significant first, represented in base
+ -- 2**Base. No leading zeroes are stored, and the value of zero is
+ -- represented using an empty vector for D.
+ end record;
+
+ for Bignum_Data use record
+ Len at 0 range 0 .. 23;
+ Neg at 3 range 0 .. 7;
+ end record;
+
+ type Bignum is access all Bignum_Data;
+
+ function To_Bignum is new Ada.Unchecked_Conversion (System.Address, Bignum);
+
+ function To_Address is new
+ Ada.Unchecked_Conversion (Bignum, System.Address);
+
+end System.Shared_Bignums;
diff --git a/gcc/ada/libgnat/s-shasto.adb b/gcc/ada/libgnat/s-shasto.adb
index a9d0a1c..0117344 100644
--- a/gcc/ada/libgnat/s-shasto.adb
+++ b/gcc/ada/libgnat/s-shasto.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-shasto.ads b/gcc/ada/libgnat/s-shasto.ads
index fae5727..189b5e1 100644
--- a/gcc/ada/libgnat/s-shasto.ads
+++ b/gcc/ada/libgnat/s-shasto.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-soflin.adb b/gcc/ada/libgnat/s-soflin.adb
index 63f7161..7e1a557 100644
--- a/gcc/ada/libgnat/s-soflin.adb
+++ b/gcc/ada/libgnat/s-soflin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-soflin.ads b/gcc/ada/libgnat/s-soflin.ads
index 2125d59..d0caa79 100644
--- a/gcc/ada/libgnat/s-soflin.ads
+++ b/gcc/ada/libgnat/s-soflin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-soliin.adb b/gcc/ada/libgnat/s-soliin.adb
index dbd9e06..f5e4ba7 100644
--- a/gcc/ada/libgnat/s-soliin.adb
+++ b/gcc/ada/libgnat/s-soliin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2017-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2017-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-soliin.ads b/gcc/ada/libgnat/s-soliin.ads
index 7e8b559..2726702 100644
--- a/gcc/ada/libgnat/s-soliin.ads
+++ b/gcc/ada/libgnat/s-soliin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2017-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2017-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-sopco3.adb b/gcc/ada/libgnat/s-sopco3.adb
index 434e496..5953c06 100644
--- a/gcc/ada/libgnat/s-sopco3.adb
+++ b/gcc/ada/libgnat/s-sopco3.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-sopco3.ads b/gcc/ada/libgnat/s-sopco3.ads
index d0595b8..9743938 100644
--- a/gcc/ada/libgnat/s-sopco3.ads
+++ b/gcc/ada/libgnat/s-sopco3.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-sopco4.adb b/gcc/ada/libgnat/s-sopco4.adb
index 9e3332b..5dae861 100644
--- a/gcc/ada/libgnat/s-sopco4.adb
+++ b/gcc/ada/libgnat/s-sopco4.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-sopco4.ads b/gcc/ada/libgnat/s-sopco4.ads
index dcd73c1..0e0f3a3 100644
--- a/gcc/ada/libgnat/s-sopco4.ads
+++ b/gcc/ada/libgnat/s-sopco4.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-sopco5.adb b/gcc/ada/libgnat/s-sopco5.adb
index 075e84c..0acbf3b 100644
--- a/gcc/ada/libgnat/s-sopco5.adb
+++ b/gcc/ada/libgnat/s-sopco5.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-sopco5.ads b/gcc/ada/libgnat/s-sopco5.ads
index 1f7cd71..df233fc 100644
--- a/gcc/ada/libgnat/s-sopco5.ads
+++ b/gcc/ada/libgnat/s-sopco5.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-spsufi.adb b/gcc/ada/libgnat/s-spsufi.adb
index 9aaa389..6702ed1 100644
--- a/gcc/ada/libgnat/s-spsufi.adb
+++ b/gcc/ada/libgnat/s-spsufi.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-spsufi.ads b/gcc/ada/libgnat/s-spsufi.ads
index 55ee06a..d8143ef 100644
--- a/gcc/ada/libgnat/s-spsufi.ads
+++ b/gcc/ada/libgnat/s-spsufi.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-stache.adb b/gcc/ada/libgnat/s-stache.adb
index 587294d..7f55f17 100644
--- a/gcc/ada/libgnat/s-stache.adb
+++ b/gcc/ada/libgnat/s-stache.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-stache.ads b/gcc/ada/libgnat/s-stache.ads
index 18b7bea..45d2da0 100644
--- a/gcc/ada/libgnat/s-stache.ads
+++ b/gcc/ada/libgnat/s-stache.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-stalib.adb b/gcc/ada/libgnat/s-stalib.adb
index cee4397..61636d1 100644
--- a/gcc/ada/libgnat/s-stalib.adb
+++ b/gcc/ada/libgnat/s-stalib.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-stalib.ads b/gcc/ada/libgnat/s-stalib.ads
index d1ed160..5fbedae 100644
--- a/gcc/ada/libgnat/s-stalib.ads
+++ b/gcc/ada/libgnat/s-stalib.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -81,6 +81,7 @@ package System.Standard_Library is
-------------------------------------
type Raise_Action is access procedure;
+ pragma Favor_Top_Level (Raise_Action);
-- A pointer to a procedure used in the Raise_Hook field
type Exception_Data;
diff --git a/gcc/ada/libgnat/s-stratt__xdr.adb b/gcc/ada/libgnat/s-statxd.adb
index 98e21a1..fcefae7 100644
--- a/gcc/ada/libgnat/s-stratt__xdr.adb
+++ b/gcc/ada/libgnat/s-statxd.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- S Y S T E M . S T R E A M _ A T T R I B U T E S --
+-- S Y S T E M . S T R E A M _ A T T R I B U T E S . X D R --
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GARLIC is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,20 +29,11 @@
-- --
------------------------------------------------------------------------------
--- This file is an alternate version of s-stratt.adb based on the XDR
--- standard. It is especially useful for exchanging streams between two
--- different systems with different basic type representations and endianness.
-
-pragma Warnings (Off, "*not allowed in compiler unit");
--- This body is used only when rebuilding the runtime library, not when
--- building the compiler, so it's OK to depend on features that would
--- otherwise break bootstrap (e.g. IF-expressions).
-
with Ada.IO_Exceptions;
with Ada.Streams; use Ada.Streams;
with Ada.Unchecked_Conversion;
-package body System.Stream_Attributes is
+package body System.Stream_Attributes.XDR is
pragma Suppress (Range_Check);
pragma Suppress (Overflow_Check);
@@ -68,19 +59,16 @@ package body System.Stream_Attributes is
subtype SEA is Ada.Streams.Stream_Element_Array;
subtype SEO is Ada.Streams.Stream_Element_Offset;
- generic function UC renames Ada.Unchecked_Conversion;
-
- type Field_Type is
- record
- E_Size : Integer; -- Exponent bit size
- E_Bias : Integer; -- Exponent bias
- F_Size : Integer; -- Fraction bit size
- E_Last : Integer; -- Max exponent value
- F_Mask : SE; -- Mask to apply on first fraction byte
- E_Bytes : SEO; -- N. of exponent bytes completely used
- F_Bytes : SEO; -- N. of fraction bytes completely used
- F_Bits : Integer; -- N. of bits used on first fraction word
- end record;
+ type Field_Type is record
+ E_Size : Integer; -- Exponent bit size
+ E_Bias : Integer; -- Exponent bias
+ F_Size : Integer; -- Fraction bit size
+ E_Last : Integer; -- Max exponent value
+ F_Mask : SE; -- Mask to apply on first fraction byte
+ E_Bytes : SEO; -- N. of exponent bytes completely used
+ F_Bytes : SEO; -- N. of fraction bytes completely used
+ F_Bits : Integer; -- N. of bits used on first fraction word
+ end record;
type Precision is (Single, Double, Quadruple);
@@ -139,40 +127,47 @@ package body System.Stream_Attributes is
SSI_L : constant := 1;
SI_L : constant := 2;
+ I24_L : constant := 3;
I_L : constant := 4;
LI_L : constant := 8;
LLI_L : constant := 8;
subtype XDR_S_SSI is SEA (1 .. SSI_L);
subtype XDR_S_SI is SEA (1 .. SI_L);
+ subtype XDR_S_I24 is SEA (1 .. I24_L);
subtype XDR_S_I is SEA (1 .. I_L);
subtype XDR_S_LI is SEA (1 .. LI_L);
subtype XDR_S_LLI is SEA (1 .. LLI_L);
function Short_Short_Integer_To_XDR_S_SSI is
- new Ada.Unchecked_Conversion (Short_Short_Integer, XDR_S_SSI);
+ new Ada.Unchecked_Conversion (Short_Short_Integer, XDR_S_SSI);
function XDR_S_SSI_To_Short_Short_Integer is
- new Ada.Unchecked_Conversion (XDR_S_SSI, Short_Short_Integer);
+ new Ada.Unchecked_Conversion (XDR_S_SSI, Short_Short_Integer);
function Short_Integer_To_XDR_S_SI is
- new Ada.Unchecked_Conversion (Short_Integer, XDR_S_SI);
+ new Ada.Unchecked_Conversion (Short_Integer, XDR_S_SI);
function XDR_S_SI_To_Short_Integer is
- new Ada.Unchecked_Conversion (XDR_S_SI, Short_Integer);
+ new Ada.Unchecked_Conversion (XDR_S_SI, Short_Integer);
+
+ function Integer_To_XDR_S_I24 is
+ new Ada.Unchecked_Conversion (Integer_24, XDR_S_I24);
+ function XDR_S_I24_To_Integer is
+ new Ada.Unchecked_Conversion (XDR_S_I24, Integer_24);
function Integer_To_XDR_S_I is
- new Ada.Unchecked_Conversion (Integer, XDR_S_I);
+ new Ada.Unchecked_Conversion (Integer, XDR_S_I);
function XDR_S_I_To_Integer is
new Ada.Unchecked_Conversion (XDR_S_I, Integer);
function Long_Long_Integer_To_XDR_S_LI is
- new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LI);
+ new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LI);
function XDR_S_LI_To_Long_Long_Integer is
- new Ada.Unchecked_Conversion (XDR_S_LI, Long_Long_Integer);
+ new Ada.Unchecked_Conversion (XDR_S_LI, Long_Long_Integer);
function Long_Long_Integer_To_XDR_S_LLI is
- new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LLI);
+ new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LLI);
function XDR_S_LLI_To_Long_Long_Integer is
- new Ada.Unchecked_Conversion (XDR_S_LLI, Long_Long_Integer);
+ new Ada.Unchecked_Conversion (XDR_S_LLI, Long_Long_Integer);
-- An XDR unsigned integer is a 32-bit datum that encodes a nonnegative
-- integer in the range [0,4294967295]. It is represented by an unsigned
@@ -187,12 +182,14 @@ package body System.Stream_Attributes is
SSU_L : constant := 1;
SU_L : constant := 2;
+ U24_L : constant := 3;
U_L : constant := 4;
LU_L : constant := 8;
LLU_L : constant := 8;
subtype XDR_S_SSU is SEA (1 .. SSU_L);
subtype XDR_S_SU is SEA (1 .. SU_L);
+ subtype XDR_S_U24 is SEA (1 .. U24_L);
subtype XDR_S_U is SEA (1 .. U_L);
subtype XDR_S_LU is SEA (1 .. LU_L);
subtype XDR_S_LLU is SEA (1 .. LLU_L);
@@ -200,26 +197,32 @@ package body System.Stream_Attributes is
type XDR_SSU is mod BB ** SSU_L;
type XDR_SU is mod BB ** SU_L;
type XDR_U is mod BB ** U_L;
+ type XDR_U24 is mod BB ** U24_L;
function Short_Unsigned_To_XDR_S_SU is
- new Ada.Unchecked_Conversion (Short_Unsigned, XDR_S_SU);
+ new Ada.Unchecked_Conversion (Short_Unsigned, XDR_S_SU);
function XDR_S_SU_To_Short_Unsigned is
- new Ada.Unchecked_Conversion (XDR_S_SU, Short_Unsigned);
+ new Ada.Unchecked_Conversion (XDR_S_SU, Short_Unsigned);
+
+ function Unsigned_To_XDR_S_U24 is
+ new Ada.Unchecked_Conversion (Unsigned_24, XDR_S_U24);
+ function XDR_S_U24_To_Unsigned is
+ new Ada.Unchecked_Conversion (XDR_S_U24, Unsigned_24);
function Unsigned_To_XDR_S_U is
- new Ada.Unchecked_Conversion (Unsigned, XDR_S_U);
+ new Ada.Unchecked_Conversion (Unsigned, XDR_S_U);
function XDR_S_U_To_Unsigned is
- new Ada.Unchecked_Conversion (XDR_S_U, Unsigned);
+ new Ada.Unchecked_Conversion (XDR_S_U, Unsigned);
function Long_Long_Unsigned_To_XDR_S_LU is
- new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LU);
+ new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LU);
function XDR_S_LU_To_Long_Long_Unsigned is
- new Ada.Unchecked_Conversion (XDR_S_LU, Long_Long_Unsigned);
+ new Ada.Unchecked_Conversion (XDR_S_LU, Long_Long_Unsigned);
function Long_Long_Unsigned_To_XDR_S_LLU is
- new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LLU);
+ new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LLU);
function XDR_S_LLU_To_Long_Long_Unsigned is
- new Ada.Unchecked_Conversion (XDR_S_LLU, Long_Long_Unsigned);
+ new Ada.Unchecked_Conversion (XDR_S_LLU, Long_Long_Unsigned);
-- The standard defines the floating-point data type "float" (32 bits
-- or 4 bytes). The encoding used is the IEEE standard for normalized
@@ -240,8 +243,8 @@ package body System.Stream_Attributes is
type XDR_TM is mod BB ** TM_L;
type XDR_SA is mod 2 ** Standard'Address_Size;
- function To_XDR_SA is new UC (System.Address, XDR_SA);
- function To_XDR_SA is new UC (XDR_SA, System.Address);
+ function To_XDR_SA is new Ada.Unchecked_Conversion (System.Address, XDR_SA);
+ function To_XDR_SA is new Ada.Unchecked_Conversion (XDR_SA, System.Address);
-- Enumerations have the same representation as signed integers.
-- Enumerations are handy for describing subsets of the integers.
@@ -284,19 +287,6 @@ package body System.Stream_Attributes is
Optimize_Integers : constant Boolean :=
Default_Bit_Order = High_Order_First;
- -----------------
- -- Block_IO_OK --
- -----------------
-
- -- We must inhibit Block_IO, because in XDR mode, each element is output
- -- according to XDR requirements, which is not at all the same as writing
- -- the whole array in one block.
-
- function Block_IO_OK return Boolean is
- begin
- return False;
- end Block_IO_OK;
-
----------
-- I_AD --
----------
@@ -484,6 +474,40 @@ package body System.Stream_Attributes is
end if;
end I_I;
+ -----------
+ -- I_I24 --
+ -----------
+
+ function I_I24 (Stream : not null access RST) return Integer_24 is
+ S : XDR_S_I24;
+ L : SEO;
+ U : XDR_U24 := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ elsif Optimize_Integers then
+ return XDR_S_I24_To_Integer (S);
+
+ else
+ for N in S'Range loop
+ U := U * BB + XDR_U24 (S (N));
+ end loop;
+
+ -- Test sign and apply two complement notation
+
+ if S (1) < BL then
+ return Integer_24 (U);
+
+ else
+ return Integer_24 (-((XDR_U24'Last xor U) + 1));
+ end if;
+ end if;
+ end I_I24;
+
----------
-- I_LF --
----------
@@ -1042,6 +1066,33 @@ package body System.Stream_Attributes is
end if;
end I_U;
+ -----------
+ -- I_U24 --
+ -----------
+
+ function I_U24 (Stream : not null access RST) return Unsigned_24 is
+ S : XDR_S_U24;
+ L : SEO;
+ U : XDR_U24 := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ elsif Optimize_Integers then
+ return XDR_S_U24_To_Unsigned (S);
+
+ else
+ for N in S'Range loop
+ U := U * BB + XDR_U24 (S (N));
+ end loop;
+
+ return Unsigned_24 (U);
+ end if;
+ end I_U24;
+
----------
-- I_WC --
----------
@@ -1289,6 +1340,38 @@ package body System.Stream_Attributes is
Ada.Streams.Write (Stream.all, S);
end W_I;
+ -----------
+ -- W_I24 --
+ -----------
+
+ procedure W_I24 (Stream : not null access RST; Item : Integer_24) is
+ S : XDR_S_I24;
+ U : XDR_U24;
+
+ begin
+ if Optimize_Integers then
+ S := Integer_To_XDR_S_I24 (Item);
+
+ else
+ -- Test sign and apply two complement notation
+
+ U := (if Item < 0
+ then XDR_U24'Last xor XDR_U24 (-(Item + 1))
+ else XDR_U24 (Item));
+
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_I24;
+
----------
-- W_LF --
----------
@@ -1377,7 +1460,7 @@ package body System.Stream_Attributes is
procedure W_LI (Stream : not null access RST; Item : Long_Integer) is
S : XDR_S_LI;
- U : Unsigned;
+ U : Unsigned := 0;
X : Long_Unsigned;
begin
@@ -1521,7 +1604,7 @@ package body System.Stream_Attributes is
Item : Long_Long_Integer)
is
S : XDR_S_LLI;
- U : Unsigned;
+ U : Unsigned := 0;
X : Long_Long_Unsigned;
begin
@@ -1569,7 +1652,7 @@ package body System.Stream_Attributes is
Item : Long_Long_Unsigned)
is
S : XDR_S_LLU;
- U : Unsigned;
+ U : Unsigned := 0;
X : Long_Long_Unsigned := Item;
begin
@@ -1606,7 +1689,7 @@ package body System.Stream_Attributes is
procedure W_LU (Stream : not null access RST; Item : Long_Unsigned) is
S : XDR_S_LU;
- U : Unsigned;
+ U : Unsigned := 0;
X : Long_Unsigned := Item;
begin
@@ -1846,6 +1929,32 @@ package body System.Stream_Attributes is
Ada.Streams.Write (Stream.all, S);
end W_U;
+ -----------
+ -- W_U24 --
+ -----------
+
+ procedure W_U24 (Stream : not null access RST; Item : Unsigned_24) is
+ S : XDR_S_U24;
+ U : XDR_U24 := XDR_U24 (Item);
+
+ begin
+ if Optimize_Integers then
+ S := Unsigned_To_XDR_S_U24 (Item);
+
+ else
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_U24;
+
----------
-- W_WC --
----------
@@ -1898,4 +2007,4 @@ package body System.Stream_Attributes is
end if;
end W_WWC;
-end System.Stream_Attributes;
+end System.Stream_Attributes.XDR;
diff --git a/gcc/ada/libgnat/s-statxd.ads b/gcc/ada/libgnat/s-statxd.ads
new file mode 100644
index 0000000..cca5e54
--- /dev/null
+++ b/gcc/ada/libgnat/s-statxd.ads
@@ -0,0 +1,117 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . S T R E A M _ A T T R I B U T E S . X D R --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains alternate implementations of the stream attributes
+-- for elementary types based on the XDR standard. These are the subprograms
+-- that are directly accessed by occurrences of the stream attributes where
+-- the type is elementary.
+
+-- It is especially useful for exchanging streams between two different
+-- systems with different basic type representations and endianness.
+
+-- We only provide the subprograms for the standard base types. For user
+-- defined types, the subprogram for the corresponding root type is called
+-- with an appropriate conversion.
+
+package System.Stream_Attributes.XDR is
+ pragma Preelaborate;
+
+ pragma Suppress (Accessibility_Check, XDR);
+ -- No need to check accessibility on arguments of subprograms
+
+ ---------------------
+ -- Input Functions --
+ ---------------------
+
+ -- Functions for S'Input attribute. These functions are also used for
+ -- S'Read, with the obvious transformation, since the input operation
+ -- is the same for all elementary types (no bounds or discriminants
+ -- are involved).
+
+ function I_AD (Stream : not null access RST) return Fat_Pointer;
+ function I_AS (Stream : not null access RST) return Thin_Pointer;
+ function I_B (Stream : not null access RST) return Boolean;
+ function I_C (Stream : not null access RST) return Character;
+ function I_F (Stream : not null access RST) return Float;
+ function I_I (Stream : not null access RST) return Integer;
+ function I_I24 (Stream : not null access RST) return Integer_24;
+ function I_LF (Stream : not null access RST) return Long_Float;
+ function I_LI (Stream : not null access RST) return Long_Integer;
+ function I_LLF (Stream : not null access RST) return Long_Long_Float;
+ function I_LLI (Stream : not null access RST) return Long_Long_Integer;
+ function I_LLU (Stream : not null access RST) return UST.Long_Long_Unsigned;
+ function I_LU (Stream : not null access RST) return UST.Long_Unsigned;
+ function I_SF (Stream : not null access RST) return Short_Float;
+ function I_SI (Stream : not null access RST) return Short_Integer;
+ function I_SSI (Stream : not null access RST) return Short_Short_Integer;
+ function I_SSU (Stream : not null access RST) return
+ UST.Short_Short_Unsigned;
+ function I_SU (Stream : not null access RST) return UST.Short_Unsigned;
+ function I_U (Stream : not null access RST) return UST.Unsigned;
+ function I_U24 (Stream : not null access RST) return Unsigned_24;
+ function I_WC (Stream : not null access RST) return Wide_Character;
+ function I_WWC (Stream : not null access RST) return Wide_Wide_Character;
+
+ -----------------------
+ -- Output Procedures --
+ -----------------------
+
+ -- Procedures for S'Write attribute. These procedures are also used for
+ -- 'Output, since for elementary types there is no difference between
+ -- 'Write and 'Output because there are no discriminants or bounds to
+ -- be written.
+
+ procedure W_AD (Stream : not null access RST; Item : Fat_Pointer);
+ procedure W_AS (Stream : not null access RST; Item : Thin_Pointer);
+ procedure W_B (Stream : not null access RST; Item : Boolean);
+ procedure W_C (Stream : not null access RST; Item : Character);
+ procedure W_F (Stream : not null access RST; Item : Float);
+ procedure W_I (Stream : not null access RST; Item : Integer);
+ procedure W_I24 (Stream : not null access RST; Item : Integer_24);
+ procedure W_LF (Stream : not null access RST; Item : Long_Float);
+ procedure W_LI (Stream : not null access RST; Item : Long_Integer);
+ procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float);
+ procedure W_LLI (Stream : not null access RST; Item : Long_Long_Integer);
+ procedure W_LLU (Stream : not null access RST; Item :
+ UST.Long_Long_Unsigned);
+ procedure W_LU (Stream : not null access RST; Item : UST.Long_Unsigned);
+ procedure W_SF (Stream : not null access RST; Item : Short_Float);
+ procedure W_SI (Stream : not null access RST; Item : Short_Integer);
+ procedure W_SSI (Stream : not null access RST; Item : Short_Short_Integer);
+ procedure W_SSU (Stream : not null access RST; Item :
+ UST.Short_Short_Unsigned);
+ procedure W_SU (Stream : not null access RST; Item : UST.Short_Unsigned);
+ procedure W_U (Stream : not null access RST; Item : UST.Unsigned);
+ procedure W_U24 (Stream : not null access RST; Item : Unsigned_24);
+ procedure W_WC (Stream : not null access RST; Item : Wide_Character);
+ procedure W_WWC (Stream : not null access RST; Item : Wide_Wide_Character);
+
+end System.Stream_Attributes.XDR;
diff --git a/gcc/ada/libgnat/s-stausa.adb b/gcc/ada/libgnat/s-stausa.adb
index 597634a..e96dc7a 100644
--- a/gcc/ada/libgnat/s-stausa.adb
+++ b/gcc/ada/libgnat/s-stausa.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-stausa.ads b/gcc/ada/libgnat/s-stausa.ads
index 2dfa735..8803237 100644
--- a/gcc/ada/libgnat/s-stausa.ads
+++ b/gcc/ada/libgnat/s-stausa.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-stchop.adb b/gcc/ada/libgnat/s-stchop.adb
index ecfa5f1..c5c3d35 100644
--- a/gcc/ada/libgnat/s-stchop.adb
+++ b/gcc/ada/libgnat/s-stchop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-stchop.ads b/gcc/ada/libgnat/s-stchop.ads
index 11f0e74..d057ddb 100644
--- a/gcc/ada/libgnat/s-stchop.ads
+++ b/gcc/ada/libgnat/s-stchop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-stchop__limit.ads b/gcc/ada/libgnat/s-stchop__limit.ads
index 9d70a57..c904606 100644
--- a/gcc/ada/libgnat/s-stchop__limit.ads
+++ b/gcc/ada/libgnat/s-stchop__limit.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-stchop__rtems.adb b/gcc/ada/libgnat/s-stchop__rtems.adb
index 66b175f..56b1747 100644
--- a/gcc/ada/libgnat/s-stchop__rtems.adb
+++ b/gcc/ada/libgnat/s-stchop__rtems.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-stchop__vxworks.adb b/gcc/ada/libgnat/s-stchop__vxworks.adb
index 49f02d8..f277426 100644
--- a/gcc/ada/libgnat/s-stchop__vxworks.adb
+++ b/gcc/ada/libgnat/s-stchop__vxworks.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-stoele.adb b/gcc/ada/libgnat/s-stoele.adb
index 8a00f7f..69cb832 100644
--- a/gcc/ada/libgnat/s-stoele.adb
+++ b/gcc/ada/libgnat/s-stoele.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-stoele.ads b/gcc/ada/libgnat/s-stoele.ads
index cf9a826..4abac8e 100644
--- a/gcc/ada/libgnat/s-stoele.ads
+++ b/gcc/ada/libgnat/s-stoele.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/s-stopoo.adb b/gcc/ada/libgnat/s-stopoo.adb
index a3eec3b..a9590d4 100644
--- a/gcc/ada/libgnat/s-stopoo.adb
+++ b/gcc/ada/libgnat/s-stopoo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-stopoo.ads b/gcc/ada/libgnat/s-stopoo.ads
index 74dd8bb..b79a038f 100644
--- a/gcc/ada/libgnat/s-stopoo.ads
+++ b/gcc/ada/libgnat/s-stopoo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -36,9 +36,9 @@
with Ada.Finalization;
with System.Storage_Elements;
-package System.Storage_Pools is
- pragma Preelaborate;
-
+package System.Storage_Pools
+ with Pure
+is
type Root_Storage_Pool is abstract
new Ada.Finalization.Limited_Controlled with private;
pragma Preelaborable_Initialization (Root_Storage_Pool);
diff --git a/gcc/ada/libgnat/s-stposu.adb b/gcc/ada/libgnat/s-stposu.adb
index 64d8aff..ff61cfb 100644
--- a/gcc/ada/libgnat/s-stposu.adb
+++ b/gcc/ada/libgnat/s-stposu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -117,11 +117,12 @@ package body System.Storage_Pools.Subpools is
Is_Subpool_Allocation : constant Boolean :=
Pool in Root_Storage_Pool_With_Subpools'Class;
- Master : Finalization_Master_Ptr := null;
- N_Addr : Address;
- N_Ptr : FM_Node_Ptr;
- N_Size : Storage_Count;
- Subpool : Subpool_Handle := null;
+ Master : Finalization_Master_Ptr := null;
+ N_Addr : Address;
+ N_Ptr : FM_Node_Ptr;
+ N_Size : Storage_Count;
+ Subpool : Subpool_Handle := null;
+ Lock_Taken : Boolean := False;
Header_And_Padding : Storage_Offset;
-- This offset includes the size of a FM_Node plus any additional
@@ -205,6 +206,7 @@ package body System.Storage_Pools.Subpools is
-- Read - allocation, finalization
-- Write - finalization
+ Lock_Taken := True;
Lock_Task.all;
-- Do not allow the allocation of controlled objects while the
@@ -322,6 +324,7 @@ package body System.Storage_Pools.Subpools is
end if;
Unlock_Task.all;
+ Lock_Taken := False;
-- Non-controlled allocation
@@ -335,7 +338,7 @@ package body System.Storage_Pools.Subpools is
-- Unlock the task in case the allocation step failed and reraise the
-- exception.
- if Is_Controlled then
+ if Lock_Taken then
Unlock_Task.all;
end if;
diff --git a/gcc/ada/libgnat/s-stposu.ads b/gcc/ada/libgnat/s-stposu.ads
index ddb116c..2653f3d 100644
--- a/gcc/ada/libgnat/s-stposu.ads
+++ b/gcc/ada/libgnat/s-stposu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -42,12 +42,14 @@ package System.Storage_Pools.Subpools is
type Root_Storage_Pool_With_Subpools is abstract
new Root_Storage_Pool with private;
+ pragma Preelaborable_Initialization (Root_Storage_Pool_With_Subpools);
-- The base for all implementations of Storage_Pool_With_Subpools. This
-- type is Limited_Controlled by derivation. To use subpools, an access
-- type must be associated with an implementation descending from type
-- Root_Storage_Pool_With_Subpools.
type Root_Subpool is abstract tagged limited private;
+ pragma Preelaborable_Initialization (Root_Subpool);
-- The base for all implementations of Subpool. Objects of this type are
-- managed by the pool_with_subpools.
diff --git a/gcc/ada/libgnat/s-stratt.adb b/gcc/ada/libgnat/s-stratt.adb
index d4a1516..366dabd 100644
--- a/gcc/ada/libgnat/s-stratt.adb
+++ b/gcc/ada/libgnat/s-stratt.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,9 +32,20 @@
with Ada.IO_Exceptions;
with Ada.Streams; use Ada.Streams;
with Ada.Unchecked_Conversion;
+with System.Stream_Attributes.XDR;
package body System.Stream_Attributes is
+ XDR_Flag : Integer;
+ pragma Import (C, XDR_Flag, "__gl_xdr_stream");
+ -- This imported value is used to determine whether the build had the
+ -- binder switch "-xdr" present which enables XDR streaming and sets this
+ -- flag to 1.
+
+ function XDR_Support return Boolean;
+ pragma Inline (XDR_Support);
+ -- Return True if XDR streaming should be used
+
Err : exception renames Ada.IO_Exceptions.End_Error;
-- Exception raised if insufficient data read (note that the RM implies
-- that Data_Error might be the appropriate choice, but AI95-00132
@@ -59,6 +70,7 @@ package body System.Stream_Attributes is
subtype S_C is SEA (1 .. (Character'Size + SU - 1) / SU);
subtype S_F is SEA (1 .. (Float'Size + SU - 1) / SU);
subtype S_I is SEA (1 .. (Integer'Size + SU - 1) / SU);
+ subtype S_I24 is SEA (1 .. (Integer_24'Size + SU - 1) / SU);
subtype S_LF is SEA (1 .. (Long_Float'Size + SU - 1) / SU);
subtype S_LI is SEA (1 .. (Long_Integer'Size + SU - 1) / SU);
subtype S_LLF is SEA (1 .. (Long_Long_Float'Size + SU - 1) / SU);
@@ -71,6 +83,7 @@ package body System.Stream_Attributes is
subtype S_SSU is SEA (1 .. (UST.Short_Short_Unsigned'Size + SU - 1) / SU);
subtype S_SU is SEA (1 .. (UST.Short_Unsigned'Size + SU - 1) / SU);
subtype S_U is SEA (1 .. (UST.Unsigned'Size + SU - 1) / SU);
+ subtype S_U24 is SEA (1 .. (Unsigned_24'Size + SU - 1) / SU);
subtype S_WC is SEA (1 .. (Wide_Character'Size + SU - 1) / SU);
subtype S_WWC is SEA (1 .. (Wide_Wide_Character'Size + SU - 1) / SU);
@@ -80,6 +93,7 @@ package body System.Stream_Attributes is
function From_AS is new UC (Thin_Pointer, S_AS);
function From_F is new UC (Float, S_F);
function From_I is new UC (Integer, S_I);
+ function From_I24 is new UC (Integer_24, S_I24);
function From_LF is new UC (Long_Float, S_LF);
function From_LI is new UC (Long_Integer, S_LI);
function From_LLF is new UC (Long_Long_Float, S_LLF);
@@ -92,6 +106,7 @@ package body System.Stream_Attributes is
function From_SSU is new UC (UST.Short_Short_Unsigned, S_SSU);
function From_SU is new UC (UST.Short_Unsigned, S_SU);
function From_U is new UC (UST.Unsigned, S_U);
+ function From_U24 is new UC (Unsigned_24, S_U24);
function From_WC is new UC (Wide_Character, S_WC);
function From_WWC is new UC (Wide_Wide_Character, S_WWC);
@@ -101,6 +116,7 @@ package body System.Stream_Attributes is
function To_AS is new UC (S_AS, Thin_Pointer);
function To_F is new UC (S_F, Float);
function To_I is new UC (S_I, Integer);
+ function To_I24 is new UC (S_I24, Integer_24);
function To_LF is new UC (S_LF, Long_Float);
function To_LI is new UC (S_LI, Long_Integer);
function To_LLF is new UC (S_LLF, Long_Long_Float);
@@ -113,16 +129,26 @@ package body System.Stream_Attributes is
function To_SSU is new UC (S_SSU, UST.Short_Short_Unsigned);
function To_SU is new UC (S_SU, UST.Short_Unsigned);
function To_U is new UC (S_U, UST.Unsigned);
+ function To_U24 is new UC (S_U24, Unsigned_24);
function To_WC is new UC (S_WC, Wide_Character);
function To_WWC is new UC (S_WWC, Wide_Wide_Character);
-----------------
+ -- XDR_Support --
+ -----------------
+
+ function XDR_Support return Boolean is
+ begin
+ return XDR_Flag = 1;
+ end XDR_Support;
+
+ -----------------
-- Block_IO_OK --
-----------------
function Block_IO_OK return Boolean is
begin
- return True;
+ return not XDR_Support;
end Block_IO_OK;
----------
@@ -134,6 +160,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_AD (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -152,6 +182,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_AS (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -170,6 +204,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_B (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -188,6 +226,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_C (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -206,6 +248,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_F (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -224,6 +270,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_I (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -233,6 +283,28 @@ package body System.Stream_Attributes is
end if;
end I_I;
+ -----------
+ -- I_I24 --
+ -----------
+
+ function I_I24 (Stream : not null access RST) return Integer_24 is
+ T : S_I24;
+ L : SEO;
+
+ begin
+ if XDR_Support then
+ return XDR.I_I24 (Stream);
+ end if;
+
+ Ada.Streams.Read (Stream.all, T, L);
+
+ if L < T'Last then
+ raise Err;
+ else
+ return To_I24 (T);
+ end if;
+ end I_I24;
+
----------
-- I_LF --
----------
@@ -242,6 +314,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_LF (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -260,6 +336,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_LI (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -278,6 +358,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_LLF (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -296,6 +380,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_LLI (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -316,6 +404,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_LLU (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -334,6 +426,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_LU (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -352,6 +448,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_SF (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -370,6 +470,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_SI (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -388,6 +492,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_SSI (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -408,6 +516,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_SSU (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -426,6 +538,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_SU (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -444,6 +560,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_U (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -453,6 +573,28 @@ package body System.Stream_Attributes is
end if;
end I_U;
+ -----------
+ -- I_U24 --
+ -----------
+
+ function I_U24 (Stream : not null access RST) return Unsigned_24 is
+ T : S_U24;
+ L : SEO;
+
+ begin
+ if XDR_Support then
+ return XDR.I_U24 (Stream);
+ end if;
+
+ Ada.Streams.Read (Stream.all, T, L);
+
+ if L < T'Last then
+ raise Err;
+ else
+ return To_U24 (T);
+ end if;
+ end I_U24;
+
----------
-- I_WC --
----------
@@ -462,6 +604,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_WC (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -480,6 +626,10 @@ package body System.Stream_Attributes is
L : SEO;
begin
+ if XDR_Support then
+ return XDR.I_WWC (Stream);
+ end if;
+
Ada.Streams.Read (Stream.all, T, L);
if L < T'Last then
@@ -496,6 +646,11 @@ package body System.Stream_Attributes is
procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is
T : constant S_AD := From_AD (Item);
begin
+ if XDR_Support then
+ XDR.W_AD (Stream, Item);
+ return;
+ end if;
+
Ada.Streams.Write (Stream.all, T);
end W_AD;
@@ -506,6 +661,11 @@ package body System.Stream_Attributes is
procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is
T : constant S_AS := From_AS (Item);
begin
+ if XDR_Support then
+ XDR.W_AS (Stream, Item);
+ return;
+ end if;
+
Ada.Streams.Write (Stream.all, T);
end W_AS;
@@ -516,6 +676,11 @@ package body System.Stream_Attributes is
procedure W_B (Stream : not null access RST; Item : Boolean) is
T : S_B;
begin
+ if XDR_Support then
+ XDR.W_B (Stream, Item);
+ return;
+ end if;
+
T (1) := Boolean'Pos (Item);
Ada.Streams.Write (Stream.all, T);
end W_B;
@@ -527,6 +692,11 @@ package body System.Stream_Attributes is
procedure W_C (Stream : not null access RST; Item : Character) is
T : S_C;
begin
+ if XDR_Support then
+ XDR.W_C (Stream, Item);
+ return;
+ end if;
+
T (1) := Character'Pos (Item);
Ada.Streams.Write (Stream.all, T);
end W_C;
@@ -536,9 +706,13 @@ package body System.Stream_Attributes is
---------
procedure W_F (Stream : not null access RST; Item : Float) is
- T : constant S_F := From_F (Item);
begin
- Ada.Streams.Write (Stream.all, T);
+ if XDR_Support then
+ XDR.W_F (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_F (Item));
end W_F;
---------
@@ -546,19 +720,41 @@ package body System.Stream_Attributes is
---------
procedure W_I (Stream : not null access RST; Item : Integer) is
- T : constant S_I := From_I (Item);
begin
- Ada.Streams.Write (Stream.all, T);
+ if XDR_Support then
+ XDR.W_I (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_I (Item));
end W_I;
+ -----------
+ -- W_I24 --
+ -----------
+
+ procedure W_I24 (Stream : not null access RST; Item : Integer_24) is
+ begin
+ if XDR_Support then
+ XDR.W_I24 (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_I24 (Item));
+ end W_I24;
+
----------
-- W_LF --
----------
procedure W_LF (Stream : not null access RST; Item : Long_Float) is
- T : constant S_LF := From_LF (Item);
begin
- Ada.Streams.Write (Stream.all, T);
+ if XDR_Support then
+ XDR.W_LF (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_LF (Item));
end W_LF;
----------
@@ -566,9 +762,13 @@ package body System.Stream_Attributes is
----------
procedure W_LI (Stream : not null access RST; Item : Long_Integer) is
- T : constant S_LI := From_LI (Item);
begin
- Ada.Streams.Write (Stream.all, T);
+ if XDR_Support then
+ XDR.W_LI (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_LI (Item));
end W_LI;
-----------
@@ -576,21 +776,27 @@ package body System.Stream_Attributes is
-----------
procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is
- T : constant S_LLF := From_LLF (Item);
begin
- Ada.Streams.Write (Stream.all, T);
+ if XDR_Support then
+ XDR.W_LLF (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_LLF (Item));
end W_LLF;
-----------
-- W_LLI --
-----------
- procedure W_LLI
- (Stream : not null access RST; Item : Long_Long_Integer)
- is
- T : constant S_LLI := From_LLI (Item);
+ procedure W_LLI (Stream : not null access RST; Item : Long_Long_Integer) is
begin
- Ada.Streams.Write (Stream.all, T);
+ if XDR_Support then
+ XDR.W_LLI (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_LLI (Item));
end W_LLI;
-----------
@@ -600,21 +806,27 @@ package body System.Stream_Attributes is
procedure W_LLU
(Stream : not null access RST; Item : UST.Long_Long_Unsigned)
is
- T : constant S_LLU := From_LLU (Item);
begin
- Ada.Streams.Write (Stream.all, T);
+ if XDR_Support then
+ XDR.W_LLU (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_LLU (Item));
end W_LLU;
----------
-- W_LU --
----------
- procedure W_LU
- (Stream : not null access RST; Item : UST.Long_Unsigned)
- is
- T : constant S_LU := From_LU (Item);
+ procedure W_LU (Stream : not null access RST; Item : UST.Long_Unsigned) is
begin
- Ada.Streams.Write (Stream.all, T);
+ if XDR_Support then
+ XDR.W_LU (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_LU (Item));
end W_LU;
----------
@@ -622,9 +834,13 @@ package body System.Stream_Attributes is
----------
procedure W_SF (Stream : not null access RST; Item : Short_Float) is
- T : constant S_SF := From_SF (Item);
begin
- Ada.Streams.Write (Stream.all, T);
+ if XDR_Support then
+ XDR.W_SF (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_SF (Item));
end W_SF;
----------
@@ -632,9 +848,13 @@ package body System.Stream_Attributes is
----------
procedure W_SI (Stream : not null access RST; Item : Short_Integer) is
- T : constant S_SI := From_SI (Item);
begin
- Ada.Streams.Write (Stream.all, T);
+ if XDR_Support then
+ XDR.W_SI (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_SI (Item));
end W_SI;
-----------
@@ -644,9 +864,13 @@ package body System.Stream_Attributes is
procedure W_SSI
(Stream : not null access RST; Item : Short_Short_Integer)
is
- T : constant S_SSI := From_SSI (Item);
begin
- Ada.Streams.Write (Stream.all, T);
+ if XDR_Support then
+ XDR.W_SSI (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_SSI (Item));
end W_SSI;
-----------
@@ -656,21 +880,27 @@ package body System.Stream_Attributes is
procedure W_SSU
(Stream : not null access RST; Item : UST.Short_Short_Unsigned)
is
- T : constant S_SSU := From_SSU (Item);
begin
- Ada.Streams.Write (Stream.all, T);
+ if XDR_Support then
+ XDR.W_SSU (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_SSU (Item));
end W_SSU;
----------
-- W_SU --
----------
- procedure W_SU
- (Stream : not null access RST; Item : UST.Short_Unsigned)
- is
- T : constant S_SU := From_SU (Item);
+ procedure W_SU (Stream : not null access RST; Item : UST.Short_Unsigned) is
begin
- Ada.Streams.Write (Stream.all, T);
+ if XDR_Support then
+ XDR.W_SU (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_SU (Item));
end W_SU;
---------
@@ -678,19 +908,41 @@ package body System.Stream_Attributes is
---------
procedure W_U (Stream : not null access RST; Item : UST.Unsigned) is
- T : constant S_U := From_U (Item);
begin
- Ada.Streams.Write (Stream.all, T);
+ if XDR_Support then
+ XDR.W_U (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_U (Item));
end W_U;
+ -----------
+ -- W_U24 --
+ -----------
+
+ procedure W_U24 (Stream : not null access RST; Item : Unsigned_24) is
+ begin
+ if XDR_Support then
+ XDR.W_U24 (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_U24 (Item));
+ end W_U24;
+
----------
-- W_WC --
----------
procedure W_WC (Stream : not null access RST; Item : Wide_Character) is
- T : constant S_WC := From_WC (Item);
begin
- Ada.Streams.Write (Stream.all, T);
+ if XDR_Support then
+ XDR.W_WC (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_WC (Item));
end W_WC;
-----------
@@ -700,9 +952,13 @@ package body System.Stream_Attributes is
procedure W_WWC
(Stream : not null access RST; Item : Wide_Wide_Character)
is
- T : constant S_WWC := From_WWC (Item);
begin
- Ada.Streams.Write (Stream.all, T);
+ if XDR_Support then
+ XDR.W_WWC (Stream, Item);
+ return;
+ end if;
+
+ Ada.Streams.Write (Stream.all, From_WWC (Item));
end W_WWC;
end System.Stream_Attributes;
diff --git a/gcc/ada/libgnat/s-stratt.ads b/gcc/ada/libgnat/s-stratt.ads
index e050bc1..c8c453a 100644
--- a/gcc/ada/libgnat/s-stratt.ads
+++ b/gcc/ada/libgnat/s-stratt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -53,6 +53,12 @@ package System.Stream_Attributes is
subtype SEC is Ada.Streams.Stream_Element_Count;
+ type Integer_24 is range -2 ** 23 .. 2 ** 23 - 1;
+ for Integer_24'Size use 24;
+
+ type Unsigned_24 is mod 2 ** 24;
+ for Unsigned_24'Size use 24;
+
-- Enumeration types are usually transferred using the routine for the
-- corresponding integer. The exception is that special routines are
-- provided for Boolean and the character types, in case the protocol
@@ -104,6 +110,7 @@ package System.Stream_Attributes is
function I_C (Stream : not null access RST) return Character;
function I_F (Stream : not null access RST) return Float;
function I_I (Stream : not null access RST) return Integer;
+ function I_I24 (Stream : not null access RST) return Integer_24;
function I_LF (Stream : not null access RST) return Long_Float;
function I_LI (Stream : not null access RST) return Long_Integer;
function I_LLF (Stream : not null access RST) return Long_Long_Float;
@@ -117,6 +124,7 @@ package System.Stream_Attributes is
UST.Short_Short_Unsigned;
function I_SU (Stream : not null access RST) return UST.Short_Unsigned;
function I_U (Stream : not null access RST) return UST.Unsigned;
+ function I_U24 (Stream : not null access RST) return Unsigned_24;
function I_WC (Stream : not null access RST) return Wide_Character;
function I_WWC (Stream : not null access RST) return Wide_Wide_Character;
@@ -135,6 +143,7 @@ package System.Stream_Attributes is
procedure W_C (Stream : not null access RST; Item : Character);
procedure W_F (Stream : not null access RST; Item : Float);
procedure W_I (Stream : not null access RST; Item : Integer);
+ procedure W_I24 (Stream : not null access RST; Item : Integer_24);
procedure W_LF (Stream : not null access RST; Item : Long_Float);
procedure W_LI (Stream : not null access RST; Item : Long_Integer);
procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float);
@@ -149,15 +158,13 @@ package System.Stream_Attributes is
UST.Short_Short_Unsigned);
procedure W_SU (Stream : not null access RST; Item : UST.Short_Unsigned);
procedure W_U (Stream : not null access RST; Item : UST.Unsigned);
+ procedure W_U24 (Stream : not null access RST; Item : Unsigned_24);
procedure W_WC (Stream : not null access RST; Item : Wide_Character);
procedure W_WWC (Stream : not null access RST; Item : Wide_Wide_Character);
function Block_IO_OK return Boolean;
- -- Package System.Stream_Attributes has several bodies - the default one
- -- distributed with GNAT, and s-stratt__xdr.adb, which is based on the XDR
- -- standard. Both bodies share the same spec. The role of this function is
- -- to indicate whether the current version of System.Stream_Attributes
- -- supports block IO. See System.Strings.Stream_Ops (s-ststop) for details.
+ -- Indicate whether the current setting supports block IO. See
+ -- System.Strings.Stream_Ops (s-ststop) for details on block IO.
private
pragma Inline (I_AD);
diff --git a/gcc/ada/libgnat/s-strcom.adb b/gcc/ada/libgnat/s-strcom.adb
index b39df66..e3167b4 100644
--- a/gcc/ada/libgnat/s-strcom.adb
+++ b/gcc/ada/libgnat/s-strcom.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-strcom.ads b/gcc/ada/libgnat/s-strcom.ads
index e6b6ad9..b77d442 100644
--- a/gcc/ada/libgnat/s-strcom.ads
+++ b/gcc/ada/libgnat/s-strcom.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-strhas.adb b/gcc/ada/libgnat/s-strhas.adb
index 92cdbf3..05c56ae 100644
--- a/gcc/ada/libgnat/s-strhas.adb
+++ b/gcc/ada/libgnat/s-strhas.adb
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-strhas.ads b/gcc/ada/libgnat/s-strhas.ads
index 19cddb5..07a5928 100644
--- a/gcc/ada/libgnat/s-strhas.ads
+++ b/gcc/ada/libgnat/s-strhas.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-string.adb b/gcc/ada/libgnat/s-string.adb
index 010e204..f26f8d6 100644
--- a/gcc/ada/libgnat/s-string.adb
+++ b/gcc/ada/libgnat/s-string.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-string.ads b/gcc/ada/libgnat/s-string.ads
index e70dafb..c93e4e62 100644
--- a/gcc/ada/libgnat/s-string.ads
+++ b/gcc/ada/libgnat/s-string.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-strops.adb b/gcc/ada/libgnat/s-strops.adb
index 75c655c..6458060 100644
--- a/gcc/ada/libgnat/s-strops.adb
+++ b/gcc/ada/libgnat/s-strops.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-strops.ads b/gcc/ada/libgnat/s-strops.ads
index 46970ab..9b6028a 100644
--- a/gcc/ada/libgnat/s-strops.ads
+++ b/gcc/ada/libgnat/s-strops.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-ststop.adb b/gcc/ada/libgnat/s-ststop.adb
index cf594b0..cc2a352 100644
--- a/gcc/ada/libgnat/s-ststop.adb
+++ b/gcc/ada/libgnat/s-ststop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -216,21 +216,25 @@ package body System.Strings.Stream_Ops is
declare
-- Determine the size in BITS of the block necessary to contain
-- the whole string.
+ -- Since we are dealing with strings indexed by natural, there
+ -- is no risk of overflow when using a Long_Long_Integer.
- Block_Size : constant Natural :=
- Integer (Item'Last - Item'First + 1) * ET_Size;
+ Block_Size : constant Long_Long_Integer :=
+ Item'Length * Long_Long_Integer (ET_Size);
-- Item can be larger than what the default block can store,
- -- determine the number of whole reads necessary to read the
+ -- determine the number of whole writes necessary to output the
-- string.
- Blocks : constant Natural := Block_Size / Default_Block_Size;
+ Blocks : constant Natural :=
+ Natural (Block_Size / Long_Long_Integer (Default_Block_Size));
-- The size of Item may not be a multiple of the default block
- -- size, determine the size of the remaining chunk in BITS.
+ -- size, determine the size of the remaining chunk.
Rem_Size : constant Natural :=
- Block_Size mod Default_Block_Size;
+ Natural
+ (Block_Size mod Long_Long_Integer (Default_Block_Size));
-- String indexes
@@ -337,20 +341,25 @@ package body System.Strings.Stream_Ops is
declare
-- Determine the size in BITS of the block necessary to contain
-- the whole string.
+ -- Since we are dealing with strings indexed by natural, there
+ -- is no risk of overflow when using a Long_Long_Integer.
- Block_Size : constant Natural := Item'Length * ET_Size;
+ Block_Size : constant Long_Long_Integer :=
+ Item'Length * Long_Long_Integer (ET_Size);
-- Item can be larger than what the default block can store,
-- determine the number of whole writes necessary to output the
-- string.
- Blocks : constant Natural := Block_Size / Default_Block_Size;
+ Blocks : constant Natural :=
+ Natural (Block_Size / Long_Long_Integer (Default_Block_Size));
-- The size of Item may not be a multiple of the default block
-- size, determine the size of the remaining chunk.
Rem_Size : constant Natural :=
- Block_Size mod Default_Block_Size;
+ Natural
+ (Block_Size mod Long_Long_Integer (Default_Block_Size));
-- String indexes
diff --git a/gcc/ada/libgnat/s-ststop.ads b/gcc/ada/libgnat/s-ststop.ads
index 0e20b84..5f35fed 100644
--- a/gcc/ada/libgnat/s-ststop.ads
+++ b/gcc/ada/libgnat/s-ststop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -53,15 +53,15 @@
-- or
-- String_Output_Blk_IO (Some_Stream, Some_String);
--- String_Output form is used if pragma Restrictions (No_String_Optimziations)
+-- String_Output form is used if pragma Restrictions (No_String_Optimizations)
-- is active, which requires element by element operations. The BLK_IO form
-- is used if this restriction is not set, allowing block optimization.
-- Note that if System.Stream_Attributes.Block_IO_OK is False, then the BLK_IO
-- form is treated as equivalent to the normal case, so that the optimization
-- is inhibited anyway, regardless of the setting of the restriction. This
--- handles versions of System.Stream_Attributes (in particular the XDR version
--- found in s-stratt-xdr) which do not permit block io optimization.
+-- handles the XDR implementation of System.Stream_Attributes in particular
+-- which does not permit block io optimization.
pragma Compiler_Unit_Warning;
diff --git a/gcc/ada/libgnat/s-tasloc.adb b/gcc/ada/libgnat/s-tasloc.adb
index 1ebb62c..17fc3ce 100644
--- a/gcc/ada/libgnat/s-tasloc.adb
+++ b/gcc/ada/libgnat/s-tasloc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, AdaCore --
+-- Copyright (C) 1997-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-tasloc.ads b/gcc/ada/libgnat/s-tasloc.ads
index 538c857..1820107 100644
--- a/gcc/ada/libgnat/s-tasloc.ads
+++ b/gcc/ada/libgnat/s-tasloc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, AdaCore --
+-- Copyright (C) 1998-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-thread.ads b/gcc/ada/libgnat/s-thread.ads
index ace45d7..a13e806 100644
--- a/gcc/ada/libgnat/s-thread.ads
+++ b/gcc/ada/libgnat/s-thread.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-thread__ae653.adb b/gcc/ada/libgnat/s-thread__ae653.adb
index 240483c..fcf1304 100644
--- a/gcc/ada/libgnat/s-thread__ae653.adb
+++ b/gcc/ada/libgnat/s-thread__ae653.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -36,6 +36,7 @@ pragma Restrictions (No_Tasking);
-- which do not use Ada tasking. This restriction ensures that this
-- will be checked by the binder.
+with System.Storage_Elements; use System.Storage_Elements;
with System.OS_Versions; use System.OS_Versions;
package body System.Threads is
@@ -44,14 +45,16 @@ package body System.Threads is
package SSL renames System.Soft_Links;
- Current_ATSD : aliased System.Address := System.Null_Address;
- pragma Export (C, Current_ATSD, "__gnat_current_atsd");
-
Main_ATSD : aliased ATSD;
-- TSD for environment task
- Stack_Limit : Address;
+ Current_ATSD : aliased System.Address := System.Null_Address;
+ pragma Thread_Local_Storage (Current_ATSD);
+ -- pragma TLS needed since TaskVarAdd no longer available
+ -- Assume guard pages for Helix APEX partitions, but leave
+ -- checking mechanism in for now, in case of surprises. ???
+ Stack_Limit : Address;
pragma Import (C, Stack_Limit, "__gnat_stack_limit");
type Set_Stack_Limit_Proc_Acc is access procedure;
@@ -62,11 +65,10 @@ package body System.Threads is
-- Procedure to be called when a task is created to set stack limit if
-- limit checking is used.
- --------------------------
- -- VxWorks specific API --
- --------------------------
+ -- VxWorks specific API
ERROR : constant STATUS := Interfaces.C.int (-1);
+ OK : constant STATUS := Interfaces.C.int (0);
function taskIdVerify (tid : t_id) return STATUS;
pragma Import (C, taskIdVerify, "taskIdVerify");
@@ -74,10 +76,6 @@ package body System.Threads is
function taskIdSelf return t_id;
pragma Import (C, taskIdSelf, "taskIdSelf");
- function taskVarAdd
- (tid : t_id; pVar : System.Address) return int;
- pragma Import (C, taskVarAdd, "taskVarAdd");
-
-----------------------
-- Local Subprograms --
-----------------------
@@ -102,21 +100,18 @@ package body System.Threads is
(Sec_Stack_Ptr : SST.SS_Stack_Ptr;
Process_ATSD_Address : System.Address)
is
- -- Current_ATSD must already be a taskVar of taskIdSelf.
- -- No assertion because taskVarGet is not available on VxWorks/CERT,
- -- which is used on VxWorks 653 3.x as a guest OS.
- TSD : constant ATSD_Access := From_Address (Process_ATSD_Address);
+ ATSD : constant ATSD_Access := From_Address (Process_ATSD_Address);
begin
- TSD.Sec_Stack_Ptr := Sec_Stack_Ptr;
- SST.SS_Init (TSD.Sec_Stack_Ptr);
+ ATSD.Sec_Stack_Ptr := Sec_Stack_Ptr;
+ SST.SS_Init (ATSD.Sec_Stack_Ptr);
Current_ATSD := Process_ATSD_Address;
-
Install_Handler;
- -- Initialize stack limit if needed
+ -- Assume guard pages for Helix/Vx7, but leave in for now ???
+ -- Initialize stack limit if needed.
if Current_ATSD /= Main_ATSD'Address
and then Set_Stack_Limit_Hook /= null
@@ -184,24 +179,16 @@ package body System.Threads is
--------------
function Register (T : Thread_Id) return STATUS is
- Result : STATUS;
-
begin
-- It cannot be assumed that the caller of this routine has a ATSD;
-- so neither this procedure nor the procedures that it calls should
-- raise or handle exceptions, or make use of a secondary stack.
- -- This routine is only necessary because taskVarAdd cannot be
- -- executed once an VxWorks 653 partition has entered normal mode
- -- (depending on configRecord.c, allocation could be disabled).
- -- Otherwise, everything could have been done in Thread_Body_Enter.
-
if taskIdVerify (T) = ERROR then
return ERROR;
end if;
- Result := taskVarAdd (T, Current_ATSD'Address);
- pragma Assert (Result /= ERROR);
+ Current_ATSD := To_Address (Integer_Address (T));
-- The same issue applies to the task variable that contains the stack
-- limit when that overflow checking mechanism is used instead of
@@ -211,17 +198,15 @@ package body System.Threads is
-- System.Stack_Check_Limits = True.
pragma Warnings (Off);
+
-- OS is a constant
- if Result /= ERROR
- and then OS /= VxWorks_653
- and then Set_Stack_Limit_Hook /= null
- then
- Result := taskVarAdd (T, Stack_Limit'Address);
- pragma Assert (Result /= ERROR);
+ if OS /= VxWorks_653 and then Set_Stack_Limit_Hook /= null then
+ -- Check that this is correct if limit checking left in. ???
+ Stack_Limit := To_Address (Integer_Address (T));
end if;
pragma Warnings (On);
- return Result;
+ return OK;
end Register;
-------------------
diff --git a/gcc/ada/libgnat/s-traceb.adb b/gcc/ada/libgnat/s-traceb.adb
index bba3494..b2cb6d8 100644
--- a/gcc/ada/libgnat/s-traceb.adb
+++ b/gcc/ada/libgnat/s-traceb.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-traceb.ads b/gcc/ada/libgnat/s-traceb.ads
index c5fe36a..1c3151c 100644
--- a/gcc/ada/libgnat/s-traceb.ads
+++ b/gcc/ada/libgnat/s-traceb.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-traceb__hpux.adb b/gcc/ada/libgnat/s-traceb__hpux.adb
index 64ac58d..2d6b715 100644
--- a/gcc/ada/libgnat/s-traceb__hpux.adb
+++ b/gcc/ada/libgnat/s-traceb__hpux.adb
@@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-traceb__mastop.adb b/gcc/ada/libgnat/s-traceb__mastop.adb
index 82ba677..e24ec1b 100644
--- a/gcc/ada/libgnat/s-traceb__mastop.adb
+++ b/gcc/ada/libgnat/s-traceb__mastop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-traent.adb b/gcc/ada/libgnat/s-traent.adb
index f7b468f..950b0e5 100644
--- a/gcc/ada/libgnat/s-traent.adb
+++ b/gcc/ada/libgnat/s-traent.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-traent.ads b/gcc/ada/libgnat/s-traent.ads
index 9d33be7..fa2db4e 100644
--- a/gcc/ada/libgnat/s-traent.ads
+++ b/gcc/ada/libgnat/s-traent.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/s-trasym.adb b/gcc/ada/libgnat/s-trasym.adb
index b3b1e7c..0d6639f 100644
--- a/gcc/ada/libgnat/s-trasym.adb
+++ b/gcc/ada/libgnat/s-trasym.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-trasym.ads b/gcc/ada/libgnat/s-trasym.ads
index 5839f23..f0240cd 100644
--- a/gcc/ada/libgnat/s-trasym.ads
+++ b/gcc/ada/libgnat/s-trasym.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-trasym__dwarf.adb b/gcc/ada/libgnat/s-trasym__dwarf.adb
index b116a10..d8e3956 100644
--- a/gcc/ada/libgnat/s-trasym__dwarf.adb
+++ b/gcc/ada/libgnat/s-trasym__dwarf.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, AdaCore --
+-- Copyright (C) 1999-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -438,7 +438,7 @@ package body System.Traceback.Symbolic is
Suppress_Hex : Boolean;
Res : in out Bounded_String)
is
- Success : Boolean := False;
+ Success : Boolean;
begin
if Symbolic.Module_Name.Is_Supported then
Append (Res, '[');
diff --git a/gcc/ada/libgnat/s-tsmona.adb b/gcc/ada/libgnat/s-tsmona.adb
index d7271d3..64db59a 100644
--- a/gcc/ada/libgnat/s-tsmona.adb
+++ b/gcc/ada/libgnat/s-tsmona.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2012-2019, AdaCore --
+-- Copyright (C) 2012-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-tsmona__linux.adb b/gcc/ada/libgnat/s-tsmona__linux.adb
index bc3ee23..98c9992 100644
--- a/gcc/ada/libgnat/s-tsmona__linux.adb
+++ b/gcc/ada/libgnat/s-tsmona__linux.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2012-2019, AdaCore --
+-- Copyright (C) 2012-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-tsmona__mingw.adb b/gcc/ada/libgnat/s-tsmona__mingw.adb
index c81a01d..b79a3fc 100644
--- a/gcc/ada/libgnat/s-tsmona__mingw.adb
+++ b/gcc/ada/libgnat/s-tsmona__mingw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2012-2019, AdaCore --
+-- Copyright (C) 2012-2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-unstyp.ads b/gcc/ada/libgnat/s-unstyp.ads
index 08480b4..0f6c73c 100644
--- a/gcc/ada/libgnat/s-unstyp.ads
+++ b/gcc/ada/libgnat/s-unstyp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -51,8 +51,8 @@ package System.Unsigned_Types is
-- Used in the implementation of Is_Negative intrinsic (see Exp_Intr)
type Packed_Byte is mod 2 ** 8;
- pragma Universal_Aliasing (Packed_Byte);
for Packed_Byte'Size use 8;
+ pragma Universal_Aliasing (Packed_Byte);
-- Component type for Packed_Bytes1, Packed_Bytes2 and Packed_Byte4 arrays.
-- As this type is used by the compiler to implement operations on user
-- packed array, it needs to be able to alias any type.
@@ -89,6 +89,24 @@ package System.Unsigned_Types is
-- cases the clusters can be assumed to be 4-byte aligned if the array
-- is aligned (see System.Pack_12 in file s-pack12 as an example).
+ type Rev_Packed_Bytes1 is new Packed_Bytes1;
+ pragma Suppress_Initialization (Rev_Packed_Bytes1);
+ -- This is equivalent to Packed_Bytes1, but for packed arrays with reverse
+ -- scalar storage order. But the Scalar_Storage_Order attribute cannot be
+ -- set directly here, see Exp_Pakd for more details.
+
+ type Rev_Packed_Bytes2 is new Packed_Bytes2;
+ pragma Suppress_Initialization (Rev_Packed_Bytes2);
+ -- This is equivalent to Packed_Bytes2, but for packed arrays with reverse
+ -- scalar storage order. But the Scalar_Storage_Order attribute cannot be
+ -- set directly here, see Exp_Pakd for more details.
+
+ type Rev_Packed_Bytes4 is new Packed_Bytes4;
+ pragma Suppress_Initialization (Rev_Packed_Bytes4);
+ -- This is equivalent to Packed_Bytes4, but for packed arrays with reverse
+ -- scalar storage order. But the Scalar_Storage_Order attribute cannot be
+ -- set directly here, see Exp_Pakd for more details.
+
type Bits_1 is mod 2**1;
type Bits_2 is mod 2**2;
type Bits_4 is mod 2**4;
diff --git a/gcc/ada/libgnat/s-utf_32.adb b/gcc/ada/libgnat/s-utf_32.adb
index 1c412da..a1346f3 100644
--- a/gcc/ada/libgnat/s-utf_32.adb
+++ b/gcc/ada/libgnat/s-utf_32.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -49,7 +49,7 @@ package body System.UTF_32 is
----------------------
-- Note these tables are derived from those given in AI-285. For details
- -- see //www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-00285.TXT?rev=1.22.
+ -- see www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-00285.TXT?rev=1.22.
type UTF_32_Range is record
Lo : UTF_32;
@@ -6071,9 +6071,6 @@ package body System.UTF_32 is
40, -- DESERET CAPITAL LETTER LONG I .. DESERET CAPITAL LETTER EW
32); -- TAG LATIN CAPITAL LETTER A .. TAG LATIN CAPITAL LETTER Z
- pragma Warnings (On);
- -- Temporary until pragma Warnings at start can be activated ???
-
-- The following is a list of the 10646 names for CAPITAL LETTER entries
-- that have no matching SMALL LETTER entry and are thus not folded
@@ -6117,10 +6114,6161 @@ package body System.UTF_32 is
-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI
-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI
+ -- The following array includes all characters in the Unicode table with
+ -- the category NFKC_Quick_Check=No, taken from
+ -- www.unicode.org/Public/UCD/latest/ucd/DerivedNormalizationProps.txt
+
+ UTF_32_NFKC_QC_No : constant UTF_32_Ranges := (
+ (16#00A0#, 16#00A0#), -- NO-BREAK SPACE
+ (16#00A8#, 16#00A8#), -- DIAERESIS
+ (16#00AA#, 16#00AA#), -- FEMININE ORDINAL INDICATOR
+ (16#00AF#, 16#00AF#), -- MACRON
+ (16#00B2#, 16#00B3#), -- SUPERSCRIPT TWO..SUPERSCRIPT THREE
+ (16#00B4#, 16#00B4#), -- ACUTE ACCENT
+ (16#00B5#, 16#00B5#), -- MICRO SIGN
+ (16#00B8#, 16#00B8#), -- CEDILLA
+ (16#00B9#, 16#00B9#), -- SUPERSCRIPT ONE
+ (16#00BA#, 16#00BA#), -- MASCULINE ORDINAL INDICATOR
+ (16#00BC#, 16#00BE#), -- VULGAR FRACTION ONE QUARTER..VULGAR FRACTION THREE QUARTERS
+ (16#0132#, 16#0133#), -- LATIN CAPITAL LIGATURE IJ..LATIN SMALL LIGATURE IJ
+ (16#013F#, 16#0140#), -- LATIN CAPITAL LETTER L WITH MIDDLE DOT..LATIN SMALL LETTER L WITH MIDDLE DOT
+ (16#0149#, 16#0149#), -- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE
+ (16#017F#, 16#017F#), -- LATIN SMALL LETTER LONG S
+ (16#01C4#, 16#01CC#), -- LATIN CAPITAL LETTER DZ WITH CARON..LATIN SMALL LETTER NJ
+ (16#01F1#, 16#01F3#), -- LATIN CAPITAL LETTER DZ..LATIN SMALL LETTER DZ
+ (16#02B0#, 16#02B8#), -- MODIFIER LETTER SMALL H..MODIFIER LETTER SMALL Y
+ (16#02D8#, 16#02DD#), -- BREVE..DOUBLE ACUTE ACCENT
+ (16#02E0#, 16#02E4#), -- MODIFIER LETTER SMALL GAMMA..MODIFIER LETTER SMALL REVERSED GLOTTAL STOP
+ (16#0340#, 16#0341#), -- COMBINING GRAVE TONE MARK..COMBINING ACUTE TONE MARK
+ (16#0343#, 16#0344#), -- COMBINING GREEK KORONIS..COMBINING GREEK DIALYTIKA TONOS
+ (16#0374#, 16#0374#), -- GREEK NUMERAL SIGN
+ (16#037A#, 16#037A#), -- GREEK YPOGEGRAMMENI
+ (16#037E#, 16#037E#), -- GREEK QUESTION MARK
+ (16#0384#, 16#0385#), -- GREEK TONOS..GREEK DIALYTIKA TONOS
+ (16#0387#, 16#0387#), -- GREEK ANO TELEIA
+ (16#03D0#, 16#03D6#), -- GREEK BETA SYMBOL..GREEK PI SYMBOL
+ (16#03F0#, 16#03F2#), -- GREEK KAPPA SYMBOL..GREEK LUNATE SIGMA SYMBOL
+ (16#03F4#, 16#03F5#), -- GREEK CAPITAL THETA SYMBOL..GREEK LUNATE EPSILON SYMBOL
+ (16#03F9#, 16#03F9#), -- GREEK CAPITAL LUNATE SIGMA SYMBOL
+ (16#0587#, 16#0587#), -- ARMENIAN SMALL LIGATURE ECH YIWN
+ (16#0675#, 16#0678#), -- ARABIC LETTER HIGH HAMZA ALEF..ARABIC LETTER HIGH HAMZA YEH
+ (16#0958#, 16#095F#), -- DEVANAGARI LETTER QA..DEVANAGARI LETTER YYA
+ (16#09DC#, 16#09DD#), -- BENGALI LETTER RRA..BENGALI LETTER RHA
+ (16#09DF#, 16#09DF#), -- BENGALI LETTER YYA
+ (16#0A33#, 16#0A33#), -- GURMUKHI LETTER LLA
+ (16#0A36#, 16#0A36#), -- GURMUKHI LETTER SHA
+ (16#0A59#, 16#0A5B#), -- GURMUKHI LETTER KHHA..GURMUKHI LETTER ZA
+ (16#0A5E#, 16#0A5E#), -- GURMUKHI LETTER FA
+ (16#0B5C#, 16#0B5D#), -- ORIYA LETTER RRA..ORIYA LETTER RHA
+ (16#0E33#, 16#0E33#), -- THAI CHARACTER SARA AM
+ (16#0EB3#, 16#0EB3#), -- LAO VOWEL SIGN AM
+ (16#0EDC#, 16#0EDD#), -- LAO HO NO..LAO HO MO
+ (16#0F0C#, 16#0F0C#), -- TIBETAN MARK DELIMITER TSHEG BSTAR
+ (16#0F43#, 16#0F43#), -- TIBETAN LETTER GHA
+ (16#0F4D#, 16#0F4D#), -- TIBETAN LETTER DDHA
+ (16#0F52#, 16#0F52#), -- TIBETAN LETTER DHA
+ (16#0F57#, 16#0F57#), -- TIBETAN LETTER BHA
+ (16#0F5C#, 16#0F5C#), -- TIBETAN LETTER DZHA
+ (16#0F69#, 16#0F69#), -- TIBETAN LETTER KSSA
+ (16#0F73#, 16#0F73#), -- TIBETAN VOWEL SIGN II
+ (16#0F75#, 16#0F79#), -- TIBETAN VOWEL SIGN UU..TIBETAN VOWEL SIGN VOCALIC LL
+ (16#0F81#, 16#0F81#), -- TIBETAN VOWEL SIGN REVERSED II
+ (16#0F93#, 16#0F93#), -- TIBETAN SUBJOINED LETTER GHA
+ (16#0F9D#, 16#0F9D#), -- TIBETAN SUBJOINED LETTER DDHA
+ (16#0FA2#, 16#0FA2#), -- TIBETAN SUBJOINED LETTER DHA
+ (16#0FA7#, 16#0FA7#), -- TIBETAN SUBJOINED LETTER BHA
+ (16#0FAC#, 16#0FAC#), -- TIBETAN SUBJOINED LETTER DZHA
+ (16#0FB9#, 16#0FB9#), -- TIBETAN SUBJOINED LETTER KSSA
+ (16#10FC#, 16#10FC#), -- MODIFIER LETTER GEORGIAN NAR
+ (16#1D2C#, 16#1D2E#), -- MODIFIER LETTER CAPITAL A..MODIFIER LETTER CAPITAL B
+ (16#1D30#, 16#1D3A#), -- MODIFIER LETTER CAPITAL D..MODIFIER LETTER CAPITAL N
+ (16#1D3C#, 16#1D4D#), -- MODIFIER LETTER CAPITAL O..MODIFIER LETTER SMALL G
+ (16#1D4F#, 16#1D6A#), -- MODIFIER LETTER SMALL K..GREEK SUBSCRIPT SMALL LETTER CHI
+ (16#1D78#, 16#1D78#), -- MODIFIER LETTER CYRILLIC EN
+ (16#1D9B#, 16#1DBF#), -- MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL THETA
+ (16#1E9A#, 16#1E9B#), -- LATIN SMALL LETTER A WITH RIGHT HALF RING..LATIN SMALL LETTER LONG S WITH DOT ABOVE
+ (16#1F71#, 16#1F71#), -- GREEK SMALL LETTER ALPHA WITH OXIA
+ (16#1F73#, 16#1F73#), -- GREEK SMALL LETTER EPSILON WITH OXIA
+ (16#1F75#, 16#1F75#), -- GREEK SMALL LETTER ETA WITH OXIA
+ (16#1F77#, 16#1F77#), -- GREEK SMALL LETTER IOTA WITH OXIA
+ (16#1F79#, 16#1F79#), -- GREEK SMALL LETTER OMICRON WITH OXIA
+ (16#1F7B#, 16#1F7B#), -- GREEK SMALL LETTER UPSILON WITH OXIA
+ (16#1F7D#, 16#1F7D#), -- GREEK SMALL LETTER OMEGA WITH OXIA
+ (16#1FBB#, 16#1FBB#), -- GREEK CAPITAL LETTER ALPHA WITH OXIA
+ (16#1FBD#, 16#1FBD#), -- GREEK KORONIS
+ (16#1FBE#, 16#1FBE#), -- GREEK PROSGEGRAMMENI
+ (16#1FBF#, 16#1FC1#), -- GREEK PSILI..GREEK DIALYTIKA AND PERISPOMENI
+ (16#1FC9#, 16#1FC9#), -- GREEK CAPITAL LETTER EPSILON WITH OXIA
+ (16#1FCB#, 16#1FCB#), -- GREEK CAPITAL LETTER ETA WITH OXIA
+ (16#1FCD#, 16#1FCF#), -- GREEK PSILI AND VARIA..GREEK PSILI AND PERISPOMENI
+ (16#1FD3#, 16#1FD3#), -- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
+ (16#1FDB#, 16#1FDB#), -- GREEK CAPITAL LETTER IOTA WITH OXIA
+ (16#1FDD#, 16#1FDF#), -- GREEK DASIA AND VARIA..GREEK DASIA AND PERISPOMENI
+ (16#1FE3#, 16#1FE3#), -- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA
+ (16#1FEB#, 16#1FEB#), -- GREEK CAPITAL LETTER UPSILON WITH OXIA
+ (16#1FED#, 16#1FEF#), -- GREEK DIALYTIKA AND VARIA..GREEK VARIA
+ (16#1FF9#, 16#1FF9#), -- GREEK CAPITAL LETTER OMICRON WITH OXIA
+ (16#1FFB#, 16#1FFB#), -- GREEK CAPITAL LETTER OMEGA WITH OXIA
+ (16#1FFD#, 16#1FFE#), -- GREEK OXIA..GREEK DASIA
+ (16#2000#, 16#200A#), -- EN QUAD..HAIR SPACE
+ (16#2011#, 16#2011#), -- NON-BREAKING HYPHEN
+ (16#2017#, 16#2017#), -- DOUBLE LOW LINE
+ (16#2024#, 16#2026#), -- ONE DOT LEADER..HORIZONTAL ELLIPSIS
+ (16#202F#, 16#202F#), -- NARROW NO-BREAK SPACE
+ (16#2033#, 16#2034#), -- DOUBLE PRIME..TRIPLE PRIME
+ (16#2036#, 16#2037#), -- REVERSED DOUBLE PRIME..REVERSED TRIPLE PRIME
+ (16#203C#, 16#203C#), -- DOUBLE EXCLAMATION MARK
+ (16#203E#, 16#203E#), -- OVERLINE
+ (16#2047#, 16#2049#), -- DOUBLE QUESTION MARK..EXCLAMATION QUESTION MARK
+ (16#2057#, 16#2057#), -- QUADRUPLE PRIME
+ (16#205F#, 16#205F#), -- MEDIUM MATHEMATICAL SPACE
+ (16#2070#, 16#2070#), -- SUPERSCRIPT ZERO
+ (16#2071#, 16#2071#), -- SUPERSCRIPT LATIN SMALL LETTER I
+ (16#2074#, 16#2079#), -- SUPERSCRIPT FOUR..SUPERSCRIPT NINE
+ (16#207A#, 16#207C#), -- SUPERSCRIPT PLUS SIGN..SUPERSCRIPT EQUALS SIGN
+ (16#207D#, 16#207D#), -- SUPERSCRIPT LEFT PARENTHESIS
+ (16#207E#, 16#207E#), -- SUPERSCRIPT RIGHT PARENTHESIS
+ (16#207F#, 16#207F#), -- SUPERSCRIPT LATIN SMALL LETTER N
+ (16#2080#, 16#2089#), -- SUBSCRIPT ZERO..SUBSCRIPT NINE
+ (16#208A#, 16#208C#), -- SUBSCRIPT PLUS SIGN..SUBSCRIPT EQUALS SIGN
+ (16#208D#, 16#208D#), -- SUBSCRIPT LEFT PARENTHESIS
+ (16#208E#, 16#208E#), -- SUBSCRIPT RIGHT PARENTHESIS
+ (16#2090#, 16#209C#), -- LATIN SUBSCRIPT SMALL LETTER A..LATIN SUBSCRIPT SMALL LETTER T
+ (16#20A8#, 16#20A8#), -- RUPEE SIGN
+ (16#2100#, 16#2101#), -- ACCOUNT OF..ADDRESSED TO THE SUBJECT
+ (16#2102#, 16#2102#), -- DOUBLE-STRUCK CAPITAL C
+ (16#2103#, 16#2103#), -- DEGREE CELSIUS
+ (16#2105#, 16#2106#), -- CARE OF..CADA UNA
+ (16#2107#, 16#2107#), -- EULER CONSTANT
+ (16#2109#, 16#2109#), -- DEGREE FAHRENHEIT
+ (16#210A#, 16#2113#), -- SCRIPT SMALL G..SCRIPT SMALL L
+ (16#2115#, 16#2115#), -- DOUBLE-STRUCK CAPITAL N
+ (16#2116#, 16#2116#), -- NUMERO SIGN
+ (16#2119#, 16#211D#), -- DOUBLE-STRUCK CAPITAL P..DOUBLE-STRUCK CAPITAL R
+ (16#2120#, 16#2122#), -- SERVICE MARK..TRADE MARK SIGN
+ (16#2124#, 16#2124#), -- DOUBLE-STRUCK CAPITAL Z
+ (16#2126#, 16#2126#), -- OHM SIGN
+ (16#2128#, 16#2128#), -- BLACK-LETTER CAPITAL Z
+ (16#212A#, 16#212D#), -- KELVIN SIGN..BLACK-LETTER CAPITAL C
+ (16#212F#, 16#2131#), -- SCRIPT SMALL E..SCRIPT CAPITAL F
+ (16#2133#, 16#2134#), -- SCRIPT CAPITAL M..SCRIPT SMALL O
+ (16#2135#, 16#2138#), -- ALEF SYMBOL..DALET SYMBOL
+ (16#2139#, 16#2139#), -- INFORMATION SOURCE
+ (16#213B#, 16#213B#), -- FACSIMILE SIGN
+ (16#213C#, 16#213F#), -- DOUBLE-STRUCK SMALL PI..DOUBLE-STRUCK CAPITAL PI
+ (16#2140#, 16#2140#), -- DOUBLE-STRUCK N-ARY SUMMATION
+ (16#2145#, 16#2149#), -- DOUBLE-STRUCK ITALIC CAPITAL D..DOUBLE-STRUCK ITALIC SMALL J
+ (16#2150#, 16#215F#), -- VULGAR FRACTION ONE SEVENTH..FRACTION NUMERATOR ONE
+ (16#2160#, 16#217F#), -- ROMAN NUMERAL ONE..SMALL ROMAN NUMERAL ONE THOUSAND
+ (16#2189#, 16#2189#), -- VULGAR FRACTION ZERO THIRDS
+ (16#222C#, 16#222D#), -- DOUBLE INTEGRAL..TRIPLE INTEGRAL
+ (16#222F#, 16#2230#), -- SURFACE INTEGRAL..VOLUME INTEGRAL
+ (16#2329#, 16#2329#), -- LEFT-POINTING ANGLE BRACKET
+ (16#232A#, 16#232A#), -- RIGHT-POINTING ANGLE BRACKET
+ (16#2460#, 16#249B#), -- CIRCLED DIGIT ONE..NUMBER TWENTY FULL STOP
+ (16#249C#, 16#24E9#), -- PARENTHESIZED LATIN SMALL LETTER A..CIRCLED LATIN SMALL LETTER Z
+ (16#24EA#, 16#24EA#), -- CIRCLED DIGIT ZERO
+ (16#2A0C#, 16#2A0C#), -- QUADRUPLE INTEGRAL OPERATOR
+ (16#2A74#, 16#2A76#), -- DOUBLE COLON EQUAL..THREE CONSECUTIVE EQUALS SIGNS
+ (16#2ADC#, 16#2ADC#), -- FORKING
+ (16#2C7C#, 16#2C7D#), -- LATIN SUBSCRIPT SMALL LETTER J..MODIFIER LETTER CAPITAL V
+ (16#2D6F#, 16#2D6F#), -- TIFINAGH MODIFIER LETTER LABIALIZATION MARK
+ (16#2E9F#, 16#2E9F#), -- CJK RADICAL MOTHER
+ (16#2EF3#, 16#2EF3#), -- CJK RADICAL C-SIMPLIFIED TURTLE
+ (16#2F00#, 16#2FD5#), -- KANGXI RADICAL ONE..KANGXI RADICAL FLUTE
+ (16#3000#, 16#3000#), -- IDEOGRAPHIC SPACE
+ (16#3036#, 16#3036#), -- CIRCLED POSTAL MARK
+ (16#3038#, 16#303A#), -- HANGZHOU NUMERAL TEN..HANGZHOU NUMERAL THIRTY
+ (16#309B#, 16#309C#), -- KATAKANA-HIRAGANA VOICED SOUND MARK..KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
+ (16#309F#, 16#309F#), -- HIRAGANA DIGRAPH YORI
+ (16#30FF#, 16#30FF#), -- KATAKANA DIGRAPH KOTO
+ (16#3131#, 16#318E#), -- HANGUL LETTER KIYEOK..HANGUL LETTER ARAEAE
+ (16#3192#, 16#3195#), -- IDEOGRAPHIC ANNOTATION ONE MARK..IDEOGRAPHIC ANNOTATION FOUR MARK
+ (16#3196#, 16#319F#), -- IDEOGRAPHIC ANNOTATION TOP MARK..IDEOGRAPHIC ANNOTATION MAN MARK
+ (16#3200#, 16#321E#), -- PARENTHESIZED HANGUL KIYEOK..PARENTHESIZED KOREAN CHARACTER O HU
+ (16#3220#, 16#3229#), -- PARENTHESIZED IDEOGRAPH ONE..PARENTHESIZED IDEOGRAPH TEN
+ (16#322A#, 16#3247#), -- PARENTHESIZED IDEOGRAPH MOON..CIRCLED IDEOGRAPH KOTO
+ (16#3250#, 16#3250#), -- PARTNERSHIP SIGN
+ (16#3251#, 16#325F#), -- CIRCLED NUMBER TWENTY ONE..CIRCLED NUMBER THIRTY FIVE
+ (16#3260#, 16#327E#), -- CIRCLED HANGUL KIYEOK..CIRCLED HANGUL IEUNG U
+ (16#3280#, 16#3289#), -- CIRCLED IDEOGRAPH ONE..CIRCLED IDEOGRAPH TEN
+ (16#328A#, 16#32B0#), -- CIRCLED IDEOGRAPH MOON..CIRCLED IDEOGRAPH NIGHT
+ (16#32B1#, 16#32BF#), -- CIRCLED NUMBER THIRTY SIX..CIRCLED NUMBER FIFTY
+ (16#32C0#, 16#33FF#), -- IDEOGRAPHIC TELEGRAPH SYMBOL FOR JANUARY..SQUARE GAL
+ (16#A69C#, 16#A69D#), -- MODIFIER LETTER CYRILLIC HARD SIGN..MODIFIER LETTER CYRILLIC SOFT SIGN
+ (16#A770#, 16#A770#), -- MODIFIER LETTER US
+ (16#A7F8#, 16#A7F9#), -- MODIFIER LETTER CAPITAL H WITH STROKE..MODIFIER LETTER SMALL LIGATURE OE
+ (16#AB5C#, 16#AB5F#), -- MODIFIER LETTER SMALL HENG..MODIFIER LETTER SMALL U WITH LEFT HOOK
+ (16#AB69#, 16#AB69#), -- MODIFIER LETTER SMALL TURNED W
+ (16#F900#, 16#FA0D#), -- CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA0D
+ (16#FA10#, 16#FA10#), -- CJK COMPATIBILITY IDEOGRAPH-FA10
+ (16#FA12#, 16#FA12#), -- CJK COMPATIBILITY IDEOGRAPH-FA12
+ (16#FA15#, 16#FA1E#), -- CJK COMPATIBILITY IDEOGRAPH-FA15..CJK COMPATIBILITY IDEOGRAPH-FA1E
+ (16#FA20#, 16#FA20#), -- CJK COMPATIBILITY IDEOGRAPH-FA20
+ (16#FA22#, 16#FA22#), -- CJK COMPATIBILITY IDEOGRAPH-FA22
+ (16#FA25#, 16#FA26#), -- CJK COMPATIBILITY IDEOGRAPH-FA25..CJK COMPATIBILITY IDEOGRAPH-FA26
+ (16#FA2A#, 16#FA6D#), -- CJK COMPATIBILITY IDEOGRAPH-FA2A..CJK COMPATIBILITY IDEOGRAPH-FA6D
+ (16#FA70#, 16#FAD9#), -- CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
+ (16#FB00#, 16#FB06#), -- LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
+ (16#FB13#, 16#FB17#), -- ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
+ (16#FB1D#, 16#FB1D#), -- HEBREW LETTER YOD WITH HIRIQ
+ (16#FB1F#, 16#FB28#), -- HEBREW LIGATURE YIDDISH YOD YOD PATAH..HEBREW LETTER WIDE TAV
+ (16#FB29#, 16#FB29#), -- HEBREW LETTER ALTERNATIVE PLUS SIGN
+ (16#FB2A#, 16#FB36#), -- HEBREW LETTER SHIN WITH SHIN DOT..HEBREW LETTER ZAYIN WITH DAGESH
+ (16#FB38#, 16#FB3C#), -- HEBREW LETTER TET WITH DAGESH..HEBREW LETTER LAMED WITH DAGESH
+ (16#FB3E#, 16#FB3E#), -- HEBREW LETTER MEM WITH DAGESH
+ (16#FB40#, 16#FB41#), -- HEBREW LETTER NUN WITH DAGESH..HEBREW LETTER SAMEKH WITH DAGESH
+ (16#FB43#, 16#FB44#), -- HEBREW LETTER FINAL PE WITH DAGESH..HEBREW LETTER PE WITH DAGESH
+ (16#FB46#, 16#FBB1#), -- HEBREW LETTER TSADI WITH DAGESH..ARABIC LETTER YEH BARREE WITH HAMZA ABOVE FINAL FORM
+ (16#FBD3#, 16#FD3D#), -- ARABIC LETTER NG ISOLATED FORM..ARABIC LIGATURE ALEF WITH FATHATAN ISOLATED FORM
+ (16#FD50#, 16#FD8F#), -- ARABIC LIGATURE TEH WITH JEEM WITH MEEM INITIAL FORM..ARABIC LIGATURE MEEM WITH KHAH WITH MEEM INITIAL FORM
+ (16#FD92#, 16#FDC7#), -- ARABIC LIGATURE MEEM WITH JEEM WITH KHAH INITIAL FORM..ARABIC LIGATURE NOON WITH JEEM WITH YEH FINAL FORM
+ (16#FDF0#, 16#FDFB#), -- ARABIC LIGATURE SALLA USED AS KORANIC STOP SIGN ISOLATED FORM..ARABIC LIGATURE JALLAJALALOUHOU
+ (16#FDFC#, 16#FDFC#), -- RIAL SIGN
+ (16#FE10#, 16#FE16#), -- PRESENTATION FORM FOR VERTICAL COMMA..PRESENTATION FORM FOR VERTICAL QUESTION MARK
+ (16#FE17#, 16#FE17#), -- PRESENTATION FORM FOR VERTICAL LEFT WHITE LENTICULAR BRACKET
+ (16#FE18#, 16#FE18#), -- PRESENTATION FORM FOR VERTICAL RIGHT WHITE LENTICULAR BRAKCET
+ (16#FE19#, 16#FE19#), -- PRESENTATION FORM FOR VERTICAL HORIZONTAL ELLIPSIS
+ (16#FE30#, 16#FE30#), -- PRESENTATION FORM FOR VERTICAL TWO DOT LEADER
+ (16#FE31#, 16#FE32#), -- PRESENTATION FORM FOR VERTICAL EM DASH..PRESENTATION FORM FOR VERTICAL EN DASH
+ (16#FE33#, 16#FE34#), -- PRESENTATION FORM FOR VERTICAL LOW LINE..PRESENTATION FORM FOR VERTICAL WAVY LOW LINE
+ (16#FE35#, 16#FE35#), -- PRESENTATION FORM FOR VERTICAL LEFT PARENTHESIS
+ (16#FE36#, 16#FE36#), -- PRESENTATION FORM FOR VERTICAL RIGHT PARENTHESIS
+ (16#FE37#, 16#FE37#), -- PRESENTATION FORM FOR VERTICAL LEFT CURLY BRACKET
+ (16#FE38#, 16#FE38#), -- PRESENTATION FORM FOR VERTICAL RIGHT CURLY BRACKET
+ (16#FE39#, 16#FE39#), -- PRESENTATION FORM FOR VERTICAL LEFT TORTOISE SHELL BRACKET
+ (16#FE3A#, 16#FE3A#), -- PRESENTATION FORM FOR VERTICAL RIGHT TORTOISE SHELL BRACKET
+ (16#FE3B#, 16#FE3B#), -- PRESENTATION FORM FOR VERTICAL LEFT BLACK LENTICULAR BRACKET
+ (16#FE3C#, 16#FE3C#), -- PRESENTATION FORM FOR VERTICAL RIGHT BLACK LENTICULAR BRACKET
+ (16#FE3D#, 16#FE3D#), -- PRESENTATION FORM FOR VERTICAL LEFT DOUBLE ANGLE BRACKET
+ (16#FE3E#, 16#FE3E#), -- PRESENTATION FORM FOR VERTICAL RIGHT DOUBLE ANGLE BRACKET
+ (16#FE3F#, 16#FE3F#), -- PRESENTATION FORM FOR VERTICAL LEFT ANGLE BRACKET
+ (16#FE40#, 16#FE40#), -- PRESENTATION FORM FOR VERTICAL RIGHT ANGLE BRACKET
+ (16#FE41#, 16#FE41#), -- PRESENTATION FORM FOR VERTICAL LEFT CORNER BRACKET
+ (16#FE42#, 16#FE42#), -- PRESENTATION FORM FOR VERTICAL RIGHT CORNER BRACKET
+ (16#FE43#, 16#FE43#), -- PRESENTATION FORM FOR VERTICAL LEFT WHITE CORNER BRACKET
+ (16#FE44#, 16#FE44#), -- PRESENTATION FORM FOR VERTICAL RIGHT WHITE CORNER BRACKET
+ (16#FE47#, 16#FE47#), -- PRESENTATION FORM FOR VERTICAL LEFT SQUARE BRACKET
+ (16#FE48#, 16#FE48#), -- PRESENTATION FORM FOR VERTICAL RIGHT SQUARE BRACKET
+ (16#FE49#, 16#FE4C#), -- DASHED OVERLINE..DOUBLE WAVY OVERLINE
+ (16#FE4D#, 16#FE4F#), -- DASHED LOW LINE..WAVY LOW LINE
+ (16#FE50#, 16#FE52#), -- SMALL COMMA..SMALL FULL STOP
+ (16#FE54#, 16#FE57#), -- SMALL SEMICOLON..SMALL EXCLAMATION MARK
+ (16#FE58#, 16#FE58#), -- SMALL EM DASH
+ (16#FE59#, 16#FE59#), -- SMALL LEFT PARENTHESIS
+ (16#FE5A#, 16#FE5A#), -- SMALL RIGHT PARENTHESIS
+ (16#FE5B#, 16#FE5B#), -- SMALL LEFT CURLY BRACKET
+ (16#FE5C#, 16#FE5C#), -- SMALL RIGHT CURLY BRACKET
+ (16#FE5D#, 16#FE5D#), -- SMALL LEFT TORTOISE SHELL BRACKET
+ (16#FE5E#, 16#FE5E#), -- SMALL RIGHT TORTOISE SHELL BRACKET
+ (16#FE5F#, 16#FE61#), -- SMALL NUMBER SIGN..SMALL ASTERISK
+ (16#FE62#, 16#FE62#), -- SMALL PLUS SIGN
+ (16#FE63#, 16#FE63#), -- SMALL HYPHEN-MINUS
+ (16#FE64#, 16#FE66#), -- SMALL LESS-THAN SIGN..SMALL EQUALS SIGN
+ (16#FE68#, 16#FE68#), -- SMALL REVERSE SOLIDUS
+ (16#FE69#, 16#FE69#), -- SMALL DOLLAR SIGN
+ (16#FE6A#, 16#FE6B#), -- SMALL PERCENT SIGN..SMALL COMMERCIAL AT
+ (16#FE70#, 16#FE72#), -- ARABIC FATHATAN ISOLATED FORM..ARABIC DAMMATAN ISOLATED FORM
+ (16#FE74#, 16#FE74#), -- ARABIC KASRATAN ISOLATED FORM
+ (16#FE76#, 16#FEFC#), -- ARABIC FATHA ISOLATED FORM..ARABIC LIGATURE LAM WITH ALEF FINAL FORM
+ (16#FF01#, 16#FF03#), -- FULLWIDTH EXCLAMATION MARK..FULLWIDTH NUMBER SIGN
+ (16#FF04#, 16#FF04#), -- FULLWIDTH DOLLAR SIGN
+ (16#FF05#, 16#FF07#), -- FULLWIDTH PERCENT SIGN..FULLWIDTH APOSTROPHE
+ (16#FF08#, 16#FF08#), -- FULLWIDTH LEFT PARENTHESIS
+ (16#FF09#, 16#FF09#), -- FULLWIDTH RIGHT PARENTHESIS
+ (16#FF0A#, 16#FF0A#), -- FULLWIDTH ASTERISK
+ (16#FF0B#, 16#FF0B#), -- FULLWIDTH PLUS SIGN
+ (16#FF0C#, 16#FF0C#), -- FULLWIDTH COMMA
+ (16#FF0D#, 16#FF0D#), -- FULLWIDTH HYPHEN-MINUS
+ (16#FF0E#, 16#FF0F#), -- FULLWIDTH FULL STOP..FULLWIDTH SOLIDUS
+ (16#FF10#, 16#FF19#), -- FULLWIDTH DIGIT ZERO..FULLWIDTH DIGIT NINE
+ (16#FF1A#, 16#FF1B#), -- FULLWIDTH COLON..FULLWIDTH SEMICOLON
+ (16#FF1C#, 16#FF1E#), -- FULLWIDTH LESS-THAN SIGN..FULLWIDTH GREATER-THAN SIGN
+ (16#FF1F#, 16#FF20#), -- FULLWIDTH QUESTION MARK..FULLWIDTH COMMERCIAL AT
+ (16#FF21#, 16#FF3A#), -- FULLWIDTH LATIN CAPITAL LETTER A..FULLWIDTH LATIN CAPITAL LETTER Z
+ (16#FF3B#, 16#FF3B#), -- FULLWIDTH LEFT SQUARE BRACKET
+ (16#FF3C#, 16#FF3C#), -- FULLWIDTH REVERSE SOLIDUS
+ (16#FF3D#, 16#FF3D#), -- FULLWIDTH RIGHT SQUARE BRACKET
+ (16#FF3E#, 16#FF3E#), -- FULLWIDTH CIRCUMFLEX ACCENT
+ (16#FF3F#, 16#FF3F#), -- FULLWIDTH LOW LINE
+ (16#FF40#, 16#FF40#), -- FULLWIDTH GRAVE ACCENT
+ (16#FF41#, 16#FF5A#), -- FULLWIDTH LATIN SMALL LETTER A..FULLWIDTH LATIN SMALL LETTER Z
+ (16#FF5B#, 16#FF5B#), -- FULLWIDTH LEFT CURLY BRACKET
+ (16#FF5C#, 16#FF5C#), -- FULLWIDTH VERTICAL LINE
+ (16#FF5D#, 16#FF5D#), -- FULLWIDTH RIGHT CURLY BRACKET
+ (16#FF5E#, 16#FF5E#), -- FULLWIDTH TILDE
+ (16#FF5F#, 16#FF5F#), -- FULLWIDTH LEFT WHITE PARENTHESIS
+ (16#FF60#, 16#FF60#), -- FULLWIDTH RIGHT WHITE PARENTHESIS
+ (16#FF61#, 16#FF61#), -- HALFWIDTH IDEOGRAPHIC FULL STOP
+ (16#FF62#, 16#FF62#), -- HALFWIDTH LEFT CORNER BRACKET
+ (16#FF63#, 16#FF63#), -- HALFWIDTH RIGHT CORNER BRACKET
+ (16#FF64#, 16#FF65#), -- HALFWIDTH IDEOGRAPHIC COMMA..HALFWIDTH KATAKANA MIDDLE DOT
+ (16#FF66#, 16#FF6F#), -- HALFWIDTH KATAKANA LETTER WO..HALFWIDTH KATAKANA LETTER SMALL TU
+ (16#FF70#, 16#FF70#), -- HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK
+ (16#FF71#, 16#FF9D#), -- HALFWIDTH KATAKANA LETTER A..HALFWIDTH KATAKANA LETTER N
+ (16#FF9E#, 16#FF9F#), -- HALFWIDTH KATAKANA VOICED SOUND MARK..HALFWIDTH KATAKANA SEMI-VOICED SOUND MARK
+ (16#FFA0#, 16#FFBE#), -- HALFWIDTH HANGUL FILLER..HALFWIDTH HANGUL LETTER HIEUH
+ (16#FFC2#, 16#FFC7#), -- HALFWIDTH HANGUL LETTER A..HALFWIDTH HANGUL LETTER E
+ (16#FFCA#, 16#FFCF#), -- HALFWIDTH HANGUL LETTER YEO..HALFWIDTH HANGUL LETTER OE
+ (16#FFD2#, 16#FFD7#), -- HALFWIDTH HANGUL LETTER YO..HALFWIDTH HANGUL LETTER YU
+ (16#FFDA#, 16#FFDC#), -- HALFWIDTH HANGUL LETTER EU..HALFWIDTH HANGUL LETTER I
+ (16#FFE0#, 16#FFE1#), -- FULLWIDTH CENT SIGN..FULLWIDTH POUND SIGN
+ (16#FFE2#, 16#FFE2#), -- FULLWIDTH NOT SIGN
+ (16#FFE3#, 16#FFE3#), -- FULLWIDTH MACRON
+ (16#FFE4#, 16#FFE4#), -- FULLWIDTH BROKEN BAR
+ (16#FFE5#, 16#FFE6#), -- FULLWIDTH YEN SIGN..FULLWIDTH WON SIGN
+ (16#FFE8#, 16#FFE8#), -- HALFWIDTH FORMS LIGHT VERTICAL
+ (16#FFE9#, 16#FFEC#), -- HALFWIDTH LEFTWARDS ARROW..HALFWIDTH DOWNWARDS ARROW
+ (16#FFED#, 16#FFEE#), -- HALFWIDTH BLACK SQUARE..HALFWIDTH WHITE CIRCLE
+ (16#1D15E#, 16#1D164#), -- MUSICAL SYMBOL HALF NOTE..MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE
+ (16#1D1BB#, 16#1D1C0#), -- MUSICAL SYMBOL MINIMA..MUSICAL SYMBOL FUSA BLACK
+ (16#1D400#, 16#1D454#), -- MATHEMATICAL BOLD CAPITAL A..MATHEMATICAL ITALIC SMALL G
+ (16#1D456#, 16#1D49C#), -- MATHEMATICAL ITALIC SMALL I..MATHEMATICAL SCRIPT CAPITAL A
+ (16#1D49E#, 16#1D49F#), -- MATHEMATICAL SCRIPT CAPITAL C..MATHEMATICAL SCRIPT CAPITAL D
+ (16#1D4A2#, 16#1D4A2#), -- MATHEMATICAL SCRIPT CAPITAL G
+ (16#1D4A5#, 16#1D4A6#), -- MATHEMATICAL SCRIPT CAPITAL J..MATHEMATICAL SCRIPT CAPITAL K
+ (16#1D4A9#, 16#1D4AC#), -- MATHEMATICAL SCRIPT CAPITAL N..MATHEMATICAL SCRIPT CAPITAL Q
+ (16#1D4AE#, 16#1D4B9#), -- MATHEMATICAL SCRIPT CAPITAL S..MATHEMATICAL SCRIPT SMALL D
+ (16#1D4BB#, 16#1D4BB#), -- MATHEMATICAL SCRIPT SMALL F
+ (16#1D4BD#, 16#1D4C3#), -- MATHEMATICAL SCRIPT SMALL H..MATHEMATICAL SCRIPT SMALL N
+ (16#1D4C5#, 16#1D505#), -- MATHEMATICAL SCRIPT SMALL P..MATHEMATICAL FRAKTUR CAPITAL B
+ (16#1D507#, 16#1D50A#), -- MATHEMATICAL FRAKTUR CAPITAL D..MATHEMATICAL FRAKTUR CAPITAL G
+ (16#1D50D#, 16#1D514#), -- MATHEMATICAL FRAKTUR CAPITAL J..MATHEMATICAL FRAKTUR CAPITAL Q
+ (16#1D516#, 16#1D51C#), -- MATHEMATICAL FRAKTUR CAPITAL S..MATHEMATICAL FRAKTUR CAPITAL Y
+ (16#1D51E#, 16#1D539#), -- MATHEMATICAL FRAKTUR SMALL A..MATHEMATICAL DOUBLE-STRUCK CAPITAL B
+ (16#1D53B#, 16#1D53E#), -- MATHEMATICAL DOUBLE-STRUCK CAPITAL D..MATHEMATICAL DOUBLE-STRUCK CAPITAL G
+ (16#1D540#, 16#1D544#), -- MATHEMATICAL DOUBLE-STRUCK CAPITAL I..MATHEMATICAL DOUBLE-STRUCK CAPITAL M
+ (16#1D546#, 16#1D546#), -- MATHEMATICAL DOUBLE-STRUCK CAPITAL O
+ (16#1D54A#, 16#1D550#), -- MATHEMATICAL DOUBLE-STRUCK CAPITAL S..MATHEMATICAL DOUBLE-STRUCK CAPITAL Y
+ (16#1D552#, 16#1D6A5#), -- MATHEMATICAL DOUBLE-STRUCK SMALL A..MATHEMATICAL ITALIC SMALL DOTLESS J
+ (16#1D6A8#, 16#1D6C0#), -- MATHEMATICAL BOLD CAPITAL ALPHA..MATHEMATICAL BOLD CAPITAL OMEGA
+ (16#1D6C1#, 16#1D6C1#), -- MATHEMATICAL BOLD NABLA
+ (16#1D6C2#, 16#1D6DA#), -- MATHEMATICAL BOLD SMALL ALPHA..MATHEMATICAL BOLD SMALL OMEGA
+ (16#1D6DB#, 16#1D6DB#), -- MATHEMATICAL BOLD PARTIAL DIFFERENTIAL
+ (16#1D6DC#, 16#1D6FA#), -- MATHEMATICAL BOLD EPSILON SYMBOL..MATHEMATICAL ITALIC CAPITAL OMEGA
+ (16#1D6FB#, 16#1D6FB#), -- MATHEMATICAL ITALIC NABLA
+ (16#1D6FC#, 16#1D714#), -- MATHEMATICAL ITALIC SMALL ALPHA..MATHEMATICAL ITALIC SMALL OMEGA
+ (16#1D715#, 16#1D715#), -- MATHEMATICAL ITALIC PARTIAL DIFFERENTIAL
+ (16#1D716#, 16#1D734#), -- MATHEMATICAL ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD ITALIC CAPITAL OMEGA
+ (16#1D735#, 16#1D735#), -- MATHEMATICAL BOLD ITALIC NABLA
+ (16#1D736#, 16#1D74E#), -- MATHEMATICAL BOLD ITALIC SMALL ALPHA..MATHEMATICAL BOLD ITALIC SMALL OMEGA
+ (16#1D74F#, 16#1D74F#), -- MATHEMATICAL BOLD ITALIC PARTIAL DIFFERENTIAL
+ (16#1D750#, 16#1D76E#), -- MATHEMATICAL BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL SANS-SERIF BOLD CAPITAL OMEGA
+ (16#1D76F#, 16#1D76F#), -- MATHEMATICAL SANS-SERIF BOLD NABLA
+ (16#1D770#, 16#1D788#), -- MATHEMATICAL SANS-SERIF BOLD SMALL ALPHA..MATHEMATICAL SANS-SERIF BOLD SMALL OMEGA
+ (16#1D789#, 16#1D789#), -- MATHEMATICAL SANS-SERIF BOLD PARTIAL DIFFERENTIAL
+ (16#1D78A#, 16#1D7A8#), -- MATHEMATICAL SANS-SERIF BOLD EPSILON SYMBOL..MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL OMEGA
+ (16#1D7A9#, 16#1D7A9#), -- MATHEMATICAL SANS-SERIF BOLD ITALIC NABLA
+ (16#1D7AA#, 16#1D7C2#), -- MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA..MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA
+ (16#1D7C3#, 16#1D7C3#), -- MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL
+ (16#1D7C4#, 16#1D7CB#), -- MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
+ (16#1D7CE#, 16#1D7FF#), -- MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
+ (16#1EE00#, 16#1EE03#), -- ARABIC MATHEMATICAL ALEF..ARABIC MATHEMATICAL DAL
+ (16#1EE05#, 16#1EE1F#), -- ARABIC MATHEMATICAL WAW..ARABIC MATHEMATICAL DOTLESS QAF
+ (16#1EE21#, 16#1EE22#), -- ARABIC MATHEMATICAL INITIAL BEH..ARABIC MATHEMATICAL INITIAL JEEM
+ (16#1EE24#, 16#1EE24#), -- ARABIC MATHEMATICAL INITIAL HEH
+ (16#1EE27#, 16#1EE27#), -- ARABIC MATHEMATICAL INITIAL HAH
+ (16#1EE29#, 16#1EE32#), -- ARABIC MATHEMATICAL INITIAL YEH..ARABIC MATHEMATICAL INITIAL QAF
+ (16#1EE34#, 16#1EE37#), -- ARABIC MATHEMATICAL INITIAL SHEEN..ARABIC MATHEMATICAL INITIAL KHAH
+ (16#1EE39#, 16#1EE39#), -- ARABIC MATHEMATICAL INITIAL DAD
+ (16#1EE3B#, 16#1EE3B#), -- ARABIC MATHEMATICAL INITIAL GHAIN
+ (16#1EE42#, 16#1EE42#), -- ARABIC MATHEMATICAL TAILED JEEM
+ (16#1EE47#, 16#1EE47#), -- ARABIC MATHEMATICAL TAILED HAH
+ (16#1EE49#, 16#1EE49#), -- ARABIC MATHEMATICAL TAILED YEH
+ (16#1EE4B#, 16#1EE4B#), -- ARABIC MATHEMATICAL TAILED LAM
+ (16#1EE4D#, 16#1EE4F#), -- ARABIC MATHEMATICAL TAILED NOON..ARABIC MATHEMATICAL TAILED AIN
+ (16#1EE51#, 16#1EE52#), -- ARABIC MATHEMATICAL TAILED SAD..ARABIC MATHEMATICAL TAILED QAF
+ (16#1EE54#, 16#1EE54#), -- ARABIC MATHEMATICAL TAILED SHEEN
+ (16#1EE57#, 16#1EE57#), -- ARABIC MATHEMATICAL TAILED KHAH
+ (16#1EE59#, 16#1EE59#), -- ARABIC MATHEMATICAL TAILED DAD
+ (16#1EE5B#, 16#1EE5B#), -- ARABIC MATHEMATICAL TAILED GHAIN
+ (16#1EE5D#, 16#1EE5D#), -- ARABIC MATHEMATICAL TAILED DOTLESS NOON
+ (16#1EE5F#, 16#1EE5F#), -- ARABIC MATHEMATICAL TAILED DOTLESS QAF
+ (16#1EE61#, 16#1EE62#), -- ARABIC MATHEMATICAL STRETCHED BEH..ARABIC MATHEMATICAL STRETCHED JEEM
+ (16#1EE64#, 16#1EE64#), -- ARABIC MATHEMATICAL STRETCHED HEH
+ (16#1EE67#, 16#1EE6A#), -- ARABIC MATHEMATICAL STRETCHED HAH..ARABIC MATHEMATICAL STRETCHED KAF
+ (16#1EE6C#, 16#1EE72#), -- ARABIC MATHEMATICAL STRETCHED MEEM..ARABIC MATHEMATICAL STRETCHED QAF
+ (16#1EE74#, 16#1EE77#), -- ARABIC MATHEMATICAL STRETCHED SHEEN..ARABIC MATHEMATICAL STRETCHED KHAH
+ (16#1EE79#, 16#1EE7C#), -- ARABIC MATHEMATICAL STRETCHED DAD..ARABIC MATHEMATICAL STRETCHED DOTLESS BEH
+ (16#1EE7E#, 16#1EE7E#), -- ARABIC MATHEMATICAL STRETCHED DOTLESS FEH
+ (16#1EE80#, 16#1EE89#), -- ARABIC MATHEMATICAL LOOPED ALEF..ARABIC MATHEMATICAL LOOPED YEH
+ (16#1EE8B#, 16#1EE9B#), -- ARABIC MATHEMATICAL LOOPED LAM..ARABIC MATHEMATICAL LOOPED GHAIN
+ (16#1EEA1#, 16#1EEA3#), -- ARABIC MATHEMATICAL DOUBLE-STRUCK BEH..ARABIC MATHEMATICAL DOUBLE-STRUCK DAL
+ (16#1EEA5#, 16#1EEA9#), -- ARABIC MATHEMATICAL DOUBLE-STRUCK WAW..ARABIC MATHEMATICAL DOUBLE-STRUCK YEH
+ (16#1EEAB#, 16#1EEBB#), -- ARABIC MATHEMATICAL DOUBLE-STRUCK LAM..ARABIC MATHEMATICAL DOUBLE-STRUCK GHAIN
+ (16#1F100#, 16#1F10A#), -- DIGIT ZERO FULL STOP..DIGIT NINE COMMA
+ (16#1F110#, 16#1F12E#), -- PARENTHESIZED LATIN CAPITAL LETTER A..CIRCLED WZ
+ (16#1F130#, 16#1F14F#), -- SQUARED LATIN CAPITAL LETTER A..SQUARED WC
+ (16#1F16A#, 16#1F16C#), -- RAISED MC SIGN..RAISED MR SIGN
+ (16#1F190#, 16#1F190#), -- SQUARE DJ
+ (16#1F200#, 16#1F202#), -- SQUARE HIRAGANA HOKA..SQUARED KATAKANA SA
+ (16#1F210#, 16#1F23B#), -- SQUARED CJK UNIFIED IDEOGRAPH-624B..SQUARED CJK UNIFIED IDEOGRAPH-914D
+ (16#1F240#, 16#1F248#), -- TORTOISE SHELL BRACKETED CJK UNIFIED IDEOGRAPH-672C..TORTOISE SHELL BRACKETED CJK UNIFIED IDEOGRAPH-6557
+ (16#1F250#, 16#1F251#), -- CIRCLED IDEOGRAPH ADVANTAGE..CIRCLED IDEOGRAPH ACCEPT
+ (16#1FBF0#, 16#1FBF9#), -- SEGMENTED DIGIT ZERO..SEGMENTED DIGIT NINE
+ (16#2F800#, 16#2FA1D#)); -- CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
+
+ pragma Warnings (On);
+ -- Temporary until pragma Warnings at start can be activated ???
+
+ type Decomposition_Mapping is record
+ Item : UTF_32;
+ First_Char_Mapping : UTF_32;
+ end record;
+ -- Item is a UTF_32 character with a decomposition mapping.
+ -- First_Char_Mapping is the first UTF_32 character of the decomposition
+ -- mapping of Item.
+
+ type Unicode_Decomposition_Array is
+ array (Positive range <>) of Decomposition_Mapping;
+
+ Unicode_Decomposition : constant Unicode_Decomposition_Array := (
+ (16#00A0#, 16#0020#),
+ (16#00A8#, 16#0020#),
+ (16#00AA#, 16#0061#),
+ (16#00AF#, 16#0020#),
+ (16#00B2#, 16#0032#),
+ (16#00B3#, 16#0033#),
+ (16#00B4#, 16#0020#),
+ (16#00B5#, 16#03BC#),
+ (16#00B8#, 16#0020#),
+ (16#00B9#, 16#0031#),
+ (16#00BA#, 16#006F#),
+ (16#00BC#, 16#0031#),
+ (16#00BD#, 16#0031#),
+ (16#00BE#, 16#0033#),
+ (16#00C0#, 16#0041#),
+ (16#00C1#, 16#0041#),
+ (16#00C2#, 16#0041#),
+ (16#00C3#, 16#0041#),
+ (16#00C4#, 16#0041#),
+ (16#00C5#, 16#0041#),
+ (16#00C7#, 16#0043#),
+ (16#00C8#, 16#0045#),
+ (16#00C9#, 16#0045#),
+ (16#00CA#, 16#0045#),
+ (16#00CB#, 16#0045#),
+ (16#00CC#, 16#0049#),
+ (16#00CD#, 16#0049#),
+ (16#00CE#, 16#0049#),
+ (16#00CF#, 16#0049#),
+ (16#00D1#, 16#004E#),
+ (16#00D2#, 16#004F#),
+ (16#00D3#, 16#004F#),
+ (16#00D4#, 16#004F#),
+ (16#00D5#, 16#004F#),
+ (16#00D6#, 16#004F#),
+ (16#00D9#, 16#0055#),
+ (16#00DA#, 16#0055#),
+ (16#00DB#, 16#0055#),
+ (16#00DC#, 16#0055#),
+ (16#00DD#, 16#0059#),
+ (16#00E0#, 16#0061#),
+ (16#00E1#, 16#0061#),
+ (16#00E2#, 16#0061#),
+ (16#00E3#, 16#0061#),
+ (16#00E4#, 16#0061#),
+ (16#00E5#, 16#0061#),
+ (16#00E7#, 16#0063#),
+ (16#00E8#, 16#0065#),
+ (16#00E9#, 16#0065#),
+ (16#00EA#, 16#0065#),
+ (16#00EB#, 16#0065#),
+ (16#00EC#, 16#0069#),
+ (16#00ED#, 16#0069#),
+ (16#00EE#, 16#0069#),
+ (16#00EF#, 16#0069#),
+ (16#00F1#, 16#006E#),
+ (16#00F2#, 16#006F#),
+ (16#00F3#, 16#006F#),
+ (16#00F4#, 16#006F#),
+ (16#00F5#, 16#006F#),
+ (16#00F6#, 16#006F#),
+ (16#00F9#, 16#0075#),
+ (16#00FA#, 16#0075#),
+ (16#00FB#, 16#0075#),
+ (16#00FC#, 16#0075#),
+ (16#00FD#, 16#0079#),
+ (16#00FF#, 16#0079#),
+ (16#0100#, 16#0041#),
+ (16#0101#, 16#0061#),
+ (16#0102#, 16#0041#),
+ (16#0103#, 16#0061#),
+ (16#0104#, 16#0041#),
+ (16#0105#, 16#0061#),
+ (16#0106#, 16#0043#),
+ (16#0107#, 16#0063#),
+ (16#0108#, 16#0043#),
+ (16#0109#, 16#0063#),
+ (16#010A#, 16#0043#),
+ (16#010B#, 16#0063#),
+ (16#010C#, 16#0043#),
+ (16#010D#, 16#0063#),
+ (16#010E#, 16#0044#),
+ (16#010F#, 16#0064#),
+ (16#0112#, 16#0045#),
+ (16#0113#, 16#0065#),
+ (16#0114#, 16#0045#),
+ (16#0115#, 16#0065#),
+ (16#0116#, 16#0045#),
+ (16#0117#, 16#0065#),
+ (16#0118#, 16#0045#),
+ (16#0119#, 16#0065#),
+ (16#011A#, 16#0045#),
+ (16#011B#, 16#0065#),
+ (16#011C#, 16#0047#),
+ (16#011D#, 16#0067#),
+ (16#011E#, 16#0047#),
+ (16#011F#, 16#0067#),
+ (16#0120#, 16#0047#),
+ (16#0121#, 16#0067#),
+ (16#0122#, 16#0047#),
+ (16#0123#, 16#0067#),
+ (16#0124#, 16#0048#),
+ (16#0125#, 16#0068#),
+ (16#0128#, 16#0049#),
+ (16#0129#, 16#0069#),
+ (16#012A#, 16#0049#),
+ (16#012B#, 16#0069#),
+ (16#012C#, 16#0049#),
+ (16#012D#, 16#0069#),
+ (16#012E#, 16#0049#),
+ (16#012F#, 16#0069#),
+ (16#0130#, 16#0049#),
+ (16#0132#, 16#0049#),
+ (16#0133#, 16#0069#),
+ (16#0134#, 16#004A#),
+ (16#0135#, 16#006A#),
+ (16#0136#, 16#004B#),
+ (16#0137#, 16#006B#),
+ (16#0139#, 16#004C#),
+ (16#013A#, 16#006C#),
+ (16#013B#, 16#004C#),
+ (16#013C#, 16#006C#),
+ (16#013D#, 16#004C#),
+ (16#013E#, 16#006C#),
+ (16#013F#, 16#004C#),
+ (16#0140#, 16#006C#),
+ (16#0143#, 16#004E#),
+ (16#0144#, 16#006E#),
+ (16#0145#, 16#004E#),
+ (16#0146#, 16#006E#),
+ (16#0147#, 16#004E#),
+ (16#0148#, 16#006E#),
+ (16#0149#, 16#02BC#),
+ (16#014C#, 16#004F#),
+ (16#014D#, 16#006F#),
+ (16#014E#, 16#004F#),
+ (16#014F#, 16#006F#),
+ (16#0150#, 16#004F#),
+ (16#0151#, 16#006F#),
+ (16#0154#, 16#0052#),
+ (16#0155#, 16#0072#),
+ (16#0156#, 16#0052#),
+ (16#0157#, 16#0072#),
+ (16#0158#, 16#0052#),
+ (16#0159#, 16#0072#),
+ (16#015A#, 16#0053#),
+ (16#015B#, 16#0073#),
+ (16#015C#, 16#0053#),
+ (16#015D#, 16#0073#),
+ (16#015E#, 16#0053#),
+ (16#015F#, 16#0073#),
+ (16#0160#, 16#0053#),
+ (16#0161#, 16#0073#),
+ (16#0162#, 16#0054#),
+ (16#0163#, 16#0074#),
+ (16#0164#, 16#0054#),
+ (16#0165#, 16#0074#),
+ (16#0168#, 16#0055#),
+ (16#0169#, 16#0075#),
+ (16#016A#, 16#0055#),
+ (16#016B#, 16#0075#),
+ (16#016C#, 16#0055#),
+ (16#016D#, 16#0075#),
+ (16#016E#, 16#0055#),
+ (16#016F#, 16#0075#),
+ (16#0170#, 16#0055#),
+ (16#0171#, 16#0075#),
+ (16#0172#, 16#0055#),
+ (16#0173#, 16#0075#),
+ (16#0174#, 16#0057#),
+ (16#0175#, 16#0077#),
+ (16#0176#, 16#0059#),
+ (16#0177#, 16#0079#),
+ (16#0178#, 16#0059#),
+ (16#0179#, 16#005A#),
+ (16#017A#, 16#007A#),
+ (16#017B#, 16#005A#),
+ (16#017C#, 16#007A#),
+ (16#017D#, 16#005A#),
+ (16#017E#, 16#007A#),
+ (16#017F#, 16#0073#),
+ (16#01A0#, 16#004F#),
+ (16#01A1#, 16#006F#),
+ (16#01AF#, 16#0055#),
+ (16#01B0#, 16#0075#),
+ (16#01C4#, 16#0044#),
+ (16#01C5#, 16#0044#),
+ (16#01C6#, 16#0064#),
+ (16#01C7#, 16#004C#),
+ (16#01C8#, 16#004C#),
+ (16#01C9#, 16#006C#),
+ (16#01CA#, 16#004E#),
+ (16#01CB#, 16#004E#),
+ (16#01CC#, 16#006E#),
+ (16#01CD#, 16#0041#),
+ (16#01CE#, 16#0061#),
+ (16#01CF#, 16#0049#),
+ (16#01D0#, 16#0069#),
+ (16#01D1#, 16#004F#),
+ (16#01D2#, 16#006F#),
+ (16#01D3#, 16#0055#),
+ (16#01D4#, 16#0075#),
+ (16#01D5#, 16#00DC#),
+ (16#01D6#, 16#00FC#),
+ (16#01D7#, 16#00DC#),
+ (16#01D8#, 16#00FC#),
+ (16#01D9#, 16#00DC#),
+ (16#01DA#, 16#00FC#),
+ (16#01DB#, 16#00DC#),
+ (16#01DC#, 16#00FC#),
+ (16#01DE#, 16#00C4#),
+ (16#01DF#, 16#00E4#),
+ (16#01E0#, 16#0226#),
+ (16#01E1#, 16#0227#),
+ (16#01E2#, 16#00C6#),
+ (16#01E3#, 16#00E6#),
+ (16#01E6#, 16#0047#),
+ (16#01E7#, 16#0067#),
+ (16#01E8#, 16#004B#),
+ (16#01E9#, 16#006B#),
+ (16#01EA#, 16#004F#),
+ (16#01EB#, 16#006F#),
+ (16#01EC#, 16#01EA#),
+ (16#01ED#, 16#01EB#),
+ (16#01EE#, 16#01B7#),
+ (16#01EF#, 16#0292#),
+ (16#01F0#, 16#006A#),
+ (16#01F1#, 16#0044#),
+ (16#01F2#, 16#0044#),
+ (16#01F3#, 16#0064#),
+ (16#01F4#, 16#0047#),
+ (16#01F5#, 16#0067#),
+ (16#01F8#, 16#004E#),
+ (16#01F9#, 16#006E#),
+ (16#01FA#, 16#00C5#),
+ (16#01FB#, 16#00E5#),
+ (16#01FC#, 16#00C6#),
+ (16#01FD#, 16#00E6#),
+ (16#01FE#, 16#00D8#),
+ (16#01FF#, 16#00F8#),
+ (16#0200#, 16#0041#),
+ (16#0201#, 16#0061#),
+ (16#0202#, 16#0041#),
+ (16#0203#, 16#0061#),
+ (16#0204#, 16#0045#),
+ (16#0205#, 16#0065#),
+ (16#0206#, 16#0045#),
+ (16#0207#, 16#0065#),
+ (16#0208#, 16#0049#),
+ (16#0209#, 16#0069#),
+ (16#020A#, 16#0049#),
+ (16#020B#, 16#0069#),
+ (16#020C#, 16#004F#),
+ (16#020D#, 16#006F#),
+ (16#020E#, 16#004F#),
+ (16#020F#, 16#006F#),
+ (16#0210#, 16#0052#),
+ (16#0211#, 16#0072#),
+ (16#0212#, 16#0052#),
+ (16#0213#, 16#0072#),
+ (16#0214#, 16#0055#),
+ (16#0215#, 16#0075#),
+ (16#0216#, 16#0055#),
+ (16#0217#, 16#0075#),
+ (16#0218#, 16#0053#),
+ (16#0219#, 16#0073#),
+ (16#021A#, 16#0054#),
+ (16#021B#, 16#0074#),
+ (16#021E#, 16#0048#),
+ (16#021F#, 16#0068#),
+ (16#0226#, 16#0041#),
+ (16#0227#, 16#0061#),
+ (16#0228#, 16#0045#),
+ (16#0229#, 16#0065#),
+ (16#022A#, 16#00D6#),
+ (16#022B#, 16#00F6#),
+ (16#022C#, 16#00D5#),
+ (16#022D#, 16#00F5#),
+ (16#022E#, 16#004F#),
+ (16#022F#, 16#006F#),
+ (16#0230#, 16#022E#),
+ (16#0231#, 16#022F#),
+ (16#0232#, 16#0059#),
+ (16#0233#, 16#0079#),
+ (16#02B0#, 16#0068#),
+ (16#02B1#, 16#0266#),
+ (16#02B2#, 16#006A#),
+ (16#02B3#, 16#0072#),
+ (16#02B4#, 16#0279#),
+ (16#02B5#, 16#027B#),
+ (16#02B6#, 16#0281#),
+ (16#02B7#, 16#0077#),
+ (16#02B8#, 16#0079#),
+ (16#02D8#, 16#0020#),
+ (16#02D9#, 16#0020#),
+ (16#02DA#, 16#0020#),
+ (16#02DB#, 16#0020#),
+ (16#02DC#, 16#0020#),
+ (16#02DD#, 16#0020#),
+ (16#02E0#, 16#0263#),
+ (16#02E1#, 16#006C#),
+ (16#02E2#, 16#0073#),
+ (16#02E3#, 16#0078#),
+ (16#02E4#, 16#0295#),
+ (16#0340#, 16#0300#),
+ (16#0341#, 16#0301#),
+ (16#0343#, 16#0313#),
+ (16#0344#, 16#0308#),
+ (16#0374#, 16#02B9#),
+ (16#037A#, 16#0020#),
+ (16#037E#, 16#003B#),
+ (16#0384#, 16#0020#),
+ (16#0385#, 16#00A8#),
+ (16#0386#, 16#0391#),
+ (16#0387#, 16#00B7#),
+ (16#0388#, 16#0395#),
+ (16#0389#, 16#0397#),
+ (16#038A#, 16#0399#),
+ (16#038C#, 16#039F#),
+ (16#038E#, 16#03A5#),
+ (16#038F#, 16#03A9#),
+ (16#0390#, 16#03CA#),
+ (16#03AA#, 16#0399#),
+ (16#03AB#, 16#03A5#),
+ (16#03AC#, 16#03B1#),
+ (16#03AD#, 16#03B5#),
+ (16#03AE#, 16#03B7#),
+ (16#03AF#, 16#03B9#),
+ (16#03B0#, 16#03CB#),
+ (16#03CA#, 16#03B9#),
+ (16#03CB#, 16#03C5#),
+ (16#03CC#, 16#03BF#),
+ (16#03CD#, 16#03C5#),
+ (16#03CE#, 16#03C9#),
+ (16#03D0#, 16#03B2#),
+ (16#03D1#, 16#03B8#),
+ (16#03D2#, 16#03A5#),
+ (16#03D3#, 16#03D2#),
+ (16#03D4#, 16#03D2#),
+ (16#03D5#, 16#03C6#),
+ (16#03D6#, 16#03C0#),
+ (16#03F0#, 16#03BA#),
+ (16#03F1#, 16#03C1#),
+ (16#03F2#, 16#03C2#),
+ (16#03F4#, 16#0398#),
+ (16#03F5#, 16#03B5#),
+ (16#03F9#, 16#03A3#),
+ (16#0400#, 16#0415#),
+ (16#0401#, 16#0415#),
+ (16#0403#, 16#0413#),
+ (16#0407#, 16#0406#),
+ (16#040C#, 16#041A#),
+ (16#040D#, 16#0418#),
+ (16#040E#, 16#0423#),
+ (16#0419#, 16#0418#),
+ (16#0439#, 16#0438#),
+ (16#0450#, 16#0435#),
+ (16#0451#, 16#0435#),
+ (16#0453#, 16#0433#),
+ (16#0457#, 16#0456#),
+ (16#045C#, 16#043A#),
+ (16#045D#, 16#0438#),
+ (16#045E#, 16#0443#),
+ (16#0476#, 16#0474#),
+ (16#0477#, 16#0475#),
+ (16#04C1#, 16#0416#),
+ (16#04C2#, 16#0436#),
+ (16#04D0#, 16#0410#),
+ (16#04D1#, 16#0430#),
+ (16#04D2#, 16#0410#),
+ (16#04D3#, 16#0430#),
+ (16#04D6#, 16#0415#),
+ (16#04D7#, 16#0435#),
+ (16#04DA#, 16#04D8#),
+ (16#04DB#, 16#04D9#),
+ (16#04DC#, 16#0416#),
+ (16#04DD#, 16#0436#),
+ (16#04DE#, 16#0417#),
+ (16#04DF#, 16#0437#),
+ (16#04E2#, 16#0418#),
+ (16#04E3#, 16#0438#),
+ (16#04E4#, 16#0418#),
+ (16#04E5#, 16#0438#),
+ (16#04E6#, 16#041E#),
+ (16#04E7#, 16#043E#),
+ (16#04EA#, 16#04E8#),
+ (16#04EB#, 16#04E9#),
+ (16#04EC#, 16#042D#),
+ (16#04ED#, 16#044D#),
+ (16#04EE#, 16#0423#),
+ (16#04EF#, 16#0443#),
+ (16#04F0#, 16#0423#),
+ (16#04F1#, 16#0443#),
+ (16#04F2#, 16#0423#),
+ (16#04F3#, 16#0443#),
+ (16#04F4#, 16#0427#),
+ (16#04F5#, 16#0447#),
+ (16#04F8#, 16#042B#),
+ (16#04F9#, 16#044B#),
+ (16#0587#, 16#0565#),
+ (16#0622#, 16#0627#),
+ (16#0623#, 16#0627#),
+ (16#0624#, 16#0648#),
+ (16#0625#, 16#0627#),
+ (16#0626#, 16#064A#),
+ (16#0675#, 16#0627#),
+ (16#0676#, 16#0648#),
+ (16#0677#, 16#06C7#),
+ (16#0678#, 16#064A#),
+ (16#06C0#, 16#06D5#),
+ (16#06C2#, 16#06C1#),
+ (16#06D3#, 16#06D2#),
+ (16#0929#, 16#0928#),
+ (16#0931#, 16#0930#),
+ (16#0934#, 16#0933#),
+ (16#0958#, 16#0915#),
+ (16#0959#, 16#0916#),
+ (16#095A#, 16#0917#),
+ (16#095B#, 16#091C#),
+ (16#095C#, 16#0921#),
+ (16#095D#, 16#0922#),
+ (16#095E#, 16#092B#),
+ (16#095F#, 16#092F#),
+ (16#09CB#, 16#09C7#),
+ (16#09CC#, 16#09C7#),
+ (16#09DC#, 16#09A1#),
+ (16#09DD#, 16#09A2#),
+ (16#09DF#, 16#09AF#),
+ (16#0A33#, 16#0A32#),
+ (16#0A36#, 16#0A38#),
+ (16#0A59#, 16#0A16#),
+ (16#0A5A#, 16#0A17#),
+ (16#0A5B#, 16#0A1C#),
+ (16#0A5E#, 16#0A2B#),
+ (16#0B48#, 16#0B47#),
+ (16#0B4B#, 16#0B47#),
+ (16#0B4C#, 16#0B47#),
+ (16#0B5C#, 16#0B21#),
+ (16#0B5D#, 16#0B22#),
+ (16#0B94#, 16#0B92#),
+ (16#0BCA#, 16#0BC6#),
+ (16#0BCB#, 16#0BC7#),
+ (16#0BCC#, 16#0BC6#),
+ (16#0C48#, 16#0C46#),
+ (16#0CC0#, 16#0CBF#),
+ (16#0CC7#, 16#0CC6#),
+ (16#0CC8#, 16#0CC6#),
+ (16#0CCA#, 16#0CC6#),
+ (16#0CCB#, 16#0CCA#),
+ (16#0D4A#, 16#0D46#),
+ (16#0D4B#, 16#0D47#),
+ (16#0D4C#, 16#0D46#),
+ (16#0DDA#, 16#0DD9#),
+ (16#0DDC#, 16#0DD9#),
+ (16#0DDD#, 16#0DDC#),
+ (16#0DDE#, 16#0DD9#),
+ (16#0E33#, 16#0E4D#),
+ (16#0EB3#, 16#0ECD#),
+ (16#0EDC#, 16#0EAB#),
+ (16#0EDD#, 16#0EAB#),
+ (16#0F0C#, 16#0F0B#),
+ (16#0F43#, 16#0F42#),
+ (16#0F4D#, 16#0F4C#),
+ (16#0F52#, 16#0F51#),
+ (16#0F57#, 16#0F56#),
+ (16#0F5C#, 16#0F5B#),
+ (16#0F69#, 16#0F40#),
+ (16#0F73#, 16#0F71#),
+ (16#0F75#, 16#0F71#),
+ (16#0F76#, 16#0FB2#),
+ (16#0F77#, 16#0FB2#),
+ (16#0F78#, 16#0FB3#),
+ (16#0F79#, 16#0FB3#),
+ (16#0F81#, 16#0F71#),
+ (16#0F93#, 16#0F92#),
+ (16#0F9D#, 16#0F9C#),
+ (16#0FA2#, 16#0FA1#),
+ (16#0FA7#, 16#0FA6#),
+ (16#0FAC#, 16#0FAB#),
+ (16#0FB9#, 16#0F90#),
+ (16#1026#, 16#1025#),
+ (16#10FC#, 16#10DC#),
+ (16#1B06#, 16#1B05#),
+ (16#1B08#, 16#1B07#),
+ (16#1B0A#, 16#1B09#),
+ (16#1B0C#, 16#1B0B#),
+ (16#1B0E#, 16#1B0D#),
+ (16#1B12#, 16#1B11#),
+ (16#1B3B#, 16#1B3A#),
+ (16#1B3D#, 16#1B3C#),
+ (16#1B40#, 16#1B3E#),
+ (16#1B41#, 16#1B3F#),
+ (16#1B43#, 16#1B42#),
+ (16#1D2C#, 16#0041#),
+ (16#1D2D#, 16#00C6#),
+ (16#1D2E#, 16#0042#),
+ (16#1D30#, 16#0044#),
+ (16#1D31#, 16#0045#),
+ (16#1D32#, 16#018E#),
+ (16#1D33#, 16#0047#),
+ (16#1D34#, 16#0048#),
+ (16#1D35#, 16#0049#),
+ (16#1D36#, 16#004A#),
+ (16#1D37#, 16#004B#),
+ (16#1D38#, 16#004C#),
+ (16#1D39#, 16#004D#),
+ (16#1D3A#, 16#004E#),
+ (16#1D3C#, 16#004F#),
+ (16#1D3D#, 16#0222#),
+ (16#1D3E#, 16#0050#),
+ (16#1D3F#, 16#0052#),
+ (16#1D40#, 16#0054#),
+ (16#1D41#, 16#0055#),
+ (16#1D42#, 16#0057#),
+ (16#1D43#, 16#0061#),
+ (16#1D44#, 16#0250#),
+ (16#1D45#, 16#0251#),
+ (16#1D46#, 16#1D02#),
+ (16#1D47#, 16#0062#),
+ (16#1D48#, 16#0064#),
+ (16#1D49#, 16#0065#),
+ (16#1D4A#, 16#0259#),
+ (16#1D4B#, 16#025B#),
+ (16#1D4C#, 16#025C#),
+ (16#1D4D#, 16#0067#),
+ (16#1D4F#, 16#006B#),
+ (16#1D50#, 16#006D#),
+ (16#1D51#, 16#014B#),
+ (16#1D52#, 16#006F#),
+ (16#1D53#, 16#0254#),
+ (16#1D54#, 16#1D16#),
+ (16#1D55#, 16#1D17#),
+ (16#1D56#, 16#0070#),
+ (16#1D57#, 16#0074#),
+ (16#1D58#, 16#0075#),
+ (16#1D59#, 16#1D1D#),
+ (16#1D5A#, 16#026F#),
+ (16#1D5B#, 16#0076#),
+ (16#1D5C#, 16#1D25#),
+ (16#1D5D#, 16#03B2#),
+ (16#1D5E#, 16#03B3#),
+ (16#1D5F#, 16#03B4#),
+ (16#1D60#, 16#03C6#),
+ (16#1D61#, 16#03C7#),
+ (16#1D62#, 16#0069#),
+ (16#1D63#, 16#0072#),
+ (16#1D64#, 16#0075#),
+ (16#1D65#, 16#0076#),
+ (16#1D66#, 16#03B2#),
+ (16#1D67#, 16#03B3#),
+ (16#1D68#, 16#03C1#),
+ (16#1D69#, 16#03C6#),
+ (16#1D6A#, 16#03C7#),
+ (16#1D78#, 16#043D#),
+ (16#1D9B#, 16#0252#),
+ (16#1D9C#, 16#0063#),
+ (16#1D9D#, 16#0255#),
+ (16#1D9E#, 16#00F0#),
+ (16#1D9F#, 16#025C#),
+ (16#1DA0#, 16#0066#),
+ (16#1DA1#, 16#025F#),
+ (16#1DA2#, 16#0261#),
+ (16#1DA3#, 16#0265#),
+ (16#1DA4#, 16#0268#),
+ (16#1DA5#, 16#0269#),
+ (16#1DA6#, 16#026A#),
+ (16#1DA7#, 16#1D7B#),
+ (16#1DA8#, 16#029D#),
+ (16#1DA9#, 16#026D#),
+ (16#1DAA#, 16#1D85#),
+ (16#1DAB#, 16#029F#),
+ (16#1DAC#, 16#0271#),
+ (16#1DAD#, 16#0270#),
+ (16#1DAE#, 16#0272#),
+ (16#1DAF#, 16#0273#),
+ (16#1DB0#, 16#0274#),
+ (16#1DB1#, 16#0275#),
+ (16#1DB2#, 16#0278#),
+ (16#1DB3#, 16#0282#),
+ (16#1DB4#, 16#0283#),
+ (16#1DB5#, 16#01AB#),
+ (16#1DB6#, 16#0289#),
+ (16#1DB7#, 16#028A#),
+ (16#1DB8#, 16#1D1C#),
+ (16#1DB9#, 16#028B#),
+ (16#1DBA#, 16#028C#),
+ (16#1DBB#, 16#007A#),
+ (16#1DBC#, 16#0290#),
+ (16#1DBD#, 16#0291#),
+ (16#1DBE#, 16#0292#),
+ (16#1DBF#, 16#03B8#),
+ (16#1E00#, 16#0041#),
+ (16#1E01#, 16#0061#),
+ (16#1E02#, 16#0042#),
+ (16#1E03#, 16#0062#),
+ (16#1E04#, 16#0042#),
+ (16#1E05#, 16#0062#),
+ (16#1E06#, 16#0042#),
+ (16#1E07#, 16#0062#),
+ (16#1E08#, 16#00C7#),
+ (16#1E09#, 16#00E7#),
+ (16#1E0A#, 16#0044#),
+ (16#1E0B#, 16#0064#),
+ (16#1E0C#, 16#0044#),
+ (16#1E0D#, 16#0064#),
+ (16#1E0E#, 16#0044#),
+ (16#1E0F#, 16#0064#),
+ (16#1E10#, 16#0044#),
+ (16#1E11#, 16#0064#),
+ (16#1E12#, 16#0044#),
+ (16#1E13#, 16#0064#),
+ (16#1E14#, 16#0112#),
+ (16#1E15#, 16#0113#),
+ (16#1E16#, 16#0112#),
+ (16#1E17#, 16#0113#),
+ (16#1E18#, 16#0045#),
+ (16#1E19#, 16#0065#),
+ (16#1E1A#, 16#0045#),
+ (16#1E1B#, 16#0065#),
+ (16#1E1C#, 16#0228#),
+ (16#1E1D#, 16#0229#),
+ (16#1E1E#, 16#0046#),
+ (16#1E1F#, 16#0066#),
+ (16#1E20#, 16#0047#),
+ (16#1E21#, 16#0067#),
+ (16#1E22#, 16#0048#),
+ (16#1E23#, 16#0068#),
+ (16#1E24#, 16#0048#),
+ (16#1E25#, 16#0068#),
+ (16#1E26#, 16#0048#),
+ (16#1E27#, 16#0068#),
+ (16#1E28#, 16#0048#),
+ (16#1E29#, 16#0068#),
+ (16#1E2A#, 16#0048#),
+ (16#1E2B#, 16#0068#),
+ (16#1E2C#, 16#0049#),
+ (16#1E2D#, 16#0069#),
+ (16#1E2E#, 16#00CF#),
+ (16#1E2F#, 16#00EF#),
+ (16#1E30#, 16#004B#),
+ (16#1E31#, 16#006B#),
+ (16#1E32#, 16#004B#),
+ (16#1E33#, 16#006B#),
+ (16#1E34#, 16#004B#),
+ (16#1E35#, 16#006B#),
+ (16#1E36#, 16#004C#),
+ (16#1E37#, 16#006C#),
+ (16#1E38#, 16#1E36#),
+ (16#1E39#, 16#1E37#),
+ (16#1E3A#, 16#004C#),
+ (16#1E3B#, 16#006C#),
+ (16#1E3C#, 16#004C#),
+ (16#1E3D#, 16#006C#),
+ (16#1E3E#, 16#004D#),
+ (16#1E3F#, 16#006D#),
+ (16#1E40#, 16#004D#),
+ (16#1E41#, 16#006D#),
+ (16#1E42#, 16#004D#),
+ (16#1E43#, 16#006D#),
+ (16#1E44#, 16#004E#),
+ (16#1E45#, 16#006E#),
+ (16#1E46#, 16#004E#),
+ (16#1E47#, 16#006E#),
+ (16#1E48#, 16#004E#),
+ (16#1E49#, 16#006E#),
+ (16#1E4A#, 16#004E#),
+ (16#1E4B#, 16#006E#),
+ (16#1E4C#, 16#00D5#),
+ (16#1E4D#, 16#00F5#),
+ (16#1E4E#, 16#00D5#),
+ (16#1E4F#, 16#00F5#),
+ (16#1E50#, 16#014C#),
+ (16#1E51#, 16#014D#),
+ (16#1E52#, 16#014C#),
+ (16#1E53#, 16#014D#),
+ (16#1E54#, 16#0050#),
+ (16#1E55#, 16#0070#),
+ (16#1E56#, 16#0050#),
+ (16#1E57#, 16#0070#),
+ (16#1E58#, 16#0052#),
+ (16#1E59#, 16#0072#),
+ (16#1E5A#, 16#0052#),
+ (16#1E5B#, 16#0072#),
+ (16#1E5C#, 16#1E5A#),
+ (16#1E5D#, 16#1E5B#),
+ (16#1E5E#, 16#0052#),
+ (16#1E5F#, 16#0072#),
+ (16#1E60#, 16#0053#),
+ (16#1E61#, 16#0073#),
+ (16#1E62#, 16#0053#),
+ (16#1E63#, 16#0073#),
+ (16#1E64#, 16#015A#),
+ (16#1E65#, 16#015B#),
+ (16#1E66#, 16#0160#),
+ (16#1E67#, 16#0161#),
+ (16#1E68#, 16#1E62#),
+ (16#1E69#, 16#1E63#),
+ (16#1E6A#, 16#0054#),
+ (16#1E6B#, 16#0074#),
+ (16#1E6C#, 16#0054#),
+ (16#1E6D#, 16#0074#),
+ (16#1E6E#, 16#0054#),
+ (16#1E6F#, 16#0074#),
+ (16#1E70#, 16#0054#),
+ (16#1E71#, 16#0074#),
+ (16#1E72#, 16#0055#),
+ (16#1E73#, 16#0075#),
+ (16#1E74#, 16#0055#),
+ (16#1E75#, 16#0075#),
+ (16#1E76#, 16#0055#),
+ (16#1E77#, 16#0075#),
+ (16#1E78#, 16#0168#),
+ (16#1E79#, 16#0169#),
+ (16#1E7A#, 16#016A#),
+ (16#1E7B#, 16#016B#),
+ (16#1E7C#, 16#0056#),
+ (16#1E7D#, 16#0076#),
+ (16#1E7E#, 16#0056#),
+ (16#1E7F#, 16#0076#),
+ (16#1E80#, 16#0057#),
+ (16#1E81#, 16#0077#),
+ (16#1E82#, 16#0057#),
+ (16#1E83#, 16#0077#),
+ (16#1E84#, 16#0057#),
+ (16#1E85#, 16#0077#),
+ (16#1E86#, 16#0057#),
+ (16#1E87#, 16#0077#),
+ (16#1E88#, 16#0057#),
+ (16#1E89#, 16#0077#),
+ (16#1E8A#, 16#0058#),
+ (16#1E8B#, 16#0078#),
+ (16#1E8C#, 16#0058#),
+ (16#1E8D#, 16#0078#),
+ (16#1E8E#, 16#0059#),
+ (16#1E8F#, 16#0079#),
+ (16#1E90#, 16#005A#),
+ (16#1E91#, 16#007A#),
+ (16#1E92#, 16#005A#),
+ (16#1E93#, 16#007A#),
+ (16#1E94#, 16#005A#),
+ (16#1E95#, 16#007A#),
+ (16#1E96#, 16#0068#),
+ (16#1E97#, 16#0074#),
+ (16#1E98#, 16#0077#),
+ (16#1E99#, 16#0079#),
+ (16#1E9A#, 16#0061#),
+ (16#1E9B#, 16#017F#),
+ (16#1EA0#, 16#0041#),
+ (16#1EA1#, 16#0061#),
+ (16#1EA2#, 16#0041#),
+ (16#1EA3#, 16#0061#),
+ (16#1EA4#, 16#00C2#),
+ (16#1EA5#, 16#00E2#),
+ (16#1EA6#, 16#00C2#),
+ (16#1EA7#, 16#00E2#),
+ (16#1EA8#, 16#00C2#),
+ (16#1EA9#, 16#00E2#),
+ (16#1EAA#, 16#00C2#),
+ (16#1EAB#, 16#00E2#),
+ (16#1EAC#, 16#1EA0#),
+ (16#1EAD#, 16#1EA1#),
+ (16#1EAE#, 16#0102#),
+ (16#1EAF#, 16#0103#),
+ (16#1EB0#, 16#0102#),
+ (16#1EB1#, 16#0103#),
+ (16#1EB2#, 16#0102#),
+ (16#1EB3#, 16#0103#),
+ (16#1EB4#, 16#0102#),
+ (16#1EB5#, 16#0103#),
+ (16#1EB6#, 16#1EA0#),
+ (16#1EB7#, 16#1EA1#),
+ (16#1EB8#, 16#0045#),
+ (16#1EB9#, 16#0065#),
+ (16#1EBA#, 16#0045#),
+ (16#1EBB#, 16#0065#),
+ (16#1EBC#, 16#0045#),
+ (16#1EBD#, 16#0065#),
+ (16#1EBE#, 16#00CA#),
+ (16#1EBF#, 16#00EA#),
+ (16#1EC0#, 16#00CA#),
+ (16#1EC1#, 16#00EA#),
+ (16#1EC2#, 16#00CA#),
+ (16#1EC3#, 16#00EA#),
+ (16#1EC4#, 16#00CA#),
+ (16#1EC5#, 16#00EA#),
+ (16#1EC6#, 16#1EB8#),
+ (16#1EC7#, 16#1EB9#),
+ (16#1EC8#, 16#0049#),
+ (16#1EC9#, 16#0069#),
+ (16#1ECA#, 16#0049#),
+ (16#1ECB#, 16#0069#),
+ (16#1ECC#, 16#004F#),
+ (16#1ECD#, 16#006F#),
+ (16#1ECE#, 16#004F#),
+ (16#1ECF#, 16#006F#),
+ (16#1ED0#, 16#00D4#),
+ (16#1ED1#, 16#00F4#),
+ (16#1ED2#, 16#00D4#),
+ (16#1ED3#, 16#00F4#),
+ (16#1ED4#, 16#00D4#),
+ (16#1ED5#, 16#00F4#),
+ (16#1ED6#, 16#00D4#),
+ (16#1ED7#, 16#00F4#),
+ (16#1ED8#, 16#1ECC#),
+ (16#1ED9#, 16#1ECD#),
+ (16#1EDA#, 16#01A0#),
+ (16#1EDB#, 16#01A1#),
+ (16#1EDC#, 16#01A0#),
+ (16#1EDD#, 16#01A1#),
+ (16#1EDE#, 16#01A0#),
+ (16#1EDF#, 16#01A1#),
+ (16#1EE0#, 16#01A0#),
+ (16#1EE1#, 16#01A1#),
+ (16#1EE2#, 16#01A0#),
+ (16#1EE3#, 16#01A1#),
+ (16#1EE4#, 16#0055#),
+ (16#1EE5#, 16#0075#),
+ (16#1EE6#, 16#0055#),
+ (16#1EE7#, 16#0075#),
+ (16#1EE8#, 16#01AF#),
+ (16#1EE9#, 16#01B0#),
+ (16#1EEA#, 16#01AF#),
+ (16#1EEB#, 16#01B0#),
+ (16#1EEC#, 16#01AF#),
+ (16#1EED#, 16#01B0#),
+ (16#1EEE#, 16#01AF#),
+ (16#1EEF#, 16#01B0#),
+ (16#1EF0#, 16#01AF#),
+ (16#1EF1#, 16#01B0#),
+ (16#1EF2#, 16#0059#),
+ (16#1EF3#, 16#0079#),
+ (16#1EF4#, 16#0059#),
+ (16#1EF5#, 16#0079#),
+ (16#1EF6#, 16#0059#),
+ (16#1EF7#, 16#0079#),
+ (16#1EF8#, 16#0059#),
+ (16#1EF9#, 16#0079#),
+ (16#1F00#, 16#03B1#),
+ (16#1F01#, 16#03B1#),
+ (16#1F02#, 16#1F00#),
+ (16#1F03#, 16#1F01#),
+ (16#1F04#, 16#1F00#),
+ (16#1F05#, 16#1F01#),
+ (16#1F06#, 16#1F00#),
+ (16#1F07#, 16#1F01#),
+ (16#1F08#, 16#0391#),
+ (16#1F09#, 16#0391#),
+ (16#1F0A#, 16#1F08#),
+ (16#1F0B#, 16#1F09#),
+ (16#1F0C#, 16#1F08#),
+ (16#1F0D#, 16#1F09#),
+ (16#1F0E#, 16#1F08#),
+ (16#1F0F#, 16#1F09#),
+ (16#1F10#, 16#03B5#),
+ (16#1F11#, 16#03B5#),
+ (16#1F12#, 16#1F10#),
+ (16#1F13#, 16#1F11#),
+ (16#1F14#, 16#1F10#),
+ (16#1F15#, 16#1F11#),
+ (16#1F18#, 16#0395#),
+ (16#1F19#, 16#0395#),
+ (16#1F1A#, 16#1F18#),
+ (16#1F1B#, 16#1F19#),
+ (16#1F1C#, 16#1F18#),
+ (16#1F1D#, 16#1F19#),
+ (16#1F20#, 16#03B7#),
+ (16#1F21#, 16#03B7#),
+ (16#1F22#, 16#1F20#),
+ (16#1F23#, 16#1F21#),
+ (16#1F24#, 16#1F20#),
+ (16#1F25#, 16#1F21#),
+ (16#1F26#, 16#1F20#),
+ (16#1F27#, 16#1F21#),
+ (16#1F28#, 16#0397#),
+ (16#1F29#, 16#0397#),
+ (16#1F2A#, 16#1F28#),
+ (16#1F2B#, 16#1F29#),
+ (16#1F2C#, 16#1F28#),
+ (16#1F2D#, 16#1F29#),
+ (16#1F2E#, 16#1F28#),
+ (16#1F2F#, 16#1F29#),
+ (16#1F30#, 16#03B9#),
+ (16#1F31#, 16#03B9#),
+ (16#1F32#, 16#1F30#),
+ (16#1F33#, 16#1F31#),
+ (16#1F34#, 16#1F30#),
+ (16#1F35#, 16#1F31#),
+ (16#1F36#, 16#1F30#),
+ (16#1F37#, 16#1F31#),
+ (16#1F38#, 16#0399#),
+ (16#1F39#, 16#0399#),
+ (16#1F3A#, 16#1F38#),
+ (16#1F3B#, 16#1F39#),
+ (16#1F3C#, 16#1F38#),
+ (16#1F3D#, 16#1F39#),
+ (16#1F3E#, 16#1F38#),
+ (16#1F3F#, 16#1F39#),
+ (16#1F40#, 16#03BF#),
+ (16#1F41#, 16#03BF#),
+ (16#1F42#, 16#1F40#),
+ (16#1F43#, 16#1F41#),
+ (16#1F44#, 16#1F40#),
+ (16#1F45#, 16#1F41#),
+ (16#1F48#, 16#039F#),
+ (16#1F49#, 16#039F#),
+ (16#1F4A#, 16#1F48#),
+ (16#1F4B#, 16#1F49#),
+ (16#1F4C#, 16#1F48#),
+ (16#1F4D#, 16#1F49#),
+ (16#1F50#, 16#03C5#),
+ (16#1F51#, 16#03C5#),
+ (16#1F52#, 16#1F50#),
+ (16#1F53#, 16#1F51#),
+ (16#1F54#, 16#1F50#),
+ (16#1F55#, 16#1F51#),
+ (16#1F56#, 16#1F50#),
+ (16#1F57#, 16#1F51#),
+ (16#1F59#, 16#03A5#),
+ (16#1F5B#, 16#1F59#),
+ (16#1F5D#, 16#1F59#),
+ (16#1F5F#, 16#1F59#),
+ (16#1F60#, 16#03C9#),
+ (16#1F61#, 16#03C9#),
+ (16#1F62#, 16#1F60#),
+ (16#1F63#, 16#1F61#),
+ (16#1F64#, 16#1F60#),
+ (16#1F65#, 16#1F61#),
+ (16#1F66#, 16#1F60#),
+ (16#1F67#, 16#1F61#),
+ (16#1F68#, 16#03A9#),
+ (16#1F69#, 16#03A9#),
+ (16#1F6A#, 16#1F68#),
+ (16#1F6B#, 16#1F69#),
+ (16#1F6C#, 16#1F68#),
+ (16#1F6D#, 16#1F69#),
+ (16#1F6E#, 16#1F68#),
+ (16#1F6F#, 16#1F69#),
+ (16#1F70#, 16#03B1#),
+ (16#1F71#, 16#03AC#),
+ (16#1F72#, 16#03B5#),
+ (16#1F73#, 16#03AD#),
+ (16#1F74#, 16#03B7#),
+ (16#1F75#, 16#03AE#),
+ (16#1F76#, 16#03B9#),
+ (16#1F77#, 16#03AF#),
+ (16#1F78#, 16#03BF#),
+ (16#1F79#, 16#03CC#),
+ (16#1F7A#, 16#03C5#),
+ (16#1F7B#, 16#03CD#),
+ (16#1F7C#, 16#03C9#),
+ (16#1F7D#, 16#03CE#),
+ (16#1F80#, 16#1F00#),
+ (16#1F81#, 16#1F01#),
+ (16#1F82#, 16#1F02#),
+ (16#1F83#, 16#1F03#),
+ (16#1F84#, 16#1F04#),
+ (16#1F85#, 16#1F05#),
+ (16#1F86#, 16#1F06#),
+ (16#1F87#, 16#1F07#),
+ (16#1F88#, 16#1F08#),
+ (16#1F89#, 16#1F09#),
+ (16#1F8A#, 16#1F0A#),
+ (16#1F8B#, 16#1F0B#),
+ (16#1F8C#, 16#1F0C#),
+ (16#1F8D#, 16#1F0D#),
+ (16#1F8E#, 16#1F0E#),
+ (16#1F8F#, 16#1F0F#),
+ (16#1F90#, 16#1F20#),
+ (16#1F91#, 16#1F21#),
+ (16#1F92#, 16#1F22#),
+ (16#1F93#, 16#1F23#),
+ (16#1F94#, 16#1F24#),
+ (16#1F95#, 16#1F25#),
+ (16#1F96#, 16#1F26#),
+ (16#1F97#, 16#1F27#),
+ (16#1F98#, 16#1F28#),
+ (16#1F99#, 16#1F29#),
+ (16#1F9A#, 16#1F2A#),
+ (16#1F9B#, 16#1F2B#),
+ (16#1F9C#, 16#1F2C#),
+ (16#1F9D#, 16#1F2D#),
+ (16#1F9E#, 16#1F2E#),
+ (16#1F9F#, 16#1F2F#),
+ (16#1FA0#, 16#1F60#),
+ (16#1FA1#, 16#1F61#),
+ (16#1FA2#, 16#1F62#),
+ (16#1FA3#, 16#1F63#),
+ (16#1FA4#, 16#1F64#),
+ (16#1FA5#, 16#1F65#),
+ (16#1FA6#, 16#1F66#),
+ (16#1FA7#, 16#1F67#),
+ (16#1FA8#, 16#1F68#),
+ (16#1FA9#, 16#1F69#),
+ (16#1FAA#, 16#1F6A#),
+ (16#1FAB#, 16#1F6B#),
+ (16#1FAC#, 16#1F6C#),
+ (16#1FAD#, 16#1F6D#),
+ (16#1FAE#, 16#1F6E#),
+ (16#1FAF#, 16#1F6F#),
+ (16#1FB0#, 16#03B1#),
+ (16#1FB1#, 16#03B1#),
+ (16#1FB2#, 16#1F70#),
+ (16#1FB3#, 16#03B1#),
+ (16#1FB4#, 16#03AC#),
+ (16#1FB6#, 16#03B1#),
+ (16#1FB7#, 16#1FB6#),
+ (16#1FB8#, 16#0391#),
+ (16#1FB9#, 16#0391#),
+ (16#1FBA#, 16#0391#),
+ (16#1FBB#, 16#0386#),
+ (16#1FBC#, 16#0391#),
+ (16#1FBD#, 16#0020#),
+ (16#1FBE#, 16#03B9#),
+ (16#1FBF#, 16#0020#),
+ (16#1FC0#, 16#0020#),
+ (16#1FC1#, 16#00A8#),
+ (16#1FC2#, 16#1F74#),
+ (16#1FC3#, 16#03B7#),
+ (16#1FC4#, 16#03AE#),
+ (16#1FC6#, 16#03B7#),
+ (16#1FC7#, 16#1FC6#),
+ (16#1FC8#, 16#0395#),
+ (16#1FC9#, 16#0388#),
+ (16#1FCA#, 16#0397#),
+ (16#1FCB#, 16#0389#),
+ (16#1FCC#, 16#0397#),
+ (16#1FCD#, 16#1FBF#),
+ (16#1FCE#, 16#1FBF#),
+ (16#1FCF#, 16#1FBF#),
+ (16#1FD0#, 16#03B9#),
+ (16#1FD1#, 16#03B9#),
+ (16#1FD2#, 16#03CA#),
+ (16#1FD3#, 16#0390#),
+ (16#1FD6#, 16#03B9#),
+ (16#1FD7#, 16#03CA#),
+ (16#1FD8#, 16#0399#),
+ (16#1FD9#, 16#0399#),
+ (16#1FDA#, 16#0399#),
+ (16#1FDB#, 16#038A#),
+ (16#1FDD#, 16#1FFE#),
+ (16#1FDE#, 16#1FFE#),
+ (16#1FDF#, 16#1FFE#),
+ (16#1FE0#, 16#03C5#),
+ (16#1FE1#, 16#03C5#),
+ (16#1FE2#, 16#03CB#),
+ (16#1FE3#, 16#03B0#),
+ (16#1FE4#, 16#03C1#),
+ (16#1FE5#, 16#03C1#),
+ (16#1FE6#, 16#03C5#),
+ (16#1FE7#, 16#03CB#),
+ (16#1FE8#, 16#03A5#),
+ (16#1FE9#, 16#03A5#),
+ (16#1FEA#, 16#03A5#),
+ (16#1FEB#, 16#038E#),
+ (16#1FEC#, 16#03A1#),
+ (16#1FED#, 16#00A8#),
+ (16#1FEE#, 16#0385#),
+ (16#1FEF#, 16#0060#),
+ (16#1FF2#, 16#1F7C#),
+ (16#1FF3#, 16#03C9#),
+ (16#1FF4#, 16#03CE#),
+ (16#1FF6#, 16#03C9#),
+ (16#1FF7#, 16#1FF6#),
+ (16#1FF8#, 16#039F#),
+ (16#1FF9#, 16#038C#),
+ (16#1FFA#, 16#03A9#),
+ (16#1FFB#, 16#038F#),
+ (16#1FFC#, 16#03A9#),
+ (16#1FFD#, 16#00B4#),
+ (16#1FFE#, 16#0020#),
+ (16#2000#, 16#2002#),
+ (16#2001#, 16#2003#),
+ (16#2002#, 16#0020#),
+ (16#2003#, 16#0020#),
+ (16#2004#, 16#0020#),
+ (16#2005#, 16#0020#),
+ (16#2006#, 16#0020#),
+ (16#2007#, 16#0020#),
+ (16#2008#, 16#0020#),
+ (16#2009#, 16#0020#),
+ (16#200A#, 16#0020#),
+ (16#2011#, 16#2010#),
+ (16#2017#, 16#0020#),
+ (16#2024#, 16#002E#),
+ (16#2025#, 16#002E#),
+ (16#2026#, 16#002E#),
+ (16#202F#, 16#0020#),
+ (16#2033#, 16#2032#),
+ (16#2034#, 16#2032#),
+ (16#2036#, 16#2035#),
+ (16#2037#, 16#2035#),
+ (16#203C#, 16#0021#),
+ (16#203E#, 16#0020#),
+ (16#2047#, 16#003F#),
+ (16#2048#, 16#003F#),
+ (16#2049#, 16#0021#),
+ (16#2057#, 16#2032#),
+ (16#205F#, 16#0020#),
+ (16#2070#, 16#0030#),
+ (16#2071#, 16#0069#),
+ (16#2074#, 16#0034#),
+ (16#2075#, 16#0035#),
+ (16#2076#, 16#0036#),
+ (16#2077#, 16#0037#),
+ (16#2078#, 16#0038#),
+ (16#2079#, 16#0039#),
+ (16#207A#, 16#002B#),
+ (16#207B#, 16#2212#),
+ (16#207C#, 16#003D#),
+ (16#207D#, 16#0028#),
+ (16#207E#, 16#0029#),
+ (16#207F#, 16#006E#),
+ (16#2080#, 16#0030#),
+ (16#2081#, 16#0031#),
+ (16#2082#, 16#0032#),
+ (16#2083#, 16#0033#),
+ (16#2084#, 16#0034#),
+ (16#2085#, 16#0035#),
+ (16#2086#, 16#0036#),
+ (16#2087#, 16#0037#),
+ (16#2088#, 16#0038#),
+ (16#2089#, 16#0039#),
+ (16#208A#, 16#002B#),
+ (16#208B#, 16#2212#),
+ (16#208C#, 16#003D#),
+ (16#208D#, 16#0028#),
+ (16#208E#, 16#0029#),
+ (16#2090#, 16#0061#),
+ (16#2091#, 16#0065#),
+ (16#2092#, 16#006F#),
+ (16#2093#, 16#0078#),
+ (16#2094#, 16#0259#),
+ (16#2095#, 16#0068#),
+ (16#2096#, 16#006B#),
+ (16#2097#, 16#006C#),
+ (16#2098#, 16#006D#),
+ (16#2099#, 16#006E#),
+ (16#209A#, 16#0070#),
+ (16#209B#, 16#0073#),
+ (16#209C#, 16#0074#),
+ (16#20A8#, 16#0052#),
+ (16#2100#, 16#0061#),
+ (16#2101#, 16#0061#),
+ (16#2102#, 16#0043#),
+ (16#2103#, 16#00B0#),
+ (16#2105#, 16#0063#),
+ (16#2106#, 16#0063#),
+ (16#2107#, 16#0190#),
+ (16#2109#, 16#00B0#),
+ (16#210A#, 16#0067#),
+ (16#210B#, 16#0048#),
+ (16#210C#, 16#0048#),
+ (16#210D#, 16#0048#),
+ (16#210E#, 16#0068#),
+ (16#210F#, 16#0127#),
+ (16#2110#, 16#0049#),
+ (16#2111#, 16#0049#),
+ (16#2112#, 16#004C#),
+ (16#2113#, 16#006C#),
+ (16#2115#, 16#004E#),
+ (16#2116#, 16#004E#),
+ (16#2119#, 16#0050#),
+ (16#211A#, 16#0051#),
+ (16#211B#, 16#0052#),
+ (16#211C#, 16#0052#),
+ (16#211D#, 16#0052#),
+ (16#2120#, 16#0053#),
+ (16#2121#, 16#0054#),
+ (16#2122#, 16#0054#),
+ (16#2124#, 16#005A#),
+ (16#2126#, 16#03A9#),
+ (16#2128#, 16#005A#),
+ (16#212A#, 16#004B#),
+ (16#212B#, 16#00C5#),
+ (16#212C#, 16#0042#),
+ (16#212D#, 16#0043#),
+ (16#212F#, 16#0065#),
+ (16#2130#, 16#0045#),
+ (16#2131#, 16#0046#),
+ (16#2133#, 16#004D#),
+ (16#2134#, 16#006F#),
+ (16#2135#, 16#05D0#),
+ (16#2136#, 16#05D1#),
+ (16#2137#, 16#05D2#),
+ (16#2138#, 16#05D3#),
+ (16#2139#, 16#0069#),
+ (16#213B#, 16#0046#),
+ (16#213C#, 16#03C0#),
+ (16#213D#, 16#03B3#),
+ (16#213E#, 16#0393#),
+ (16#213F#, 16#03A0#),
+ (16#2140#, 16#2211#),
+ (16#2145#, 16#0044#),
+ (16#2146#, 16#0064#),
+ (16#2147#, 16#0065#),
+ (16#2148#, 16#0069#),
+ (16#2149#, 16#006A#),
+ (16#2150#, 16#0031#),
+ (16#2151#, 16#0031#),
+ (16#2152#, 16#0031#),
+ (16#2153#, 16#0031#),
+ (16#2154#, 16#0032#),
+ (16#2155#, 16#0031#),
+ (16#2156#, 16#0032#),
+ (16#2157#, 16#0033#),
+ (16#2158#, 16#0034#),
+ (16#2159#, 16#0031#),
+ (16#215A#, 16#0035#),
+ (16#215B#, 16#0031#),
+ (16#215C#, 16#0033#),
+ (16#215D#, 16#0035#),
+ (16#215E#, 16#0037#),
+ (16#215F#, 16#0031#),
+ (16#2160#, 16#0049#),
+ (16#2161#, 16#0049#),
+ (16#2162#, 16#0049#),
+ (16#2163#, 16#0049#),
+ (16#2164#, 16#0056#),
+ (16#2165#, 16#0056#),
+ (16#2166#, 16#0056#),
+ (16#2167#, 16#0056#),
+ (16#2168#, 16#0049#),
+ (16#2169#, 16#0058#),
+ (16#216A#, 16#0058#),
+ (16#216B#, 16#0058#),
+ (16#216C#, 16#004C#),
+ (16#216D#, 16#0043#),
+ (16#216E#, 16#0044#),
+ (16#216F#, 16#004D#),
+ (16#2170#, 16#0069#),
+ (16#2171#, 16#0069#),
+ (16#2172#, 16#0069#),
+ (16#2173#, 16#0069#),
+ (16#2174#, 16#0076#),
+ (16#2175#, 16#0076#),
+ (16#2176#, 16#0076#),
+ (16#2177#, 16#0076#),
+ (16#2178#, 16#0069#),
+ (16#2179#, 16#0078#),
+ (16#217A#, 16#0078#),
+ (16#217B#, 16#0078#),
+ (16#217C#, 16#006C#),
+ (16#217D#, 16#0063#),
+ (16#217E#, 16#0064#),
+ (16#217F#, 16#006D#),
+ (16#2189#, 16#0030#),
+ (16#219A#, 16#2190#),
+ (16#219B#, 16#2192#),
+ (16#21AE#, 16#2194#),
+ (16#21CD#, 16#21D0#),
+ (16#21CE#, 16#21D4#),
+ (16#21CF#, 16#21D2#),
+ (16#2204#, 16#2203#),
+ (16#2209#, 16#2208#),
+ (16#220C#, 16#220B#),
+ (16#2224#, 16#2223#),
+ (16#2226#, 16#2225#),
+ (16#222C#, 16#222B#),
+ (16#222D#, 16#222B#),
+ (16#222F#, 16#222E#),
+ (16#2230#, 16#222E#),
+ (16#2241#, 16#223C#),
+ (16#2244#, 16#2243#),
+ (16#2247#, 16#2245#),
+ (16#2249#, 16#2248#),
+ (16#2260#, 16#003D#),
+ (16#2262#, 16#2261#),
+ (16#226D#, 16#224D#),
+ (16#226E#, 16#003C#),
+ (16#226F#, 16#003E#),
+ (16#2270#, 16#2264#),
+ (16#2271#, 16#2265#),
+ (16#2274#, 16#2272#),
+ (16#2275#, 16#2273#),
+ (16#2278#, 16#2276#),
+ (16#2279#, 16#2277#),
+ (16#2280#, 16#227A#),
+ (16#2281#, 16#227B#),
+ (16#2284#, 16#2282#),
+ (16#2285#, 16#2283#),
+ (16#2288#, 16#2286#),
+ (16#2289#, 16#2287#),
+ (16#22AC#, 16#22A2#),
+ (16#22AD#, 16#22A8#),
+ (16#22AE#, 16#22A9#),
+ (16#22AF#, 16#22AB#),
+ (16#22E0#, 16#227C#),
+ (16#22E1#, 16#227D#),
+ (16#22E2#, 16#2291#),
+ (16#22E3#, 16#2292#),
+ (16#22EA#, 16#22B2#),
+ (16#22EB#, 16#22B3#),
+ (16#22EC#, 16#22B4#),
+ (16#22ED#, 16#22B5#),
+ (16#2329#, 16#3008#),
+ (16#232A#, 16#3009#),
+ (16#2460#, 16#0031#),
+ (16#2461#, 16#0032#),
+ (16#2462#, 16#0033#),
+ (16#2463#, 16#0034#),
+ (16#2464#, 16#0035#),
+ (16#2465#, 16#0036#),
+ (16#2466#, 16#0037#),
+ (16#2467#, 16#0038#),
+ (16#2468#, 16#0039#),
+ (16#2469#, 16#0031#),
+ (16#246A#, 16#0031#),
+ (16#246B#, 16#0031#),
+ (16#246C#, 16#0031#),
+ (16#246D#, 16#0031#),
+ (16#246E#, 16#0031#),
+ (16#246F#, 16#0031#),
+ (16#2470#, 16#0031#),
+ (16#2471#, 16#0031#),
+ (16#2472#, 16#0031#),
+ (16#2473#, 16#0032#),
+ (16#2474#, 16#0028#),
+ (16#2475#, 16#0028#),
+ (16#2476#, 16#0028#),
+ (16#2477#, 16#0028#),
+ (16#2478#, 16#0028#),
+ (16#2479#, 16#0028#),
+ (16#247A#, 16#0028#),
+ (16#247B#, 16#0028#),
+ (16#247C#, 16#0028#),
+ (16#247D#, 16#0028#),
+ (16#247E#, 16#0028#),
+ (16#247F#, 16#0028#),
+ (16#2480#, 16#0028#),
+ (16#2481#, 16#0028#),
+ (16#2482#, 16#0028#),
+ (16#2483#, 16#0028#),
+ (16#2484#, 16#0028#),
+ (16#2485#, 16#0028#),
+ (16#2486#, 16#0028#),
+ (16#2487#, 16#0028#),
+ (16#2488#, 16#0031#),
+ (16#2489#, 16#0032#),
+ (16#248A#, 16#0033#),
+ (16#248B#, 16#0034#),
+ (16#248C#, 16#0035#),
+ (16#248D#, 16#0036#),
+ (16#248E#, 16#0037#),
+ (16#248F#, 16#0038#),
+ (16#2490#, 16#0039#),
+ (16#2491#, 16#0031#),
+ (16#2492#, 16#0031#),
+ (16#2493#, 16#0031#),
+ (16#2494#, 16#0031#),
+ (16#2495#, 16#0031#),
+ (16#2496#, 16#0031#),
+ (16#2497#, 16#0031#),
+ (16#2498#, 16#0031#),
+ (16#2499#, 16#0031#),
+ (16#249A#, 16#0031#),
+ (16#249B#, 16#0032#),
+ (16#249C#, 16#0028#),
+ (16#249D#, 16#0028#),
+ (16#249E#, 16#0028#),
+ (16#249F#, 16#0028#),
+ (16#24A0#, 16#0028#),
+ (16#24A1#, 16#0028#),
+ (16#24A2#, 16#0028#),
+ (16#24A3#, 16#0028#),
+ (16#24A4#, 16#0028#),
+ (16#24A5#, 16#0028#),
+ (16#24A6#, 16#0028#),
+ (16#24A7#, 16#0028#),
+ (16#24A8#, 16#0028#),
+ (16#24A9#, 16#0028#),
+ (16#24AA#, 16#0028#),
+ (16#24AB#, 16#0028#),
+ (16#24AC#, 16#0028#),
+ (16#24AD#, 16#0028#),
+ (16#24AE#, 16#0028#),
+ (16#24AF#, 16#0028#),
+ (16#24B0#, 16#0028#),
+ (16#24B1#, 16#0028#),
+ (16#24B2#, 16#0028#),
+ (16#24B3#, 16#0028#),
+ (16#24B4#, 16#0028#),
+ (16#24B5#, 16#0028#),
+ (16#24B6#, 16#0041#),
+ (16#24B7#, 16#0042#),
+ (16#24B8#, 16#0043#),
+ (16#24B9#, 16#0044#),
+ (16#24BA#, 16#0045#),
+ (16#24BB#, 16#0046#),
+ (16#24BC#, 16#0047#),
+ (16#24BD#, 16#0048#),
+ (16#24BE#, 16#0049#),
+ (16#24BF#, 16#004A#),
+ (16#24C0#, 16#004B#),
+ (16#24C1#, 16#004C#),
+ (16#24C2#, 16#004D#),
+ (16#24C3#, 16#004E#),
+ (16#24C4#, 16#004F#),
+ (16#24C5#, 16#0050#),
+ (16#24C6#, 16#0051#),
+ (16#24C7#, 16#0052#),
+ (16#24C8#, 16#0053#),
+ (16#24C9#, 16#0054#),
+ (16#24CA#, 16#0055#),
+ (16#24CB#, 16#0056#),
+ (16#24CC#, 16#0057#),
+ (16#24CD#, 16#0058#),
+ (16#24CE#, 16#0059#),
+ (16#24CF#, 16#005A#),
+ (16#24D0#, 16#0061#),
+ (16#24D1#, 16#0062#),
+ (16#24D2#, 16#0063#),
+ (16#24D3#, 16#0064#),
+ (16#24D4#, 16#0065#),
+ (16#24D5#, 16#0066#),
+ (16#24D6#, 16#0067#),
+ (16#24D7#, 16#0068#),
+ (16#24D8#, 16#0069#),
+ (16#24D9#, 16#006A#),
+ (16#24DA#, 16#006B#),
+ (16#24DB#, 16#006C#),
+ (16#24DC#, 16#006D#),
+ (16#24DD#, 16#006E#),
+ (16#24DE#, 16#006F#),
+ (16#24DF#, 16#0070#),
+ (16#24E0#, 16#0071#),
+ (16#24E1#, 16#0072#),
+ (16#24E2#, 16#0073#),
+ (16#24E3#, 16#0074#),
+ (16#24E4#, 16#0075#),
+ (16#24E5#, 16#0076#),
+ (16#24E6#, 16#0077#),
+ (16#24E7#, 16#0078#),
+ (16#24E8#, 16#0079#),
+ (16#24E9#, 16#007A#),
+ (16#24EA#, 16#0030#),
+ (16#2A0C#, 16#222B#),
+ (16#2A74#, 16#003A#),
+ (16#2A75#, 16#003D#),
+ (16#2A76#, 16#003D#),
+ (16#2ADC#, 16#2ADD#),
+ (16#2C7C#, 16#006A#),
+ (16#2C7D#, 16#0056#),
+ (16#2D6F#, 16#2D61#),
+ (16#2E9F#, 16#6BCD#),
+ (16#2EF3#, 16#9F9F#),
+ (16#2F00#, 16#4E00#),
+ (16#2F01#, 16#4E28#),
+ (16#2F02#, 16#4E36#),
+ (16#2F03#, 16#4E3F#),
+ (16#2F04#, 16#4E59#),
+ (16#2F05#, 16#4E85#),
+ (16#2F06#, 16#4E8C#),
+ (16#2F07#, 16#4EA0#),
+ (16#2F08#, 16#4EBA#),
+ (16#2F09#, 16#513F#),
+ (16#2F0A#, 16#5165#),
+ (16#2F0B#, 16#516B#),
+ (16#2F0C#, 16#5182#),
+ (16#2F0D#, 16#5196#),
+ (16#2F0E#, 16#51AB#),
+ (16#2F0F#, 16#51E0#),
+ (16#2F10#, 16#51F5#),
+ (16#2F11#, 16#5200#),
+ (16#2F12#, 16#529B#),
+ (16#2F13#, 16#52F9#),
+ (16#2F14#, 16#5315#),
+ (16#2F15#, 16#531A#),
+ (16#2F16#, 16#5338#),
+ (16#2F17#, 16#5341#),
+ (16#2F18#, 16#535C#),
+ (16#2F19#, 16#5369#),
+ (16#2F1A#, 16#5382#),
+ (16#2F1B#, 16#53B6#),
+ (16#2F1C#, 16#53C8#),
+ (16#2F1D#, 16#53E3#),
+ (16#2F1E#, 16#56D7#),
+ (16#2F1F#, 16#571F#),
+ (16#2F20#, 16#58EB#),
+ (16#2F21#, 16#5902#),
+ (16#2F22#, 16#590A#),
+ (16#2F23#, 16#5915#),
+ (16#2F24#, 16#5927#),
+ (16#2F25#, 16#5973#),
+ (16#2F26#, 16#5B50#),
+ (16#2F27#, 16#5B80#),
+ (16#2F28#, 16#5BF8#),
+ (16#2F29#, 16#5C0F#),
+ (16#2F2A#, 16#5C22#),
+ (16#2F2B#, 16#5C38#),
+ (16#2F2C#, 16#5C6E#),
+ (16#2F2D#, 16#5C71#),
+ (16#2F2E#, 16#5DDB#),
+ (16#2F2F#, 16#5DE5#),
+ (16#2F30#, 16#5DF1#),
+ (16#2F31#, 16#5DFE#),
+ (16#2F32#, 16#5E72#),
+ (16#2F33#, 16#5E7A#),
+ (16#2F34#, 16#5E7F#),
+ (16#2F35#, 16#5EF4#),
+ (16#2F36#, 16#5EFE#),
+ (16#2F37#, 16#5F0B#),
+ (16#2F38#, 16#5F13#),
+ (16#2F39#, 16#5F50#),
+ (16#2F3A#, 16#5F61#),
+ (16#2F3B#, 16#5F73#),
+ (16#2F3C#, 16#5FC3#),
+ (16#2F3D#, 16#6208#),
+ (16#2F3E#, 16#6236#),
+ (16#2F3F#, 16#624B#),
+ (16#2F40#, 16#652F#),
+ (16#2F41#, 16#6534#),
+ (16#2F42#, 16#6587#),
+ (16#2F43#, 16#6597#),
+ (16#2F44#, 16#65A4#),
+ (16#2F45#, 16#65B9#),
+ (16#2F46#, 16#65E0#),
+ (16#2F47#, 16#65E5#),
+ (16#2F48#, 16#66F0#),
+ (16#2F49#, 16#6708#),
+ (16#2F4A#, 16#6728#),
+ (16#2F4B#, 16#6B20#),
+ (16#2F4C#, 16#6B62#),
+ (16#2F4D#, 16#6B79#),
+ (16#2F4E#, 16#6BB3#),
+ (16#2F4F#, 16#6BCB#),
+ (16#2F50#, 16#6BD4#),
+ (16#2F51#, 16#6BDB#),
+ (16#2F52#, 16#6C0F#),
+ (16#2F53#, 16#6C14#),
+ (16#2F54#, 16#6C34#),
+ (16#2F55#, 16#706B#),
+ (16#2F56#, 16#722A#),
+ (16#2F57#, 16#7236#),
+ (16#2F58#, 16#723B#),
+ (16#2F59#, 16#723F#),
+ (16#2F5A#, 16#7247#),
+ (16#2F5B#, 16#7259#),
+ (16#2F5C#, 16#725B#),
+ (16#2F5D#, 16#72AC#),
+ (16#2F5E#, 16#7384#),
+ (16#2F5F#, 16#7389#),
+ (16#2F60#, 16#74DC#),
+ (16#2F61#, 16#74E6#),
+ (16#2F62#, 16#7518#),
+ (16#2F63#, 16#751F#),
+ (16#2F64#, 16#7528#),
+ (16#2F65#, 16#7530#),
+ (16#2F66#, 16#758B#),
+ (16#2F67#, 16#7592#),
+ (16#2F68#, 16#7676#),
+ (16#2F69#, 16#767D#),
+ (16#2F6A#, 16#76AE#),
+ (16#2F6B#, 16#76BF#),
+ (16#2F6C#, 16#76EE#),
+ (16#2F6D#, 16#77DB#),
+ (16#2F6E#, 16#77E2#),
+ (16#2F6F#, 16#77F3#),
+ (16#2F70#, 16#793A#),
+ (16#2F71#, 16#79B8#),
+ (16#2F72#, 16#79BE#),
+ (16#2F73#, 16#7A74#),
+ (16#2F74#, 16#7ACB#),
+ (16#2F75#, 16#7AF9#),
+ (16#2F76#, 16#7C73#),
+ (16#2F77#, 16#7CF8#),
+ (16#2F78#, 16#7F36#),
+ (16#2F79#, 16#7F51#),
+ (16#2F7A#, 16#7F8A#),
+ (16#2F7B#, 16#7FBD#),
+ (16#2F7C#, 16#8001#),
+ (16#2F7D#, 16#800C#),
+ (16#2F7E#, 16#8012#),
+ (16#2F7F#, 16#8033#),
+ (16#2F80#, 16#807F#),
+ (16#2F81#, 16#8089#),
+ (16#2F82#, 16#81E3#),
+ (16#2F83#, 16#81EA#),
+ (16#2F84#, 16#81F3#),
+ (16#2F85#, 16#81FC#),
+ (16#2F86#, 16#820C#),
+ (16#2F87#, 16#821B#),
+ (16#2F88#, 16#821F#),
+ (16#2F89#, 16#826E#),
+ (16#2F8A#, 16#8272#),
+ (16#2F8B#, 16#8278#),
+ (16#2F8C#, 16#864D#),
+ (16#2F8D#, 16#866B#),
+ (16#2F8E#, 16#8840#),
+ (16#2F8F#, 16#884C#),
+ (16#2F90#, 16#8863#),
+ (16#2F91#, 16#897E#),
+ (16#2F92#, 16#898B#),
+ (16#2F93#, 16#89D2#),
+ (16#2F94#, 16#8A00#),
+ (16#2F95#, 16#8C37#),
+ (16#2F96#, 16#8C46#),
+ (16#2F97#, 16#8C55#),
+ (16#2F98#, 16#8C78#),
+ (16#2F99#, 16#8C9D#),
+ (16#2F9A#, 16#8D64#),
+ (16#2F9B#, 16#8D70#),
+ (16#2F9C#, 16#8DB3#),
+ (16#2F9D#, 16#8EAB#),
+ (16#2F9E#, 16#8ECA#),
+ (16#2F9F#, 16#8F9B#),
+ (16#2FA0#, 16#8FB0#),
+ (16#2FA1#, 16#8FB5#),
+ (16#2FA2#, 16#9091#),
+ (16#2FA3#, 16#9149#),
+ (16#2FA4#, 16#91C6#),
+ (16#2FA5#, 16#91CC#),
+ (16#2FA6#, 16#91D1#),
+ (16#2FA7#, 16#9577#),
+ (16#2FA8#, 16#9580#),
+ (16#2FA9#, 16#961C#),
+ (16#2FAA#, 16#96B6#),
+ (16#2FAB#, 16#96B9#),
+ (16#2FAC#, 16#96E8#),
+ (16#2FAD#, 16#9751#),
+ (16#2FAE#, 16#975E#),
+ (16#2FAF#, 16#9762#),
+ (16#2FB0#, 16#9769#),
+ (16#2FB1#, 16#97CB#),
+ (16#2FB2#, 16#97ED#),
+ (16#2FB3#, 16#97F3#),
+ (16#2FB4#, 16#9801#),
+ (16#2FB5#, 16#98A8#),
+ (16#2FB6#, 16#98DB#),
+ (16#2FB7#, 16#98DF#),
+ (16#2FB8#, 16#9996#),
+ (16#2FB9#, 16#9999#),
+ (16#2FBA#, 16#99AC#),
+ (16#2FBB#, 16#9AA8#),
+ (16#2FBC#, 16#9AD8#),
+ (16#2FBD#, 16#9ADF#),
+ (16#2FBE#, 16#9B25#),
+ (16#2FBF#, 16#9B2F#),
+ (16#2FC0#, 16#9B32#),
+ (16#2FC1#, 16#9B3C#),
+ (16#2FC2#, 16#9B5A#),
+ (16#2FC3#, 16#9CE5#),
+ (16#2FC4#, 16#9E75#),
+ (16#2FC5#, 16#9E7F#),
+ (16#2FC6#, 16#9EA5#),
+ (16#2FC7#, 16#9EBB#),
+ (16#2FC8#, 16#9EC3#),
+ (16#2FC9#, 16#9ECD#),
+ (16#2FCA#, 16#9ED1#),
+ (16#2FCB#, 16#9EF9#),
+ (16#2FCC#, 16#9EFD#),
+ (16#2FCD#, 16#9F0E#),
+ (16#2FCE#, 16#9F13#),
+ (16#2FCF#, 16#9F20#),
+ (16#2FD0#, 16#9F3B#),
+ (16#2FD1#, 16#9F4A#),
+ (16#2FD2#, 16#9F52#),
+ (16#2FD3#, 16#9F8D#),
+ (16#2FD4#, 16#9F9C#),
+ (16#2FD5#, 16#9FA0#),
+ (16#3000#, 16#0020#),
+ (16#3036#, 16#3012#),
+ (16#3038#, 16#5341#),
+ (16#3039#, 16#5344#),
+ (16#303A#, 16#5345#),
+ (16#304C#, 16#304B#),
+ (16#304E#, 16#304D#),
+ (16#3050#, 16#304F#),
+ (16#3052#, 16#3051#),
+ (16#3054#, 16#3053#),
+ (16#3056#, 16#3055#),
+ (16#3058#, 16#3057#),
+ (16#305A#, 16#3059#),
+ (16#305C#, 16#305B#),
+ (16#305E#, 16#305D#),
+ (16#3060#, 16#305F#),
+ (16#3062#, 16#3061#),
+ (16#3065#, 16#3064#),
+ (16#3067#, 16#3066#),
+ (16#3069#, 16#3068#),
+ (16#3070#, 16#306F#),
+ (16#3071#, 16#306F#),
+ (16#3073#, 16#3072#),
+ (16#3074#, 16#3072#),
+ (16#3076#, 16#3075#),
+ (16#3077#, 16#3075#),
+ (16#3079#, 16#3078#),
+ (16#307A#, 16#3078#),
+ (16#307C#, 16#307B#),
+ (16#307D#, 16#307B#),
+ (16#3094#, 16#3046#),
+ (16#309B#, 16#0020#),
+ (16#309C#, 16#0020#),
+ (16#309E#, 16#309D#),
+ (16#309F#, 16#3088#),
+ (16#30AC#, 16#30AB#),
+ (16#30AE#, 16#30AD#),
+ (16#30B0#, 16#30AF#),
+ (16#30B2#, 16#30B1#),
+ (16#30B4#, 16#30B3#),
+ (16#30B6#, 16#30B5#),
+ (16#30B8#, 16#30B7#),
+ (16#30BA#, 16#30B9#),
+ (16#30BC#, 16#30BB#),
+ (16#30BE#, 16#30BD#),
+ (16#30C0#, 16#30BF#),
+ (16#30C2#, 16#30C1#),
+ (16#30C5#, 16#30C4#),
+ (16#30C7#, 16#30C6#),
+ (16#30C9#, 16#30C8#),
+ (16#30D0#, 16#30CF#),
+ (16#30D1#, 16#30CF#),
+ (16#30D3#, 16#30D2#),
+ (16#30D4#, 16#30D2#),
+ (16#30D6#, 16#30D5#),
+ (16#30D7#, 16#30D5#),
+ (16#30D9#, 16#30D8#),
+ (16#30DA#, 16#30D8#),
+ (16#30DC#, 16#30DB#),
+ (16#30DD#, 16#30DB#),
+ (16#30F4#, 16#30A6#),
+ (16#30F7#, 16#30EF#),
+ (16#30F8#, 16#30F0#),
+ (16#30F9#, 16#30F1#),
+ (16#30FA#, 16#30F2#),
+ (16#30FE#, 16#30FD#),
+ (16#30FF#, 16#30B3#),
+ (16#3131#, 16#1100#),
+ (16#3132#, 16#1101#),
+ (16#3133#, 16#11AA#),
+ (16#3134#, 16#1102#),
+ (16#3135#, 16#11AC#),
+ (16#3136#, 16#11AD#),
+ (16#3137#, 16#1103#),
+ (16#3138#, 16#1104#),
+ (16#3139#, 16#1105#),
+ (16#313A#, 16#11B0#),
+ (16#313B#, 16#11B1#),
+ (16#313C#, 16#11B2#),
+ (16#313D#, 16#11B3#),
+ (16#313E#, 16#11B4#),
+ (16#313F#, 16#11B5#),
+ (16#3140#, 16#111A#),
+ (16#3141#, 16#1106#),
+ (16#3142#, 16#1107#),
+ (16#3143#, 16#1108#),
+ (16#3144#, 16#1121#),
+ (16#3145#, 16#1109#),
+ (16#3146#, 16#110A#),
+ (16#3147#, 16#110B#),
+ (16#3148#, 16#110C#),
+ (16#3149#, 16#110D#),
+ (16#314A#, 16#110E#),
+ (16#314B#, 16#110F#),
+ (16#314C#, 16#1110#),
+ (16#314D#, 16#1111#),
+ (16#314E#, 16#1112#),
+ (16#314F#, 16#1161#),
+ (16#3150#, 16#1162#),
+ (16#3151#, 16#1163#),
+ (16#3152#, 16#1164#),
+ (16#3153#, 16#1165#),
+ (16#3154#, 16#1166#),
+ (16#3155#, 16#1167#),
+ (16#3156#, 16#1168#),
+ (16#3157#, 16#1169#),
+ (16#3158#, 16#116A#),
+ (16#3159#, 16#116B#),
+ (16#315A#, 16#116C#),
+ (16#315B#, 16#116D#),
+ (16#315C#, 16#116E#),
+ (16#315D#, 16#116F#),
+ (16#315E#, 16#1170#),
+ (16#315F#, 16#1171#),
+ (16#3160#, 16#1172#),
+ (16#3161#, 16#1173#),
+ (16#3162#, 16#1174#),
+ (16#3163#, 16#1175#),
+ (16#3164#, 16#1160#),
+ (16#3165#, 16#1114#),
+ (16#3166#, 16#1115#),
+ (16#3167#, 16#11C7#),
+ (16#3168#, 16#11C8#),
+ (16#3169#, 16#11CC#),
+ (16#316A#, 16#11CE#),
+ (16#316B#, 16#11D3#),
+ (16#316C#, 16#11D7#),
+ (16#316D#, 16#11D9#),
+ (16#316E#, 16#111C#),
+ (16#316F#, 16#11DD#),
+ (16#3170#, 16#11DF#),
+ (16#3171#, 16#111D#),
+ (16#3172#, 16#111E#),
+ (16#3173#, 16#1120#),
+ (16#3174#, 16#1122#),
+ (16#3175#, 16#1123#),
+ (16#3176#, 16#1127#),
+ (16#3177#, 16#1129#),
+ (16#3178#, 16#112B#),
+ (16#3179#, 16#112C#),
+ (16#317A#, 16#112D#),
+ (16#317B#, 16#112E#),
+ (16#317C#, 16#112F#),
+ (16#317D#, 16#1132#),
+ (16#317E#, 16#1136#),
+ (16#317F#, 16#1140#),
+ (16#3180#, 16#1147#),
+ (16#3181#, 16#114C#),
+ (16#3182#, 16#11F1#),
+ (16#3183#, 16#11F2#),
+ (16#3184#, 16#1157#),
+ (16#3185#, 16#1158#),
+ (16#3186#, 16#1159#),
+ (16#3187#, 16#1184#),
+ (16#3188#, 16#1185#),
+ (16#3189#, 16#1188#),
+ (16#318A#, 16#1191#),
+ (16#318B#, 16#1192#),
+ (16#318C#, 16#1194#),
+ (16#318D#, 16#119E#),
+ (16#318E#, 16#11A1#),
+ (16#3192#, 16#4E00#),
+ (16#3193#, 16#4E8C#),
+ (16#3194#, 16#4E09#),
+ (16#3195#, 16#56DB#),
+ (16#3196#, 16#4E0A#),
+ (16#3197#, 16#4E2D#),
+ (16#3198#, 16#4E0B#),
+ (16#3199#, 16#7532#),
+ (16#319A#, 16#4E59#),
+ (16#319B#, 16#4E19#),
+ (16#319C#, 16#4E01#),
+ (16#319D#, 16#5929#),
+ (16#319E#, 16#5730#),
+ (16#319F#, 16#4EBA#),
+ (16#3200#, 16#0028#),
+ (16#3201#, 16#0028#),
+ (16#3202#, 16#0028#),
+ (16#3203#, 16#0028#),
+ (16#3204#, 16#0028#),
+ (16#3205#, 16#0028#),
+ (16#3206#, 16#0028#),
+ (16#3207#, 16#0028#),
+ (16#3208#, 16#0028#),
+ (16#3209#, 16#0028#),
+ (16#320A#, 16#0028#),
+ (16#320B#, 16#0028#),
+ (16#320C#, 16#0028#),
+ (16#320D#, 16#0028#),
+ (16#320E#, 16#0028#),
+ (16#320F#, 16#0028#),
+ (16#3210#, 16#0028#),
+ (16#3211#, 16#0028#),
+ (16#3212#, 16#0028#),
+ (16#3213#, 16#0028#),
+ (16#3214#, 16#0028#),
+ (16#3215#, 16#0028#),
+ (16#3216#, 16#0028#),
+ (16#3217#, 16#0028#),
+ (16#3218#, 16#0028#),
+ (16#3219#, 16#0028#),
+ (16#321A#, 16#0028#),
+ (16#321B#, 16#0028#),
+ (16#321C#, 16#0028#),
+ (16#321D#, 16#0028#),
+ (16#321E#, 16#0028#),
+ (16#3220#, 16#0028#),
+ (16#3221#, 16#0028#),
+ (16#3222#, 16#0028#),
+ (16#3223#, 16#0028#),
+ (16#3224#, 16#0028#),
+ (16#3225#, 16#0028#),
+ (16#3226#, 16#0028#),
+ (16#3227#, 16#0028#),
+ (16#3228#, 16#0028#),
+ (16#3229#, 16#0028#),
+ (16#322A#, 16#0028#),
+ (16#322B#, 16#0028#),
+ (16#322C#, 16#0028#),
+ (16#322D#, 16#0028#),
+ (16#322E#, 16#0028#),
+ (16#322F#, 16#0028#),
+ (16#3230#, 16#0028#),
+ (16#3231#, 16#0028#),
+ (16#3232#, 16#0028#),
+ (16#3233#, 16#0028#),
+ (16#3234#, 16#0028#),
+ (16#3235#, 16#0028#),
+ (16#3236#, 16#0028#),
+ (16#3237#, 16#0028#),
+ (16#3238#, 16#0028#),
+ (16#3239#, 16#0028#),
+ (16#323A#, 16#0028#),
+ (16#323B#, 16#0028#),
+ (16#323C#, 16#0028#),
+ (16#323D#, 16#0028#),
+ (16#323E#, 16#0028#),
+ (16#323F#, 16#0028#),
+ (16#3240#, 16#0028#),
+ (16#3241#, 16#0028#),
+ (16#3242#, 16#0028#),
+ (16#3243#, 16#0028#),
+ (16#3244#, 16#554F#),
+ (16#3245#, 16#5E7C#),
+ (16#3246#, 16#6587#),
+ (16#3247#, 16#7B8F#),
+ (16#3250#, 16#0050#),
+ (16#3251#, 16#0032#),
+ (16#3252#, 16#0032#),
+ (16#3253#, 16#0032#),
+ (16#3254#, 16#0032#),
+ (16#3255#, 16#0032#),
+ (16#3256#, 16#0032#),
+ (16#3257#, 16#0032#),
+ (16#3258#, 16#0032#),
+ (16#3259#, 16#0032#),
+ (16#325A#, 16#0033#),
+ (16#325B#, 16#0033#),
+ (16#325C#, 16#0033#),
+ (16#325D#, 16#0033#),
+ (16#325E#, 16#0033#),
+ (16#325F#, 16#0033#),
+ (16#3260#, 16#1100#),
+ (16#3261#, 16#1102#),
+ (16#3262#, 16#1103#),
+ (16#3263#, 16#1105#),
+ (16#3264#, 16#1106#),
+ (16#3265#, 16#1107#),
+ (16#3266#, 16#1109#),
+ (16#3267#, 16#110B#),
+ (16#3268#, 16#110C#),
+ (16#3269#, 16#110E#),
+ (16#326A#, 16#110F#),
+ (16#326B#, 16#1110#),
+ (16#326C#, 16#1111#),
+ (16#326D#, 16#1112#),
+ (16#326E#, 16#1100#),
+ (16#326F#, 16#1102#),
+ (16#3270#, 16#1103#),
+ (16#3271#, 16#1105#),
+ (16#3272#, 16#1106#),
+ (16#3273#, 16#1107#),
+ (16#3274#, 16#1109#),
+ (16#3275#, 16#110B#),
+ (16#3276#, 16#110C#),
+ (16#3277#, 16#110E#),
+ (16#3278#, 16#110F#),
+ (16#3279#, 16#1110#),
+ (16#327A#, 16#1111#),
+ (16#327B#, 16#1112#),
+ (16#327C#, 16#110E#),
+ (16#327D#, 16#110C#),
+ (16#327E#, 16#110B#),
+ (16#3280#, 16#4E00#),
+ (16#3281#, 16#4E8C#),
+ (16#3282#, 16#4E09#),
+ (16#3283#, 16#56DB#),
+ (16#3284#, 16#4E94#),
+ (16#3285#, 16#516D#),
+ (16#3286#, 16#4E03#),
+ (16#3287#, 16#516B#),
+ (16#3288#, 16#4E5D#),
+ (16#3289#, 16#5341#),
+ (16#328A#, 16#6708#),
+ (16#328B#, 16#706B#),
+ (16#328C#, 16#6C34#),
+ (16#328D#, 16#6728#),
+ (16#328E#, 16#91D1#),
+ (16#328F#, 16#571F#),
+ (16#3290#, 16#65E5#),
+ (16#3291#, 16#682A#),
+ (16#3292#, 16#6709#),
+ (16#3293#, 16#793E#),
+ (16#3294#, 16#540D#),
+ (16#3295#, 16#7279#),
+ (16#3296#, 16#8CA1#),
+ (16#3297#, 16#795D#),
+ (16#3298#, 16#52B4#),
+ (16#3299#, 16#79D8#),
+ (16#329A#, 16#7537#),
+ (16#329B#, 16#5973#),
+ (16#329C#, 16#9069#),
+ (16#329D#, 16#512A#),
+ (16#329E#, 16#5370#),
+ (16#329F#, 16#6CE8#),
+ (16#32A0#, 16#9805#),
+ (16#32A1#, 16#4F11#),
+ (16#32A2#, 16#5199#),
+ (16#32A3#, 16#6B63#),
+ (16#32A4#, 16#4E0A#),
+ (16#32A5#, 16#4E2D#),
+ (16#32A6#, 16#4E0B#),
+ (16#32A7#, 16#5DE6#),
+ (16#32A8#, 16#53F3#),
+ (16#32A9#, 16#533B#),
+ (16#32AA#, 16#5B97#),
+ (16#32AB#, 16#5B66#),
+ (16#32AC#, 16#76E3#),
+ (16#32AD#, 16#4F01#),
+ (16#32AE#, 16#8CC7#),
+ (16#32AF#, 16#5354#),
+ (16#32B0#, 16#591C#),
+ (16#32B1#, 16#0033#),
+ (16#32B2#, 16#0033#),
+ (16#32B3#, 16#0033#),
+ (16#32B4#, 16#0033#),
+ (16#32B5#, 16#0034#),
+ (16#32B6#, 16#0034#),
+ (16#32B7#, 16#0034#),
+ (16#32B8#, 16#0034#),
+ (16#32B9#, 16#0034#),
+ (16#32BA#, 16#0034#),
+ (16#32BB#, 16#0034#),
+ (16#32BC#, 16#0034#),
+ (16#32BD#, 16#0034#),
+ (16#32BE#, 16#0034#),
+ (16#32BF#, 16#0035#),
+ (16#32C0#, 16#0031#),
+ (16#32C1#, 16#0032#),
+ (16#32C2#, 16#0033#),
+ (16#32C3#, 16#0034#),
+ (16#32C4#, 16#0035#),
+ (16#32C5#, 16#0036#),
+ (16#32C6#, 16#0037#),
+ (16#32C7#, 16#0038#),
+ (16#32C8#, 16#0039#),
+ (16#32C9#, 16#0031#),
+ (16#32CA#, 16#0031#),
+ (16#32CB#, 16#0031#),
+ (16#32CC#, 16#0048#),
+ (16#32CD#, 16#0065#),
+ (16#32CE#, 16#0065#),
+ (16#32CF#, 16#004C#),
+ (16#32D0#, 16#30A2#),
+ (16#32D1#, 16#30A4#),
+ (16#32D2#, 16#30A6#),
+ (16#32D3#, 16#30A8#),
+ (16#32D4#, 16#30AA#),
+ (16#32D5#, 16#30AB#),
+ (16#32D6#, 16#30AD#),
+ (16#32D7#, 16#30AF#),
+ (16#32D8#, 16#30B1#),
+ (16#32D9#, 16#30B3#),
+ (16#32DA#, 16#30B5#),
+ (16#32DB#, 16#30B7#),
+ (16#32DC#, 16#30B9#),
+ (16#32DD#, 16#30BB#),
+ (16#32DE#, 16#30BD#),
+ (16#32DF#, 16#30BF#),
+ (16#32E0#, 16#30C1#),
+ (16#32E1#, 16#30C4#),
+ (16#32E2#, 16#30C6#),
+ (16#32E3#, 16#30C8#),
+ (16#32E4#, 16#30CA#),
+ (16#32E5#, 16#30CB#),
+ (16#32E6#, 16#30CC#),
+ (16#32E7#, 16#30CD#),
+ (16#32E8#, 16#30CE#),
+ (16#32E9#, 16#30CF#),
+ (16#32EA#, 16#30D2#),
+ (16#32EB#, 16#30D5#),
+ (16#32EC#, 16#30D8#),
+ (16#32ED#, 16#30DB#),
+ (16#32EE#, 16#30DE#),
+ (16#32EF#, 16#30DF#),
+ (16#32F0#, 16#30E0#),
+ (16#32F1#, 16#30E1#),
+ (16#32F2#, 16#30E2#),
+ (16#32F3#, 16#30E4#),
+ (16#32F4#, 16#30E6#),
+ (16#32F5#, 16#30E8#),
+ (16#32F6#, 16#30E9#),
+ (16#32F7#, 16#30EA#),
+ (16#32F8#, 16#30EB#),
+ (16#32F9#, 16#30EC#),
+ (16#32FA#, 16#30ED#),
+ (16#32FB#, 16#30EF#),
+ (16#32FC#, 16#30F0#),
+ (16#32FD#, 16#30F1#),
+ (16#32FE#, 16#30F2#),
+ (16#32FF#, 16#4EE4#),
+ (16#3300#, 16#30A2#),
+ (16#3301#, 16#30A2#),
+ (16#3302#, 16#30A2#),
+ (16#3303#, 16#30A2#),
+ (16#3304#, 16#30A4#),
+ (16#3305#, 16#30A4#),
+ (16#3306#, 16#30A6#),
+ (16#3307#, 16#30A8#),
+ (16#3308#, 16#30A8#),
+ (16#3309#, 16#30AA#),
+ (16#330A#, 16#30AA#),
+ (16#330B#, 16#30AB#),
+ (16#330C#, 16#30AB#),
+ (16#330D#, 16#30AB#),
+ (16#330E#, 16#30AC#),
+ (16#330F#, 16#30AC#),
+ (16#3310#, 16#30AE#),
+ (16#3311#, 16#30AE#),
+ (16#3312#, 16#30AD#),
+ (16#3313#, 16#30AE#),
+ (16#3314#, 16#30AD#),
+ (16#3315#, 16#30AD#),
+ (16#3316#, 16#30AD#),
+ (16#3317#, 16#30AD#),
+ (16#3318#, 16#30B0#),
+ (16#3319#, 16#30B0#),
+ (16#331A#, 16#30AF#),
+ (16#331B#, 16#30AF#),
+ (16#331C#, 16#30B1#),
+ (16#331D#, 16#30B3#),
+ (16#331E#, 16#30B3#),
+ (16#331F#, 16#30B5#),
+ (16#3320#, 16#30B5#),
+ (16#3321#, 16#30B7#),
+ (16#3322#, 16#30BB#),
+ (16#3323#, 16#30BB#),
+ (16#3324#, 16#30C0#),
+ (16#3325#, 16#30C7#),
+ (16#3326#, 16#30C9#),
+ (16#3327#, 16#30C8#),
+ (16#3328#, 16#30CA#),
+ (16#3329#, 16#30CE#),
+ (16#332A#, 16#30CF#),
+ (16#332B#, 16#30D1#),
+ (16#332C#, 16#30D1#),
+ (16#332D#, 16#30D0#),
+ (16#332E#, 16#30D4#),
+ (16#332F#, 16#30D4#),
+ (16#3330#, 16#30D4#),
+ (16#3331#, 16#30D3#),
+ (16#3332#, 16#30D5#),
+ (16#3333#, 16#30D5#),
+ (16#3334#, 16#30D6#),
+ (16#3335#, 16#30D5#),
+ (16#3336#, 16#30D8#),
+ (16#3337#, 16#30DA#),
+ (16#3338#, 16#30DA#),
+ (16#3339#, 16#30D8#),
+ (16#333A#, 16#30DA#),
+ (16#333B#, 16#30DA#),
+ (16#333C#, 16#30D9#),
+ (16#333D#, 16#30DD#),
+ (16#333E#, 16#30DC#),
+ (16#333F#, 16#30DB#),
+ (16#3340#, 16#30DD#),
+ (16#3341#, 16#30DB#),
+ (16#3342#, 16#30DB#),
+ (16#3343#, 16#30DE#),
+ (16#3344#, 16#30DE#),
+ (16#3345#, 16#30DE#),
+ (16#3346#, 16#30DE#),
+ (16#3347#, 16#30DE#),
+ (16#3348#, 16#30DF#),
+ (16#3349#, 16#30DF#),
+ (16#334A#, 16#30DF#),
+ (16#334B#, 16#30E1#),
+ (16#334C#, 16#30E1#),
+ (16#334D#, 16#30E1#),
+ (16#334E#, 16#30E4#),
+ (16#334F#, 16#30E4#),
+ (16#3350#, 16#30E6#),
+ (16#3351#, 16#30EA#),
+ (16#3352#, 16#30EA#),
+ (16#3353#, 16#30EB#),
+ (16#3354#, 16#30EB#),
+ (16#3355#, 16#30EC#),
+ (16#3356#, 16#30EC#),
+ (16#3357#, 16#30EF#),
+ (16#3358#, 16#0030#),
+ (16#3359#, 16#0031#),
+ (16#335A#, 16#0032#),
+ (16#335B#, 16#0033#),
+ (16#335C#, 16#0034#),
+ (16#335D#, 16#0035#),
+ (16#335E#, 16#0036#),
+ (16#335F#, 16#0037#),
+ (16#3360#, 16#0038#),
+ (16#3361#, 16#0039#),
+ (16#3362#, 16#0031#),
+ (16#3363#, 16#0031#),
+ (16#3364#, 16#0031#),
+ (16#3365#, 16#0031#),
+ (16#3366#, 16#0031#),
+ (16#3367#, 16#0031#),
+ (16#3368#, 16#0031#),
+ (16#3369#, 16#0031#),
+ (16#336A#, 16#0031#),
+ (16#336B#, 16#0031#),
+ (16#336C#, 16#0032#),
+ (16#336D#, 16#0032#),
+ (16#336E#, 16#0032#),
+ (16#336F#, 16#0032#),
+ (16#3370#, 16#0032#),
+ (16#3371#, 16#0068#),
+ (16#3372#, 16#0064#),
+ (16#3373#, 16#0041#),
+ (16#3374#, 16#0062#),
+ (16#3375#, 16#006F#),
+ (16#3376#, 16#0070#),
+ (16#3377#, 16#0064#),
+ (16#3378#, 16#0064#),
+ (16#3379#, 16#0064#),
+ (16#337A#, 16#0049#),
+ (16#337B#, 16#5E73#),
+ (16#337C#, 16#662D#),
+ (16#337D#, 16#5927#),
+ (16#337E#, 16#660E#),
+ (16#337F#, 16#682A#),
+ (16#3380#, 16#0070#),
+ (16#3381#, 16#006E#),
+ (16#3382#, 16#03BC#),
+ (16#3383#, 16#006D#),
+ (16#3384#, 16#006B#),
+ (16#3385#, 16#004B#),
+ (16#3386#, 16#004D#),
+ (16#3387#, 16#0047#),
+ (16#3388#, 16#0063#),
+ (16#3389#, 16#006B#),
+ (16#338A#, 16#0070#),
+ (16#338B#, 16#006E#),
+ (16#338C#, 16#03BC#),
+ (16#338D#, 16#03BC#),
+ (16#338E#, 16#006D#),
+ (16#338F#, 16#006B#),
+ (16#3390#, 16#0048#),
+ (16#3391#, 16#006B#),
+ (16#3392#, 16#004D#),
+ (16#3393#, 16#0047#),
+ (16#3394#, 16#0054#),
+ (16#3395#, 16#03BC#),
+ (16#3396#, 16#006D#),
+ (16#3397#, 16#0064#),
+ (16#3398#, 16#006B#),
+ (16#3399#, 16#0066#),
+ (16#339A#, 16#006E#),
+ (16#339B#, 16#03BC#),
+ (16#339C#, 16#006D#),
+ (16#339D#, 16#0063#),
+ (16#339E#, 16#006B#),
+ (16#339F#, 16#006D#),
+ (16#33A0#, 16#0063#),
+ (16#33A1#, 16#006D#),
+ (16#33A2#, 16#006B#),
+ (16#33A3#, 16#006D#),
+ (16#33A4#, 16#0063#),
+ (16#33A5#, 16#006D#),
+ (16#33A6#, 16#006B#),
+ (16#33A7#, 16#006D#),
+ (16#33A8#, 16#006D#),
+ (16#33A9#, 16#0050#),
+ (16#33AA#, 16#006B#),
+ (16#33AB#, 16#004D#),
+ (16#33AC#, 16#0047#),
+ (16#33AD#, 16#0072#),
+ (16#33AE#, 16#0072#),
+ (16#33AF#, 16#0072#),
+ (16#33B0#, 16#0070#),
+ (16#33B1#, 16#006E#),
+ (16#33B2#, 16#03BC#),
+ (16#33B3#, 16#006D#),
+ (16#33B4#, 16#0070#),
+ (16#33B5#, 16#006E#),
+ (16#33B6#, 16#03BC#),
+ (16#33B7#, 16#006D#),
+ (16#33B8#, 16#006B#),
+ (16#33B9#, 16#004D#),
+ (16#33BA#, 16#0070#),
+ (16#33BB#, 16#006E#),
+ (16#33BC#, 16#03BC#),
+ (16#33BD#, 16#006D#),
+ (16#33BE#, 16#006B#),
+ (16#33BF#, 16#004D#),
+ (16#33C0#, 16#006B#),
+ (16#33C1#, 16#004D#),
+ (16#33C2#, 16#0061#),
+ (16#33C3#, 16#0042#),
+ (16#33C4#, 16#0063#),
+ (16#33C5#, 16#0063#),
+ (16#33C6#, 16#0043#),
+ (16#33C7#, 16#0043#),
+ (16#33C8#, 16#0064#),
+ (16#33C9#, 16#0047#),
+ (16#33CA#, 16#0068#),
+ (16#33CB#, 16#0048#),
+ (16#33CC#, 16#0069#),
+ (16#33CD#, 16#004B#),
+ (16#33CE#, 16#004B#),
+ (16#33CF#, 16#006B#),
+ (16#33D0#, 16#006C#),
+ (16#33D1#, 16#006C#),
+ (16#33D2#, 16#006C#),
+ (16#33D3#, 16#006C#),
+ (16#33D4#, 16#006D#),
+ (16#33D5#, 16#006D#),
+ (16#33D6#, 16#006D#),
+ (16#33D7#, 16#0050#),
+ (16#33D8#, 16#0070#),
+ (16#33D9#, 16#0050#),
+ (16#33DA#, 16#0050#),
+ (16#33DB#, 16#0073#),
+ (16#33DC#, 16#0053#),
+ (16#33DD#, 16#0057#),
+ (16#33DE#, 16#0056#),
+ (16#33DF#, 16#0041#),
+ (16#33E0#, 16#0031#),
+ (16#33E1#, 16#0032#),
+ (16#33E2#, 16#0033#),
+ (16#33E3#, 16#0034#),
+ (16#33E4#, 16#0035#),
+ (16#33E5#, 16#0036#),
+ (16#33E6#, 16#0037#),
+ (16#33E7#, 16#0038#),
+ (16#33E8#, 16#0039#),
+ (16#33E9#, 16#0031#),
+ (16#33EA#, 16#0031#),
+ (16#33EB#, 16#0031#),
+ (16#33EC#, 16#0031#),
+ (16#33ED#, 16#0031#),
+ (16#33EE#, 16#0031#),
+ (16#33EF#, 16#0031#),
+ (16#33F0#, 16#0031#),
+ (16#33F1#, 16#0031#),
+ (16#33F2#, 16#0031#),
+ (16#33F3#, 16#0032#),
+ (16#33F4#, 16#0032#),
+ (16#33F5#, 16#0032#),
+ (16#33F6#, 16#0032#),
+ (16#33F7#, 16#0032#),
+ (16#33F8#, 16#0032#),
+ (16#33F9#, 16#0032#),
+ (16#33FA#, 16#0032#),
+ (16#33FB#, 16#0032#),
+ (16#33FC#, 16#0032#),
+ (16#33FD#, 16#0033#),
+ (16#33FE#, 16#0033#),
+ (16#33FF#, 16#0067#),
+ (16#A69C#, 16#044A#),
+ (16#A69D#, 16#044C#),
+ (16#A770#, 16#A76F#),
+ (16#A7F8#, 16#0126#),
+ (16#A7F9#, 16#0153#),
+ (16#AB5C#, 16#A727#),
+ (16#AB5D#, 16#AB37#),
+ (16#AB5E#, 16#026B#),
+ (16#AB5F#, 16#AB52#),
+ (16#AB69#, 16#028D#),
+ (16#F900#, 16#8C48#),
+ (16#F901#, 16#66F4#),
+ (16#F902#, 16#8ECA#),
+ (16#F903#, 16#8CC8#),
+ (16#F904#, 16#6ED1#),
+ (16#F905#, 16#4E32#),
+ (16#F906#, 16#53E5#),
+ (16#F907#, 16#9F9C#),
+ (16#F908#, 16#9F9C#),
+ (16#F909#, 16#5951#),
+ (16#F90A#, 16#91D1#),
+ (16#F90B#, 16#5587#),
+ (16#F90C#, 16#5948#),
+ (16#F90D#, 16#61F6#),
+ (16#F90E#, 16#7669#),
+ (16#F90F#, 16#7F85#),
+ (16#F910#, 16#863F#),
+ (16#F911#, 16#87BA#),
+ (16#F912#, 16#88F8#),
+ (16#F913#, 16#908F#),
+ (16#F914#, 16#6A02#),
+ (16#F915#, 16#6D1B#),
+ (16#F916#, 16#70D9#),
+ (16#F917#, 16#73DE#),
+ (16#F918#, 16#843D#),
+ (16#F919#, 16#916A#),
+ (16#F91A#, 16#99F1#),
+ (16#F91B#, 16#4E82#),
+ (16#F91C#, 16#5375#),
+ (16#F91D#, 16#6B04#),
+ (16#F91E#, 16#721B#),
+ (16#F91F#, 16#862D#),
+ (16#F920#, 16#9E1E#),
+ (16#F921#, 16#5D50#),
+ (16#F922#, 16#6FEB#),
+ (16#F923#, 16#85CD#),
+ (16#F924#, 16#8964#),
+ (16#F925#, 16#62C9#),
+ (16#F926#, 16#81D8#),
+ (16#F927#, 16#881F#),
+ (16#F928#, 16#5ECA#),
+ (16#F929#, 16#6717#),
+ (16#F92A#, 16#6D6A#),
+ (16#F92B#, 16#72FC#),
+ (16#F92C#, 16#90CE#),
+ (16#F92D#, 16#4F86#),
+ (16#F92E#, 16#51B7#),
+ (16#F92F#, 16#52DE#),
+ (16#F930#, 16#64C4#),
+ (16#F931#, 16#6AD3#),
+ (16#F932#, 16#7210#),
+ (16#F933#, 16#76E7#),
+ (16#F934#, 16#8001#),
+ (16#F935#, 16#8606#),
+ (16#F936#, 16#865C#),
+ (16#F937#, 16#8DEF#),
+ (16#F938#, 16#9732#),
+ (16#F939#, 16#9B6F#),
+ (16#F93A#, 16#9DFA#),
+ (16#F93B#, 16#788C#),
+ (16#F93C#, 16#797F#),
+ (16#F93D#, 16#7DA0#),
+ (16#F93E#, 16#83C9#),
+ (16#F93F#, 16#9304#),
+ (16#F940#, 16#9E7F#),
+ (16#F941#, 16#8AD6#),
+ (16#F942#, 16#58DF#),
+ (16#F943#, 16#5F04#),
+ (16#F944#, 16#7C60#),
+ (16#F945#, 16#807E#),
+ (16#F946#, 16#7262#),
+ (16#F947#, 16#78CA#),
+ (16#F948#, 16#8CC2#),
+ (16#F949#, 16#96F7#),
+ (16#F94A#, 16#58D8#),
+ (16#F94B#, 16#5C62#),
+ (16#F94C#, 16#6A13#),
+ (16#F94D#, 16#6DDA#),
+ (16#F94E#, 16#6F0F#),
+ (16#F94F#, 16#7D2F#),
+ (16#F950#, 16#7E37#),
+ (16#F951#, 16#964B#),
+ (16#F952#, 16#52D2#),
+ (16#F953#, 16#808B#),
+ (16#F954#, 16#51DC#),
+ (16#F955#, 16#51CC#),
+ (16#F956#, 16#7A1C#),
+ (16#F957#, 16#7DBE#),
+ (16#F958#, 16#83F1#),
+ (16#F959#, 16#9675#),
+ (16#F95A#, 16#8B80#),
+ (16#F95B#, 16#62CF#),
+ (16#F95C#, 16#6A02#),
+ (16#F95D#, 16#8AFE#),
+ (16#F95E#, 16#4E39#),
+ (16#F95F#, 16#5BE7#),
+ (16#F960#, 16#6012#),
+ (16#F961#, 16#7387#),
+ (16#F962#, 16#7570#),
+ (16#F963#, 16#5317#),
+ (16#F964#, 16#78FB#),
+ (16#F965#, 16#4FBF#),
+ (16#F966#, 16#5FA9#),
+ (16#F967#, 16#4E0D#),
+ (16#F968#, 16#6CCC#),
+ (16#F969#, 16#6578#),
+ (16#F96A#, 16#7D22#),
+ (16#F96B#, 16#53C3#),
+ (16#F96C#, 16#585E#),
+ (16#F96D#, 16#7701#),
+ (16#F96E#, 16#8449#),
+ (16#F96F#, 16#8AAA#),
+ (16#F970#, 16#6BBA#),
+ (16#F971#, 16#8FB0#),
+ (16#F972#, 16#6C88#),
+ (16#F973#, 16#62FE#),
+ (16#F974#, 16#82E5#),
+ (16#F975#, 16#63A0#),
+ (16#F976#, 16#7565#),
+ (16#F977#, 16#4EAE#),
+ (16#F978#, 16#5169#),
+ (16#F979#, 16#51C9#),
+ (16#F97A#, 16#6881#),
+ (16#F97B#, 16#7CE7#),
+ (16#F97C#, 16#826F#),
+ (16#F97D#, 16#8AD2#),
+ (16#F97E#, 16#91CF#),
+ (16#F97F#, 16#52F5#),
+ (16#F980#, 16#5442#),
+ (16#F981#, 16#5973#),
+ (16#F982#, 16#5EEC#),
+ (16#F983#, 16#65C5#),
+ (16#F984#, 16#6FFE#),
+ (16#F985#, 16#792A#),
+ (16#F986#, 16#95AD#),
+ (16#F987#, 16#9A6A#),
+ (16#F988#, 16#9E97#),
+ (16#F989#, 16#9ECE#),
+ (16#F98A#, 16#529B#),
+ (16#F98B#, 16#66C6#),
+ (16#F98C#, 16#6B77#),
+ (16#F98D#, 16#8F62#),
+ (16#F98E#, 16#5E74#),
+ (16#F98F#, 16#6190#),
+ (16#F990#, 16#6200#),
+ (16#F991#, 16#649A#),
+ (16#F992#, 16#6F23#),
+ (16#F993#, 16#7149#),
+ (16#F994#, 16#7489#),
+ (16#F995#, 16#79CA#),
+ (16#F996#, 16#7DF4#),
+ (16#F997#, 16#806F#),
+ (16#F998#, 16#8F26#),
+ (16#F999#, 16#84EE#),
+ (16#F99A#, 16#9023#),
+ (16#F99B#, 16#934A#),
+ (16#F99C#, 16#5217#),
+ (16#F99D#, 16#52A3#),
+ (16#F99E#, 16#54BD#),
+ (16#F99F#, 16#70C8#),
+ (16#F9A0#, 16#88C2#),
+ (16#F9A1#, 16#8AAA#),
+ (16#F9A2#, 16#5EC9#),
+ (16#F9A3#, 16#5FF5#),
+ (16#F9A4#, 16#637B#),
+ (16#F9A5#, 16#6BAE#),
+ (16#F9A6#, 16#7C3E#),
+ (16#F9A7#, 16#7375#),
+ (16#F9A8#, 16#4EE4#),
+ (16#F9A9#, 16#56F9#),
+ (16#F9AA#, 16#5BE7#),
+ (16#F9AB#, 16#5DBA#),
+ (16#F9AC#, 16#601C#),
+ (16#F9AD#, 16#73B2#),
+ (16#F9AE#, 16#7469#),
+ (16#F9AF#, 16#7F9A#),
+ (16#F9B0#, 16#8046#),
+ (16#F9B1#, 16#9234#),
+ (16#F9B2#, 16#96F6#),
+ (16#F9B3#, 16#9748#),
+ (16#F9B4#, 16#9818#),
+ (16#F9B5#, 16#4F8B#),
+ (16#F9B6#, 16#79AE#),
+ (16#F9B7#, 16#91B4#),
+ (16#F9B8#, 16#96B8#),
+ (16#F9B9#, 16#60E1#),
+ (16#F9BA#, 16#4E86#),
+ (16#F9BB#, 16#50DA#),
+ (16#F9BC#, 16#5BEE#),
+ (16#F9BD#, 16#5C3F#),
+ (16#F9BE#, 16#6599#),
+ (16#F9BF#, 16#6A02#),
+ (16#F9C0#, 16#71CE#),
+ (16#F9C1#, 16#7642#),
+ (16#F9C2#, 16#84FC#),
+ (16#F9C3#, 16#907C#),
+ (16#F9C4#, 16#9F8D#),
+ (16#F9C5#, 16#6688#),
+ (16#F9C6#, 16#962E#),
+ (16#F9C7#, 16#5289#),
+ (16#F9C8#, 16#677B#),
+ (16#F9C9#, 16#67F3#),
+ (16#F9CA#, 16#6D41#),
+ (16#F9CB#, 16#6E9C#),
+ (16#F9CC#, 16#7409#),
+ (16#F9CD#, 16#7559#),
+ (16#F9CE#, 16#786B#),
+ (16#F9CF#, 16#7D10#),
+ (16#F9D0#, 16#985E#),
+ (16#F9D1#, 16#516D#),
+ (16#F9D2#, 16#622E#),
+ (16#F9D3#, 16#9678#),
+ (16#F9D4#, 16#502B#),
+ (16#F9D5#, 16#5D19#),
+ (16#F9D6#, 16#6DEA#),
+ (16#F9D7#, 16#8F2A#),
+ (16#F9D8#, 16#5F8B#),
+ (16#F9D9#, 16#6144#),
+ (16#F9DA#, 16#6817#),
+ (16#F9DB#, 16#7387#),
+ (16#F9DC#, 16#9686#),
+ (16#F9DD#, 16#5229#),
+ (16#F9DE#, 16#540F#),
+ (16#F9DF#, 16#5C65#),
+ (16#F9E0#, 16#6613#),
+ (16#F9E1#, 16#674E#),
+ (16#F9E2#, 16#68A8#),
+ (16#F9E3#, 16#6CE5#),
+ (16#F9E4#, 16#7406#),
+ (16#F9E5#, 16#75E2#),
+ (16#F9E6#, 16#7F79#),
+ (16#F9E7#, 16#88CF#),
+ (16#F9E8#, 16#88E1#),
+ (16#F9E9#, 16#91CC#),
+ (16#F9EA#, 16#96E2#),
+ (16#F9EB#, 16#533F#),
+ (16#F9EC#, 16#6EBA#),
+ (16#F9ED#, 16#541D#),
+ (16#F9EE#, 16#71D0#),
+ (16#F9EF#, 16#7498#),
+ (16#F9F0#, 16#85FA#),
+ (16#F9F1#, 16#96A3#),
+ (16#F9F2#, 16#9C57#),
+ (16#F9F3#, 16#9E9F#),
+ (16#F9F4#, 16#6797#),
+ (16#F9F5#, 16#6DCB#),
+ (16#F9F6#, 16#81E8#),
+ (16#F9F7#, 16#7ACB#),
+ (16#F9F8#, 16#7B20#),
+ (16#F9F9#, 16#7C92#),
+ (16#F9FA#, 16#72C0#),
+ (16#F9FB#, 16#7099#),
+ (16#F9FC#, 16#8B58#),
+ (16#F9FD#, 16#4EC0#),
+ (16#F9FE#, 16#8336#),
+ (16#F9FF#, 16#523A#),
+ (16#FA00#, 16#5207#),
+ (16#FA01#, 16#5EA6#),
+ (16#FA02#, 16#62D3#),
+ (16#FA03#, 16#7CD6#),
+ (16#FA04#, 16#5B85#),
+ (16#FA05#, 16#6D1E#),
+ (16#FA06#, 16#66B4#),
+ (16#FA07#, 16#8F3B#),
+ (16#FA08#, 16#884C#),
+ (16#FA09#, 16#964D#),
+ (16#FA0A#, 16#898B#),
+ (16#FA0B#, 16#5ED3#),
+ (16#FA0C#, 16#5140#),
+ (16#FA0D#, 16#55C0#),
+ (16#FA10#, 16#585A#),
+ (16#FA12#, 16#6674#),
+ (16#FA15#, 16#51DE#),
+ (16#FA16#, 16#732A#),
+ (16#FA17#, 16#76CA#),
+ (16#FA18#, 16#793C#),
+ (16#FA19#, 16#795E#),
+ (16#FA1A#, 16#7965#),
+ (16#FA1B#, 16#798F#),
+ (16#FA1C#, 16#9756#),
+ (16#FA1D#, 16#7CBE#),
+ (16#FA1E#, 16#7FBD#),
+ (16#FA20#, 16#8612#),
+ (16#FA22#, 16#8AF8#),
+ (16#FA25#, 16#9038#),
+ (16#FA26#, 16#90FD#),
+ (16#FA2A#, 16#98EF#),
+ (16#FA2B#, 16#98FC#),
+ (16#FA2C#, 16#9928#),
+ (16#FA2D#, 16#9DB4#),
+ (16#FA2E#, 16#90DE#),
+ (16#FA2F#, 16#96B7#),
+ (16#FA30#, 16#4FAE#),
+ (16#FA31#, 16#50E7#),
+ (16#FA32#, 16#514D#),
+ (16#FA33#, 16#52C9#),
+ (16#FA34#, 16#52E4#),
+ (16#FA35#, 16#5351#),
+ (16#FA36#, 16#559D#),
+ (16#FA37#, 16#5606#),
+ (16#FA38#, 16#5668#),
+ (16#FA39#, 16#5840#),
+ (16#FA3A#, 16#58A8#),
+ (16#FA3B#, 16#5C64#),
+ (16#FA3C#, 16#5C6E#),
+ (16#FA3D#, 16#6094#),
+ (16#FA3E#, 16#6168#),
+ (16#FA3F#, 16#618E#),
+ (16#FA40#, 16#61F2#),
+ (16#FA41#, 16#654F#),
+ (16#FA42#, 16#65E2#),
+ (16#FA43#, 16#6691#),
+ (16#FA44#, 16#6885#),
+ (16#FA45#, 16#6D77#),
+ (16#FA46#, 16#6E1A#),
+ (16#FA47#, 16#6F22#),
+ (16#FA48#, 16#716E#),
+ (16#FA49#, 16#722B#),
+ (16#FA4A#, 16#7422#),
+ (16#FA4B#, 16#7891#),
+ (16#FA4C#, 16#793E#),
+ (16#FA4D#, 16#7949#),
+ (16#FA4E#, 16#7948#),
+ (16#FA4F#, 16#7950#),
+ (16#FA50#, 16#7956#),
+ (16#FA51#, 16#795D#),
+ (16#FA52#, 16#798D#),
+ (16#FA53#, 16#798E#),
+ (16#FA54#, 16#7A40#),
+ (16#FA55#, 16#7A81#),
+ (16#FA56#, 16#7BC0#),
+ (16#FA57#, 16#7DF4#),
+ (16#FA58#, 16#7E09#),
+ (16#FA59#, 16#7E41#),
+ (16#FA5A#, 16#7F72#),
+ (16#FA5B#, 16#8005#),
+ (16#FA5C#, 16#81ED#),
+ (16#FA5D#, 16#8279#),
+ (16#FA5E#, 16#8279#),
+ (16#FA5F#, 16#8457#),
+ (16#FA60#, 16#8910#),
+ (16#FA61#, 16#8996#),
+ (16#FA62#, 16#8B01#),
+ (16#FA63#, 16#8B39#),
+ (16#FA64#, 16#8CD3#),
+ (16#FA65#, 16#8D08#),
+ (16#FA66#, 16#8FB6#),
+ (16#FA67#, 16#9038#),
+ (16#FA68#, 16#96E3#),
+ (16#FA69#, 16#97FF#),
+ (16#FA6A#, 16#983B#),
+ (16#FA6B#, 16#6075#),
+ (16#FA6C#, 16#242EE#),
+ (16#FA6D#, 16#8218#),
+ (16#FA70#, 16#4E26#),
+ (16#FA71#, 16#51B5#),
+ (16#FA72#, 16#5168#),
+ (16#FA73#, 16#4F80#),
+ (16#FA74#, 16#5145#),
+ (16#FA75#, 16#5180#),
+ (16#FA76#, 16#52C7#),
+ (16#FA77#, 16#52FA#),
+ (16#FA78#, 16#559D#),
+ (16#FA79#, 16#5555#),
+ (16#FA7A#, 16#5599#),
+ (16#FA7B#, 16#55E2#),
+ (16#FA7C#, 16#585A#),
+ (16#FA7D#, 16#58B3#),
+ (16#FA7E#, 16#5944#),
+ (16#FA7F#, 16#5954#),
+ (16#FA80#, 16#5A62#),
+ (16#FA81#, 16#5B28#),
+ (16#FA82#, 16#5ED2#),
+ (16#FA83#, 16#5ED9#),
+ (16#FA84#, 16#5F69#),
+ (16#FA85#, 16#5FAD#),
+ (16#FA86#, 16#60D8#),
+ (16#FA87#, 16#614E#),
+ (16#FA88#, 16#6108#),
+ (16#FA89#, 16#618E#),
+ (16#FA8A#, 16#6160#),
+ (16#FA8B#, 16#61F2#),
+ (16#FA8C#, 16#6234#),
+ (16#FA8D#, 16#63C4#),
+ (16#FA8E#, 16#641C#),
+ (16#FA8F#, 16#6452#),
+ (16#FA90#, 16#6556#),
+ (16#FA91#, 16#6674#),
+ (16#FA92#, 16#6717#),
+ (16#FA93#, 16#671B#),
+ (16#FA94#, 16#6756#),
+ (16#FA95#, 16#6B79#),
+ (16#FA96#, 16#6BBA#),
+ (16#FA97#, 16#6D41#),
+ (16#FA98#, 16#6EDB#),
+ (16#FA99#, 16#6ECB#),
+ (16#FA9A#, 16#6F22#),
+ (16#FA9B#, 16#701E#),
+ (16#FA9C#, 16#716E#),
+ (16#FA9D#, 16#77A7#),
+ (16#FA9E#, 16#7235#),
+ (16#FA9F#, 16#72AF#),
+ (16#FAA0#, 16#732A#),
+ (16#FAA1#, 16#7471#),
+ (16#FAA2#, 16#7506#),
+ (16#FAA3#, 16#753B#),
+ (16#FAA4#, 16#761D#),
+ (16#FAA5#, 16#761F#),
+ (16#FAA6#, 16#76CA#),
+ (16#FAA7#, 16#76DB#),
+ (16#FAA8#, 16#76F4#),
+ (16#FAA9#, 16#774A#),
+ (16#FAAA#, 16#7740#),
+ (16#FAAB#, 16#78CC#),
+ (16#FAAC#, 16#7AB1#),
+ (16#FAAD#, 16#7BC0#),
+ (16#FAAE#, 16#7C7B#),
+ (16#FAAF#, 16#7D5B#),
+ (16#FAB0#, 16#7DF4#),
+ (16#FAB1#, 16#7F3E#),
+ (16#FAB2#, 16#8005#),
+ (16#FAB3#, 16#8352#),
+ (16#FAB4#, 16#83EF#),
+ (16#FAB5#, 16#8779#),
+ (16#FAB6#, 16#8941#),
+ (16#FAB7#, 16#8986#),
+ (16#FAB8#, 16#8996#),
+ (16#FAB9#, 16#8ABF#),
+ (16#FABA#, 16#8AF8#),
+ (16#FABB#, 16#8ACB#),
+ (16#FABC#, 16#8B01#),
+ (16#FABD#, 16#8AFE#),
+ (16#FABE#, 16#8AED#),
+ (16#FABF#, 16#8B39#),
+ (16#FAC0#, 16#8B8A#),
+ (16#FAC1#, 16#8D08#),
+ (16#FAC2#, 16#8F38#),
+ (16#FAC3#, 16#9072#),
+ (16#FAC4#, 16#9199#),
+ (16#FAC5#, 16#9276#),
+ (16#FAC6#, 16#967C#),
+ (16#FAC7#, 16#96E3#),
+ (16#FAC8#, 16#9756#),
+ (16#FAC9#, 16#97DB#),
+ (16#FACA#, 16#97FF#),
+ (16#FACB#, 16#980B#),
+ (16#FACC#, 16#983B#),
+ (16#FACD#, 16#9B12#),
+ (16#FACE#, 16#9F9C#),
+ (16#FACF#, 16#2284A#),
+ (16#FAD0#, 16#22844#),
+ (16#FAD1#, 16#233D5#),
+ (16#FAD2#, 16#3B9D#),
+ (16#FAD3#, 16#4018#),
+ (16#FAD4#, 16#4039#),
+ (16#FAD5#, 16#25249#),
+ (16#FAD6#, 16#25CD0#),
+ (16#FAD7#, 16#27ED3#),
+ (16#FAD8#, 16#9F43#),
+ (16#FAD9#, 16#9F8E#),
+ (16#FB00#, 16#0066#),
+ (16#FB01#, 16#0066#),
+ (16#FB02#, 16#0066#),
+ (16#FB03#, 16#0066#),
+ (16#FB04#, 16#0066#),
+ (16#FB05#, 16#017F#),
+ (16#FB06#, 16#0073#),
+ (16#FB13#, 16#0574#),
+ (16#FB14#, 16#0574#),
+ (16#FB15#, 16#0574#),
+ (16#FB16#, 16#057E#),
+ (16#FB17#, 16#0574#),
+ (16#FB1D#, 16#05D9#),
+ (16#FB1F#, 16#05F2#),
+ (16#FB20#, 16#05E2#),
+ (16#FB21#, 16#05D0#),
+ (16#FB22#, 16#05D3#),
+ (16#FB23#, 16#05D4#),
+ (16#FB24#, 16#05DB#),
+ (16#FB25#, 16#05DC#),
+ (16#FB26#, 16#05DD#),
+ (16#FB27#, 16#05E8#),
+ (16#FB28#, 16#05EA#),
+ (16#FB29#, 16#002B#),
+ (16#FB2A#, 16#05E9#),
+ (16#FB2B#, 16#05E9#),
+ (16#FB2C#, 16#FB49#),
+ (16#FB2D#, 16#FB49#),
+ (16#FB2E#, 16#05D0#),
+ (16#FB2F#, 16#05D0#),
+ (16#FB30#, 16#05D0#),
+ (16#FB31#, 16#05D1#),
+ (16#FB32#, 16#05D2#),
+ (16#FB33#, 16#05D3#),
+ (16#FB34#, 16#05D4#),
+ (16#FB35#, 16#05D5#),
+ (16#FB36#, 16#05D6#),
+ (16#FB38#, 16#05D8#),
+ (16#FB39#, 16#05D9#),
+ (16#FB3A#, 16#05DA#),
+ (16#FB3B#, 16#05DB#),
+ (16#FB3C#, 16#05DC#),
+ (16#FB3E#, 16#05DE#),
+ (16#FB40#, 16#05E0#),
+ (16#FB41#, 16#05E1#),
+ (16#FB43#, 16#05E3#),
+ (16#FB44#, 16#05E4#),
+ (16#FB46#, 16#05E6#),
+ (16#FB47#, 16#05E7#),
+ (16#FB48#, 16#05E8#),
+ (16#FB49#, 16#05E9#),
+ (16#FB4A#, 16#05EA#),
+ (16#FB4B#, 16#05D5#),
+ (16#FB4C#, 16#05D1#),
+ (16#FB4D#, 16#05DB#),
+ (16#FB4E#, 16#05E4#),
+ (16#FB4F#, 16#05D0#),
+ (16#FB50#, 16#0671#),
+ (16#FB51#, 16#0671#),
+ (16#FB52#, 16#067B#),
+ (16#FB53#, 16#067B#),
+ (16#FB54#, 16#067B#),
+ (16#FB55#, 16#067B#),
+ (16#FB56#, 16#067E#),
+ (16#FB57#, 16#067E#),
+ (16#FB58#, 16#067E#),
+ (16#FB59#, 16#067E#),
+ (16#FB5A#, 16#0680#),
+ (16#FB5B#, 16#0680#),
+ (16#FB5C#, 16#0680#),
+ (16#FB5D#, 16#0680#),
+ (16#FB5E#, 16#067A#),
+ (16#FB5F#, 16#067A#),
+ (16#FB60#, 16#067A#),
+ (16#FB61#, 16#067A#),
+ (16#FB62#, 16#067F#),
+ (16#FB63#, 16#067F#),
+ (16#FB64#, 16#067F#),
+ (16#FB65#, 16#067F#),
+ (16#FB66#, 16#0679#),
+ (16#FB67#, 16#0679#),
+ (16#FB68#, 16#0679#),
+ (16#FB69#, 16#0679#),
+ (16#FB6A#, 16#06A4#),
+ (16#FB6B#, 16#06A4#),
+ (16#FB6C#, 16#06A4#),
+ (16#FB6D#, 16#06A4#),
+ (16#FB6E#, 16#06A6#),
+ (16#FB6F#, 16#06A6#),
+ (16#FB70#, 16#06A6#),
+ (16#FB71#, 16#06A6#),
+ (16#FB72#, 16#0684#),
+ (16#FB73#, 16#0684#),
+ (16#FB74#, 16#0684#),
+ (16#FB75#, 16#0684#),
+ (16#FB76#, 16#0683#),
+ (16#FB77#, 16#0683#),
+ (16#FB78#, 16#0683#),
+ (16#FB79#, 16#0683#),
+ (16#FB7A#, 16#0686#),
+ (16#FB7B#, 16#0686#),
+ (16#FB7C#, 16#0686#),
+ (16#FB7D#, 16#0686#),
+ (16#FB7E#, 16#0687#),
+ (16#FB7F#, 16#0687#),
+ (16#FB80#, 16#0687#),
+ (16#FB81#, 16#0687#),
+ (16#FB82#, 16#068D#),
+ (16#FB83#, 16#068D#),
+ (16#FB84#, 16#068C#),
+ (16#FB85#, 16#068C#),
+ (16#FB86#, 16#068E#),
+ (16#FB87#, 16#068E#),
+ (16#FB88#, 16#0688#),
+ (16#FB89#, 16#0688#),
+ (16#FB8A#, 16#0698#),
+ (16#FB8B#, 16#0698#),
+ (16#FB8C#, 16#0691#),
+ (16#FB8D#, 16#0691#),
+ (16#FB8E#, 16#06A9#),
+ (16#FB8F#, 16#06A9#),
+ (16#FB90#, 16#06A9#),
+ (16#FB91#, 16#06A9#),
+ (16#FB92#, 16#06AF#),
+ (16#FB93#, 16#06AF#),
+ (16#FB94#, 16#06AF#),
+ (16#FB95#, 16#06AF#),
+ (16#FB96#, 16#06B3#),
+ (16#FB97#, 16#06B3#),
+ (16#FB98#, 16#06B3#),
+ (16#FB99#, 16#06B3#),
+ (16#FB9A#, 16#06B1#),
+ (16#FB9B#, 16#06B1#),
+ (16#FB9C#, 16#06B1#),
+ (16#FB9D#, 16#06B1#),
+ (16#FB9E#, 16#06BA#),
+ (16#FB9F#, 16#06BA#),
+ (16#FBA0#, 16#06BB#),
+ (16#FBA1#, 16#06BB#),
+ (16#FBA2#, 16#06BB#),
+ (16#FBA3#, 16#06BB#),
+ (16#FBA4#, 16#06C0#),
+ (16#FBA5#, 16#06C0#),
+ (16#FBA6#, 16#06C1#),
+ (16#FBA7#, 16#06C1#),
+ (16#FBA8#, 16#06C1#),
+ (16#FBA9#, 16#06C1#),
+ (16#FBAA#, 16#06BE#),
+ (16#FBAB#, 16#06BE#),
+ (16#FBAC#, 16#06BE#),
+ (16#FBAD#, 16#06BE#),
+ (16#FBAE#, 16#06D2#),
+ (16#FBAF#, 16#06D2#),
+ (16#FBB0#, 16#06D3#),
+ (16#FBB1#, 16#06D3#),
+ (16#FBD3#, 16#06AD#),
+ (16#FBD4#, 16#06AD#),
+ (16#FBD5#, 16#06AD#),
+ (16#FBD6#, 16#06AD#),
+ (16#FBD7#, 16#06C7#),
+ (16#FBD8#, 16#06C7#),
+ (16#FBD9#, 16#06C6#),
+ (16#FBDA#, 16#06C6#),
+ (16#FBDB#, 16#06C8#),
+ (16#FBDC#, 16#06C8#),
+ (16#FBDD#, 16#0677#),
+ (16#FBDE#, 16#06CB#),
+ (16#FBDF#, 16#06CB#),
+ (16#FBE0#, 16#06C5#),
+ (16#FBE1#, 16#06C5#),
+ (16#FBE2#, 16#06C9#),
+ (16#FBE3#, 16#06C9#),
+ (16#FBE4#, 16#06D0#),
+ (16#FBE5#, 16#06D0#),
+ (16#FBE6#, 16#06D0#),
+ (16#FBE7#, 16#06D0#),
+ (16#FBE8#, 16#0649#),
+ (16#FBE9#, 16#0649#),
+ (16#FBEA#, 16#0626#),
+ (16#FBEB#, 16#0626#),
+ (16#FBEC#, 16#0626#),
+ (16#FBED#, 16#0626#),
+ (16#FBEE#, 16#0626#),
+ (16#FBEF#, 16#0626#),
+ (16#FBF0#, 16#0626#),
+ (16#FBF1#, 16#0626#),
+ (16#FBF2#, 16#0626#),
+ (16#FBF3#, 16#0626#),
+ (16#FBF4#, 16#0626#),
+ (16#FBF5#, 16#0626#),
+ (16#FBF6#, 16#0626#),
+ (16#FBF7#, 16#0626#),
+ (16#FBF8#, 16#0626#),
+ (16#FBF9#, 16#0626#),
+ (16#FBFA#, 16#0626#),
+ (16#FBFB#, 16#0626#),
+ (16#FBFC#, 16#06CC#),
+ (16#FBFD#, 16#06CC#),
+ (16#FBFE#, 16#06CC#),
+ (16#FBFF#, 16#06CC#),
+ (16#FC00#, 16#0626#),
+ (16#FC01#, 16#0626#),
+ (16#FC02#, 16#0626#),
+ (16#FC03#, 16#0626#),
+ (16#FC04#, 16#0626#),
+ (16#FC05#, 16#0628#),
+ (16#FC06#, 16#0628#),
+ (16#FC07#, 16#0628#),
+ (16#FC08#, 16#0628#),
+ (16#FC09#, 16#0628#),
+ (16#FC0A#, 16#0628#),
+ (16#FC0B#, 16#062A#),
+ (16#FC0C#, 16#062A#),
+ (16#FC0D#, 16#062A#),
+ (16#FC0E#, 16#062A#),
+ (16#FC0F#, 16#062A#),
+ (16#FC10#, 16#062A#),
+ (16#FC11#, 16#062B#),
+ (16#FC12#, 16#062B#),
+ (16#FC13#, 16#062B#),
+ (16#FC14#, 16#062B#),
+ (16#FC15#, 16#062C#),
+ (16#FC16#, 16#062C#),
+ (16#FC17#, 16#062D#),
+ (16#FC18#, 16#062D#),
+ (16#FC19#, 16#062E#),
+ (16#FC1A#, 16#062E#),
+ (16#FC1B#, 16#062E#),
+ (16#FC1C#, 16#0633#),
+ (16#FC1D#, 16#0633#),
+ (16#FC1E#, 16#0633#),
+ (16#FC1F#, 16#0633#),
+ (16#FC20#, 16#0635#),
+ (16#FC21#, 16#0635#),
+ (16#FC22#, 16#0636#),
+ (16#FC23#, 16#0636#),
+ (16#FC24#, 16#0636#),
+ (16#FC25#, 16#0636#),
+ (16#FC26#, 16#0637#),
+ (16#FC27#, 16#0637#),
+ (16#FC28#, 16#0638#),
+ (16#FC29#, 16#0639#),
+ (16#FC2A#, 16#0639#),
+ (16#FC2B#, 16#063A#),
+ (16#FC2C#, 16#063A#),
+ (16#FC2D#, 16#0641#),
+ (16#FC2E#, 16#0641#),
+ (16#FC2F#, 16#0641#),
+ (16#FC30#, 16#0641#),
+ (16#FC31#, 16#0641#),
+ (16#FC32#, 16#0641#),
+ (16#FC33#, 16#0642#),
+ (16#FC34#, 16#0642#),
+ (16#FC35#, 16#0642#),
+ (16#FC36#, 16#0642#),
+ (16#FC37#, 16#0643#),
+ (16#FC38#, 16#0643#),
+ (16#FC39#, 16#0643#),
+ (16#FC3A#, 16#0643#),
+ (16#FC3B#, 16#0643#),
+ (16#FC3C#, 16#0643#),
+ (16#FC3D#, 16#0643#),
+ (16#FC3E#, 16#0643#),
+ (16#FC3F#, 16#0644#),
+ (16#FC40#, 16#0644#),
+ (16#FC41#, 16#0644#),
+ (16#FC42#, 16#0644#),
+ (16#FC43#, 16#0644#),
+ (16#FC44#, 16#0644#),
+ (16#FC45#, 16#0645#),
+ (16#FC46#, 16#0645#),
+ (16#FC47#, 16#0645#),
+ (16#FC48#, 16#0645#),
+ (16#FC49#, 16#0645#),
+ (16#FC4A#, 16#0645#),
+ (16#FC4B#, 16#0646#),
+ (16#FC4C#, 16#0646#),
+ (16#FC4D#, 16#0646#),
+ (16#FC4E#, 16#0646#),
+ (16#FC4F#, 16#0646#),
+ (16#FC50#, 16#0646#),
+ (16#FC51#, 16#0647#),
+ (16#FC52#, 16#0647#),
+ (16#FC53#, 16#0647#),
+ (16#FC54#, 16#0647#),
+ (16#FC55#, 16#064A#),
+ (16#FC56#, 16#064A#),
+ (16#FC57#, 16#064A#),
+ (16#FC58#, 16#064A#),
+ (16#FC59#, 16#064A#),
+ (16#FC5A#, 16#064A#),
+ (16#FC5B#, 16#0630#),
+ (16#FC5C#, 16#0631#),
+ (16#FC5D#, 16#0649#),
+ (16#FC5E#, 16#0020#),
+ (16#FC5F#, 16#0020#),
+ (16#FC60#, 16#0020#),
+ (16#FC61#, 16#0020#),
+ (16#FC62#, 16#0020#),
+ (16#FC63#, 16#0020#),
+ (16#FC64#, 16#0626#),
+ (16#FC65#, 16#0626#),
+ (16#FC66#, 16#0626#),
+ (16#FC67#, 16#0626#),
+ (16#FC68#, 16#0626#),
+ (16#FC69#, 16#0626#),
+ (16#FC6A#, 16#0628#),
+ (16#FC6B#, 16#0628#),
+ (16#FC6C#, 16#0628#),
+ (16#FC6D#, 16#0628#),
+ (16#FC6E#, 16#0628#),
+ (16#FC6F#, 16#0628#),
+ (16#FC70#, 16#062A#),
+ (16#FC71#, 16#062A#),
+ (16#FC72#, 16#062A#),
+ (16#FC73#, 16#062A#),
+ (16#FC74#, 16#062A#),
+ (16#FC75#, 16#062A#),
+ (16#FC76#, 16#062B#),
+ (16#FC77#, 16#062B#),
+ (16#FC78#, 16#062B#),
+ (16#FC79#, 16#062B#),
+ (16#FC7A#, 16#062B#),
+ (16#FC7B#, 16#062B#),
+ (16#FC7C#, 16#0641#),
+ (16#FC7D#, 16#0641#),
+ (16#FC7E#, 16#0642#),
+ (16#FC7F#, 16#0642#),
+ (16#FC80#, 16#0643#),
+ (16#FC81#, 16#0643#),
+ (16#FC82#, 16#0643#),
+ (16#FC83#, 16#0643#),
+ (16#FC84#, 16#0643#),
+ (16#FC85#, 16#0644#),
+ (16#FC86#, 16#0644#),
+ (16#FC87#, 16#0644#),
+ (16#FC88#, 16#0645#),
+ (16#FC89#, 16#0645#),
+ (16#FC8A#, 16#0646#),
+ (16#FC8B#, 16#0646#),
+ (16#FC8C#, 16#0646#),
+ (16#FC8D#, 16#0646#),
+ (16#FC8E#, 16#0646#),
+ (16#FC8F#, 16#0646#),
+ (16#FC90#, 16#0649#),
+ (16#FC91#, 16#064A#),
+ (16#FC92#, 16#064A#),
+ (16#FC93#, 16#064A#),
+ (16#FC94#, 16#064A#),
+ (16#FC95#, 16#064A#),
+ (16#FC96#, 16#064A#),
+ (16#FC97#, 16#0626#),
+ (16#FC98#, 16#0626#),
+ (16#FC99#, 16#0626#),
+ (16#FC9A#, 16#0626#),
+ (16#FC9B#, 16#0626#),
+ (16#FC9C#, 16#0628#),
+ (16#FC9D#, 16#0628#),
+ (16#FC9E#, 16#0628#),
+ (16#FC9F#, 16#0628#),
+ (16#FCA0#, 16#0628#),
+ (16#FCA1#, 16#062A#),
+ (16#FCA2#, 16#062A#),
+ (16#FCA3#, 16#062A#),
+ (16#FCA4#, 16#062A#),
+ (16#FCA5#, 16#062A#),
+ (16#FCA6#, 16#062B#),
+ (16#FCA7#, 16#062C#),
+ (16#FCA8#, 16#062C#),
+ (16#FCA9#, 16#062D#),
+ (16#FCAA#, 16#062D#),
+ (16#FCAB#, 16#062E#),
+ (16#FCAC#, 16#062E#),
+ (16#FCAD#, 16#0633#),
+ (16#FCAE#, 16#0633#),
+ (16#FCAF#, 16#0633#),
+ (16#FCB0#, 16#0633#),
+ (16#FCB1#, 16#0635#),
+ (16#FCB2#, 16#0635#),
+ (16#FCB3#, 16#0635#),
+ (16#FCB4#, 16#0636#),
+ (16#FCB5#, 16#0636#),
+ (16#FCB6#, 16#0636#),
+ (16#FCB7#, 16#0636#),
+ (16#FCB8#, 16#0637#),
+ (16#FCB9#, 16#0638#),
+ (16#FCBA#, 16#0639#),
+ (16#FCBB#, 16#0639#),
+ (16#FCBC#, 16#063A#),
+ (16#FCBD#, 16#063A#),
+ (16#FCBE#, 16#0641#),
+ (16#FCBF#, 16#0641#),
+ (16#FCC0#, 16#0641#),
+ (16#FCC1#, 16#0641#),
+ (16#FCC2#, 16#0642#),
+ (16#FCC3#, 16#0642#),
+ (16#FCC4#, 16#0643#),
+ (16#FCC5#, 16#0643#),
+ (16#FCC6#, 16#0643#),
+ (16#FCC7#, 16#0643#),
+ (16#FCC8#, 16#0643#),
+ (16#FCC9#, 16#0644#),
+ (16#FCCA#, 16#0644#),
+ (16#FCCB#, 16#0644#),
+ (16#FCCC#, 16#0644#),
+ (16#FCCD#, 16#0644#),
+ (16#FCCE#, 16#0645#),
+ (16#FCCF#, 16#0645#),
+ (16#FCD0#, 16#0645#),
+ (16#FCD1#, 16#0645#),
+ (16#FCD2#, 16#0646#),
+ (16#FCD3#, 16#0646#),
+ (16#FCD4#, 16#0646#),
+ (16#FCD5#, 16#0646#),
+ (16#FCD6#, 16#0646#),
+ (16#FCD7#, 16#0647#),
+ (16#FCD8#, 16#0647#),
+ (16#FCD9#, 16#0647#),
+ (16#FCDA#, 16#064A#),
+ (16#FCDB#, 16#064A#),
+ (16#FCDC#, 16#064A#),
+ (16#FCDD#, 16#064A#),
+ (16#FCDE#, 16#064A#),
+ (16#FCDF#, 16#0626#),
+ (16#FCE0#, 16#0626#),
+ (16#FCE1#, 16#0628#),
+ (16#FCE2#, 16#0628#),
+ (16#FCE3#, 16#062A#),
+ (16#FCE4#, 16#062A#),
+ (16#FCE5#, 16#062B#),
+ (16#FCE6#, 16#062B#),
+ (16#FCE7#, 16#0633#),
+ (16#FCE8#, 16#0633#),
+ (16#FCE9#, 16#0634#),
+ (16#FCEA#, 16#0634#),
+ (16#FCEB#, 16#0643#),
+ (16#FCEC#, 16#0643#),
+ (16#FCED#, 16#0644#),
+ (16#FCEE#, 16#0646#),
+ (16#FCEF#, 16#0646#),
+ (16#FCF0#, 16#064A#),
+ (16#FCF1#, 16#064A#),
+ (16#FCF2#, 16#0640#),
+ (16#FCF3#, 16#0640#),
+ (16#FCF4#, 16#0640#),
+ (16#FCF5#, 16#0637#),
+ (16#FCF6#, 16#0637#),
+ (16#FCF7#, 16#0639#),
+ (16#FCF8#, 16#0639#),
+ (16#FCF9#, 16#063A#),
+ (16#FCFA#, 16#063A#),
+ (16#FCFB#, 16#0633#),
+ (16#FCFC#, 16#0633#),
+ (16#FCFD#, 16#0634#),
+ (16#FCFE#, 16#0634#),
+ (16#FCFF#, 16#062D#),
+ (16#FD00#, 16#062D#),
+ (16#FD01#, 16#062C#),
+ (16#FD02#, 16#062C#),
+ (16#FD03#, 16#062E#),
+ (16#FD04#, 16#062E#),
+ (16#FD05#, 16#0635#),
+ (16#FD06#, 16#0635#),
+ (16#FD07#, 16#0636#),
+ (16#FD08#, 16#0636#),
+ (16#FD09#, 16#0634#),
+ (16#FD0A#, 16#0634#),
+ (16#FD0B#, 16#0634#),
+ (16#FD0C#, 16#0634#),
+ (16#FD0D#, 16#0634#),
+ (16#FD0E#, 16#0633#),
+ (16#FD0F#, 16#0635#),
+ (16#FD10#, 16#0636#),
+ (16#FD11#, 16#0637#),
+ (16#FD12#, 16#0637#),
+ (16#FD13#, 16#0639#),
+ (16#FD14#, 16#0639#),
+ (16#FD15#, 16#063A#),
+ (16#FD16#, 16#063A#),
+ (16#FD17#, 16#0633#),
+ (16#FD18#, 16#0633#),
+ (16#FD19#, 16#0634#),
+ (16#FD1A#, 16#0634#),
+ (16#FD1B#, 16#062D#),
+ (16#FD1C#, 16#062D#),
+ (16#FD1D#, 16#062C#),
+ (16#FD1E#, 16#062C#),
+ (16#FD1F#, 16#062E#),
+ (16#FD20#, 16#062E#),
+ (16#FD21#, 16#0635#),
+ (16#FD22#, 16#0635#),
+ (16#FD23#, 16#0636#),
+ (16#FD24#, 16#0636#),
+ (16#FD25#, 16#0634#),
+ (16#FD26#, 16#0634#),
+ (16#FD27#, 16#0634#),
+ (16#FD28#, 16#0634#),
+ (16#FD29#, 16#0634#),
+ (16#FD2A#, 16#0633#),
+ (16#FD2B#, 16#0635#),
+ (16#FD2C#, 16#0636#),
+ (16#FD2D#, 16#0634#),
+ (16#FD2E#, 16#0634#),
+ (16#FD2F#, 16#0634#),
+ (16#FD30#, 16#0634#),
+ (16#FD31#, 16#0633#),
+ (16#FD32#, 16#0634#),
+ (16#FD33#, 16#0637#),
+ (16#FD34#, 16#0633#),
+ (16#FD35#, 16#0633#),
+ (16#FD36#, 16#0633#),
+ (16#FD37#, 16#0634#),
+ (16#FD38#, 16#0634#),
+ (16#FD39#, 16#0634#),
+ (16#FD3A#, 16#0637#),
+ (16#FD3B#, 16#0638#),
+ (16#FD3C#, 16#0627#),
+ (16#FD3D#, 16#0627#),
+ (16#FD50#, 16#062A#),
+ (16#FD51#, 16#062A#),
+ (16#FD52#, 16#062A#),
+ (16#FD53#, 16#062A#),
+ (16#FD54#, 16#062A#),
+ (16#FD55#, 16#062A#),
+ (16#FD56#, 16#062A#),
+ (16#FD57#, 16#062A#),
+ (16#FD58#, 16#062C#),
+ (16#FD59#, 16#062C#),
+ (16#FD5A#, 16#062D#),
+ (16#FD5B#, 16#062D#),
+ (16#FD5C#, 16#0633#),
+ (16#FD5D#, 16#0633#),
+ (16#FD5E#, 16#0633#),
+ (16#FD5F#, 16#0633#),
+ (16#FD60#, 16#0633#),
+ (16#FD61#, 16#0633#),
+ (16#FD62#, 16#0633#),
+ (16#FD63#, 16#0633#),
+ (16#FD64#, 16#0635#),
+ (16#FD65#, 16#0635#),
+ (16#FD66#, 16#0635#),
+ (16#FD67#, 16#0634#),
+ (16#FD68#, 16#0634#),
+ (16#FD69#, 16#0634#),
+ (16#FD6A#, 16#0634#),
+ (16#FD6B#, 16#0634#),
+ (16#FD6C#, 16#0634#),
+ (16#FD6D#, 16#0634#),
+ (16#FD6E#, 16#0636#),
+ (16#FD6F#, 16#0636#),
+ (16#FD70#, 16#0636#),
+ (16#FD71#, 16#0637#),
+ (16#FD72#, 16#0637#),
+ (16#FD73#, 16#0637#),
+ (16#FD74#, 16#0637#),
+ (16#FD75#, 16#0639#),
+ (16#FD76#, 16#0639#),
+ (16#FD77#, 16#0639#),
+ (16#FD78#, 16#0639#),
+ (16#FD79#, 16#063A#),
+ (16#FD7A#, 16#063A#),
+ (16#FD7B#, 16#063A#),
+ (16#FD7C#, 16#0641#),
+ (16#FD7D#, 16#0641#),
+ (16#FD7E#, 16#0642#),
+ (16#FD7F#, 16#0642#),
+ (16#FD80#, 16#0644#),
+ (16#FD81#, 16#0644#),
+ (16#FD82#, 16#0644#),
+ (16#FD83#, 16#0644#),
+ (16#FD84#, 16#0644#),
+ (16#FD85#, 16#0644#),
+ (16#FD86#, 16#0644#),
+ (16#FD87#, 16#0644#),
+ (16#FD88#, 16#0644#),
+ (16#FD89#, 16#0645#),
+ (16#FD8A#, 16#0645#),
+ (16#FD8B#, 16#0645#),
+ (16#FD8C#, 16#0645#),
+ (16#FD8D#, 16#0645#),
+ (16#FD8E#, 16#0645#),
+ (16#FD8F#, 16#0645#),
+ (16#FD92#, 16#0645#),
+ (16#FD93#, 16#0647#),
+ (16#FD94#, 16#0647#),
+ (16#FD95#, 16#0646#),
+ (16#FD96#, 16#0646#),
+ (16#FD97#, 16#0646#),
+ (16#FD98#, 16#0646#),
+ (16#FD99#, 16#0646#),
+ (16#FD9A#, 16#0646#),
+ (16#FD9B#, 16#0646#),
+ (16#FD9C#, 16#064A#),
+ (16#FD9D#, 16#064A#),
+ (16#FD9E#, 16#0628#),
+ (16#FD9F#, 16#062A#),
+ (16#FDA0#, 16#062A#),
+ (16#FDA1#, 16#062A#),
+ (16#FDA2#, 16#062A#),
+ (16#FDA3#, 16#062A#),
+ (16#FDA4#, 16#062A#),
+ (16#FDA5#, 16#062C#),
+ (16#FDA6#, 16#062C#),
+ (16#FDA7#, 16#062C#),
+ (16#FDA8#, 16#0633#),
+ (16#FDA9#, 16#0635#),
+ (16#FDAA#, 16#0634#),
+ (16#FDAB#, 16#0636#),
+ (16#FDAC#, 16#0644#),
+ (16#FDAD#, 16#0644#),
+ (16#FDAE#, 16#064A#),
+ (16#FDAF#, 16#064A#),
+ (16#FDB0#, 16#064A#),
+ (16#FDB1#, 16#0645#),
+ (16#FDB2#, 16#0642#),
+ (16#FDB3#, 16#0646#),
+ (16#FDB4#, 16#0642#),
+ (16#FDB5#, 16#0644#),
+ (16#FDB6#, 16#0639#),
+ (16#FDB7#, 16#0643#),
+ (16#FDB8#, 16#0646#),
+ (16#FDB9#, 16#0645#),
+ (16#FDBA#, 16#0644#),
+ (16#FDBB#, 16#0643#),
+ (16#FDBC#, 16#0644#),
+ (16#FDBD#, 16#0646#),
+ (16#FDBE#, 16#062C#),
+ (16#FDBF#, 16#062D#),
+ (16#FDC0#, 16#0645#),
+ (16#FDC1#, 16#0641#),
+ (16#FDC2#, 16#0628#),
+ (16#FDC3#, 16#0643#),
+ (16#FDC4#, 16#0639#),
+ (16#FDC5#, 16#0635#),
+ (16#FDC6#, 16#0633#),
+ (16#FDC7#, 16#0646#),
+ (16#FDF0#, 16#0635#),
+ (16#FDF1#, 16#0642#),
+ (16#FDF2#, 16#0627#),
+ (16#FDF3#, 16#0627#),
+ (16#FDF4#, 16#0645#),
+ (16#FDF5#, 16#0635#),
+ (16#FDF6#, 16#0631#),
+ (16#FDF7#, 16#0639#),
+ (16#FDF8#, 16#0648#),
+ (16#FDF9#, 16#0635#),
+ (16#FDFA#, 16#0635#),
+ (16#FDFB#, 16#062C#),
+ (16#FDFC#, 16#0631#),
+ (16#FE10#, 16#002C#),
+ (16#FE11#, 16#3001#),
+ (16#FE12#, 16#3002#),
+ (16#FE13#, 16#003A#),
+ (16#FE14#, 16#003B#),
+ (16#FE15#, 16#0021#),
+ (16#FE16#, 16#003F#),
+ (16#FE17#, 16#3016#),
+ (16#FE18#, 16#3017#),
+ (16#FE19#, 16#2026#),
+ (16#FE30#, 16#2025#),
+ (16#FE31#, 16#2014#),
+ (16#FE32#, 16#2013#),
+ (16#FE33#, 16#005F#),
+ (16#FE34#, 16#005F#),
+ (16#FE35#, 16#0028#),
+ (16#FE36#, 16#0029#),
+ (16#FE37#, 16#007B#),
+ (16#FE38#, 16#007D#),
+ (16#FE39#, 16#3014#),
+ (16#FE3A#, 16#3015#),
+ (16#FE3B#, 16#3010#),
+ (16#FE3C#, 16#3011#),
+ (16#FE3D#, 16#300A#),
+ (16#FE3E#, 16#300B#),
+ (16#FE3F#, 16#3008#),
+ (16#FE40#, 16#3009#),
+ (16#FE41#, 16#300C#),
+ (16#FE42#, 16#300D#),
+ (16#FE43#, 16#300E#),
+ (16#FE44#, 16#300F#),
+ (16#FE47#, 16#005B#),
+ (16#FE48#, 16#005D#),
+ (16#FE49#, 16#203E#),
+ (16#FE4A#, 16#203E#),
+ (16#FE4B#, 16#203E#),
+ (16#FE4C#, 16#203E#),
+ (16#FE4D#, 16#005F#),
+ (16#FE4E#, 16#005F#),
+ (16#FE4F#, 16#005F#),
+ (16#FE50#, 16#002C#),
+ (16#FE51#, 16#3001#),
+ (16#FE52#, 16#002E#),
+ (16#FE54#, 16#003B#),
+ (16#FE55#, 16#003A#),
+ (16#FE56#, 16#003F#),
+ (16#FE57#, 16#0021#),
+ (16#FE58#, 16#2014#),
+ (16#FE59#, 16#0028#),
+ (16#FE5A#, 16#0029#),
+ (16#FE5B#, 16#007B#),
+ (16#FE5C#, 16#007D#),
+ (16#FE5D#, 16#3014#),
+ (16#FE5E#, 16#3015#),
+ (16#FE5F#, 16#0023#),
+ (16#FE60#, 16#0026#),
+ (16#FE61#, 16#002A#),
+ (16#FE62#, 16#002B#),
+ (16#FE63#, 16#002D#),
+ (16#FE64#, 16#003C#),
+ (16#FE65#, 16#003E#),
+ (16#FE66#, 16#003D#),
+ (16#FE68#, 16#005C#),
+ (16#FE69#, 16#0024#),
+ (16#FE6A#, 16#0025#),
+ (16#FE6B#, 16#0040#),
+ (16#FE70#, 16#0020#),
+ (16#FE71#, 16#0640#),
+ (16#FE72#, 16#0020#),
+ (16#FE74#, 16#0020#),
+ (16#FE76#, 16#0020#),
+ (16#FE77#, 16#0640#),
+ (16#FE78#, 16#0020#),
+ (16#FE79#, 16#0640#),
+ (16#FE7A#, 16#0020#),
+ (16#FE7B#, 16#0640#),
+ (16#FE7C#, 16#0020#),
+ (16#FE7D#, 16#0640#),
+ (16#FE7E#, 16#0020#),
+ (16#FE7F#, 16#0640#),
+ (16#FE80#, 16#0621#),
+ (16#FE81#, 16#0622#),
+ (16#FE82#, 16#0622#),
+ (16#FE83#, 16#0623#),
+ (16#FE84#, 16#0623#),
+ (16#FE85#, 16#0624#),
+ (16#FE86#, 16#0624#),
+ (16#FE87#, 16#0625#),
+ (16#FE88#, 16#0625#),
+ (16#FE89#, 16#0626#),
+ (16#FE8A#, 16#0626#),
+ (16#FE8B#, 16#0626#),
+ (16#FE8C#, 16#0626#),
+ (16#FE8D#, 16#0627#),
+ (16#FE8E#, 16#0627#),
+ (16#FE8F#, 16#0628#),
+ (16#FE90#, 16#0628#),
+ (16#FE91#, 16#0628#),
+ (16#FE92#, 16#0628#),
+ (16#FE93#, 16#0629#),
+ (16#FE94#, 16#0629#),
+ (16#FE95#, 16#062A#),
+ (16#FE96#, 16#062A#),
+ (16#FE97#, 16#062A#),
+ (16#FE98#, 16#062A#),
+ (16#FE99#, 16#062B#),
+ (16#FE9A#, 16#062B#),
+ (16#FE9B#, 16#062B#),
+ (16#FE9C#, 16#062B#),
+ (16#FE9D#, 16#062C#),
+ (16#FE9E#, 16#062C#),
+ (16#FE9F#, 16#062C#),
+ (16#FEA0#, 16#062C#),
+ (16#FEA1#, 16#062D#),
+ (16#FEA2#, 16#062D#),
+ (16#FEA3#, 16#062D#),
+ (16#FEA4#, 16#062D#),
+ (16#FEA5#, 16#062E#),
+ (16#FEA6#, 16#062E#),
+ (16#FEA7#, 16#062E#),
+ (16#FEA8#, 16#062E#),
+ (16#FEA9#, 16#062F#),
+ (16#FEAA#, 16#062F#),
+ (16#FEAB#, 16#0630#),
+ (16#FEAC#, 16#0630#),
+ (16#FEAD#, 16#0631#),
+ (16#FEAE#, 16#0631#),
+ (16#FEAF#, 16#0632#),
+ (16#FEB0#, 16#0632#),
+ (16#FEB1#, 16#0633#),
+ (16#FEB2#, 16#0633#),
+ (16#FEB3#, 16#0633#),
+ (16#FEB4#, 16#0633#),
+ (16#FEB5#, 16#0634#),
+ (16#FEB6#, 16#0634#),
+ (16#FEB7#, 16#0634#),
+ (16#FEB8#, 16#0634#),
+ (16#FEB9#, 16#0635#),
+ (16#FEBA#, 16#0635#),
+ (16#FEBB#, 16#0635#),
+ (16#FEBC#, 16#0635#),
+ (16#FEBD#, 16#0636#),
+ (16#FEBE#, 16#0636#),
+ (16#FEBF#, 16#0636#),
+ (16#FEC0#, 16#0636#),
+ (16#FEC1#, 16#0637#),
+ (16#FEC2#, 16#0637#),
+ (16#FEC3#, 16#0637#),
+ (16#FEC4#, 16#0637#),
+ (16#FEC5#, 16#0638#),
+ (16#FEC6#, 16#0638#),
+ (16#FEC7#, 16#0638#),
+ (16#FEC8#, 16#0638#),
+ (16#FEC9#, 16#0639#),
+ (16#FECA#, 16#0639#),
+ (16#FECB#, 16#0639#),
+ (16#FECC#, 16#0639#),
+ (16#FECD#, 16#063A#),
+ (16#FECE#, 16#063A#),
+ (16#FECF#, 16#063A#),
+ (16#FED0#, 16#063A#),
+ (16#FED1#, 16#0641#),
+ (16#FED2#, 16#0641#),
+ (16#FED3#, 16#0641#),
+ (16#FED4#, 16#0641#),
+ (16#FED5#, 16#0642#),
+ (16#FED6#, 16#0642#),
+ (16#FED7#, 16#0642#),
+ (16#FED8#, 16#0642#),
+ (16#FED9#, 16#0643#),
+ (16#FEDA#, 16#0643#),
+ (16#FEDB#, 16#0643#),
+ (16#FEDC#, 16#0643#),
+ (16#FEDD#, 16#0644#),
+ (16#FEDE#, 16#0644#),
+ (16#FEDF#, 16#0644#),
+ (16#FEE0#, 16#0644#),
+ (16#FEE1#, 16#0645#),
+ (16#FEE2#, 16#0645#),
+ (16#FEE3#, 16#0645#),
+ (16#FEE4#, 16#0645#),
+ (16#FEE5#, 16#0646#),
+ (16#FEE6#, 16#0646#),
+ (16#FEE7#, 16#0646#),
+ (16#FEE8#, 16#0646#),
+ (16#FEE9#, 16#0647#),
+ (16#FEEA#, 16#0647#),
+ (16#FEEB#, 16#0647#),
+ (16#FEEC#, 16#0647#),
+ (16#FEED#, 16#0648#),
+ (16#FEEE#, 16#0648#),
+ (16#FEEF#, 16#0649#),
+ (16#FEF0#, 16#0649#),
+ (16#FEF1#, 16#064A#),
+ (16#FEF2#, 16#064A#),
+ (16#FEF3#, 16#064A#),
+ (16#FEF4#, 16#064A#),
+ (16#FEF5#, 16#0644#),
+ (16#FEF6#, 16#0644#),
+ (16#FEF7#, 16#0644#),
+ (16#FEF8#, 16#0644#),
+ (16#FEF9#, 16#0644#),
+ (16#FEFA#, 16#0644#),
+ (16#FEFB#, 16#0644#),
+ (16#FEFC#, 16#0644#),
+ (16#FF01#, 16#0021#),
+ (16#FF02#, 16#0022#),
+ (16#FF03#, 16#0023#),
+ (16#FF04#, 16#0024#),
+ (16#FF05#, 16#0025#),
+ (16#FF06#, 16#0026#),
+ (16#FF07#, 16#0027#),
+ (16#FF08#, 16#0028#),
+ (16#FF09#, 16#0029#),
+ (16#FF0A#, 16#002A#),
+ (16#FF0B#, 16#002B#),
+ (16#FF0C#, 16#002C#),
+ (16#FF0D#, 16#002D#),
+ (16#FF0E#, 16#002E#),
+ (16#FF0F#, 16#002F#),
+ (16#FF10#, 16#0030#),
+ (16#FF11#, 16#0031#),
+ (16#FF12#, 16#0032#),
+ (16#FF13#, 16#0033#),
+ (16#FF14#, 16#0034#),
+ (16#FF15#, 16#0035#),
+ (16#FF16#, 16#0036#),
+ (16#FF17#, 16#0037#),
+ (16#FF18#, 16#0038#),
+ (16#FF19#, 16#0039#),
+ (16#FF1A#, 16#003A#),
+ (16#FF1B#, 16#003B#),
+ (16#FF1C#, 16#003C#),
+ (16#FF1D#, 16#003D#),
+ (16#FF1E#, 16#003E#),
+ (16#FF1F#, 16#003F#),
+ (16#FF20#, 16#0040#),
+ (16#FF21#, 16#0041#),
+ (16#FF22#, 16#0042#),
+ (16#FF23#, 16#0043#),
+ (16#FF24#, 16#0044#),
+ (16#FF25#, 16#0045#),
+ (16#FF26#, 16#0046#),
+ (16#FF27#, 16#0047#),
+ (16#FF28#, 16#0048#),
+ (16#FF29#, 16#0049#),
+ (16#FF2A#, 16#004A#),
+ (16#FF2B#, 16#004B#),
+ (16#FF2C#, 16#004C#),
+ (16#FF2D#, 16#004D#),
+ (16#FF2E#, 16#004E#),
+ (16#FF2F#, 16#004F#),
+ (16#FF30#, 16#0050#),
+ (16#FF31#, 16#0051#),
+ (16#FF32#, 16#0052#),
+ (16#FF33#, 16#0053#),
+ (16#FF34#, 16#0054#),
+ (16#FF35#, 16#0055#),
+ (16#FF36#, 16#0056#),
+ (16#FF37#, 16#0057#),
+ (16#FF38#, 16#0058#),
+ (16#FF39#, 16#0059#),
+ (16#FF3A#, 16#005A#),
+ (16#FF3B#, 16#005B#),
+ (16#FF3C#, 16#005C#),
+ (16#FF3D#, 16#005D#),
+ (16#FF3E#, 16#005E#),
+ (16#FF3F#, 16#005F#),
+ (16#FF40#, 16#0060#),
+ (16#FF41#, 16#0061#),
+ (16#FF42#, 16#0062#),
+ (16#FF43#, 16#0063#),
+ (16#FF44#, 16#0064#),
+ (16#FF45#, 16#0065#),
+ (16#FF46#, 16#0066#),
+ (16#FF47#, 16#0067#),
+ (16#FF48#, 16#0068#),
+ (16#FF49#, 16#0069#),
+ (16#FF4A#, 16#006A#),
+ (16#FF4B#, 16#006B#),
+ (16#FF4C#, 16#006C#),
+ (16#FF4D#, 16#006D#),
+ (16#FF4E#, 16#006E#),
+ (16#FF4F#, 16#006F#),
+ (16#FF50#, 16#0070#),
+ (16#FF51#, 16#0071#),
+ (16#FF52#, 16#0072#),
+ (16#FF53#, 16#0073#),
+ (16#FF54#, 16#0074#),
+ (16#FF55#, 16#0075#),
+ (16#FF56#, 16#0076#),
+ (16#FF57#, 16#0077#),
+ (16#FF58#, 16#0078#),
+ (16#FF59#, 16#0079#),
+ (16#FF5A#, 16#007A#),
+ (16#FF5B#, 16#007B#),
+ (16#FF5C#, 16#007C#),
+ (16#FF5D#, 16#007D#),
+ (16#FF5E#, 16#007E#),
+ (16#FF5F#, 16#2985#),
+ (16#FF60#, 16#2986#),
+ (16#FF61#, 16#3002#),
+ (16#FF62#, 16#300C#),
+ (16#FF63#, 16#300D#),
+ (16#FF64#, 16#3001#),
+ (16#FF65#, 16#30FB#),
+ (16#FF66#, 16#30F2#),
+ (16#FF67#, 16#30A1#),
+ (16#FF68#, 16#30A3#),
+ (16#FF69#, 16#30A5#),
+ (16#FF6A#, 16#30A7#),
+ (16#FF6B#, 16#30A9#),
+ (16#FF6C#, 16#30E3#),
+ (16#FF6D#, 16#30E5#),
+ (16#FF6E#, 16#30E7#),
+ (16#FF6F#, 16#30C3#),
+ (16#FF70#, 16#30FC#),
+ (16#FF71#, 16#30A2#),
+ (16#FF72#, 16#30A4#),
+ (16#FF73#, 16#30A6#),
+ (16#FF74#, 16#30A8#),
+ (16#FF75#, 16#30AA#),
+ (16#FF76#, 16#30AB#),
+ (16#FF77#, 16#30AD#),
+ (16#FF78#, 16#30AF#),
+ (16#FF79#, 16#30B1#),
+ (16#FF7A#, 16#30B3#),
+ (16#FF7B#, 16#30B5#),
+ (16#FF7C#, 16#30B7#),
+ (16#FF7D#, 16#30B9#),
+ (16#FF7E#, 16#30BB#),
+ (16#FF7F#, 16#30BD#),
+ (16#FF80#, 16#30BF#),
+ (16#FF81#, 16#30C1#),
+ (16#FF82#, 16#30C4#),
+ (16#FF83#, 16#30C6#),
+ (16#FF84#, 16#30C8#),
+ (16#FF85#, 16#30CA#),
+ (16#FF86#, 16#30CB#),
+ (16#FF87#, 16#30CC#),
+ (16#FF88#, 16#30CD#),
+ (16#FF89#, 16#30CE#),
+ (16#FF8A#, 16#30CF#),
+ (16#FF8B#, 16#30D2#),
+ (16#FF8C#, 16#30D5#),
+ (16#FF8D#, 16#30D8#),
+ (16#FF8E#, 16#30DB#),
+ (16#FF8F#, 16#30DE#),
+ (16#FF90#, 16#30DF#),
+ (16#FF91#, 16#30E0#),
+ (16#FF92#, 16#30E1#),
+ (16#FF93#, 16#30E2#),
+ (16#FF94#, 16#30E4#),
+ (16#FF95#, 16#30E6#),
+ (16#FF96#, 16#30E8#),
+ (16#FF97#, 16#30E9#),
+ (16#FF98#, 16#30EA#),
+ (16#FF99#, 16#30EB#),
+ (16#FF9A#, 16#30EC#),
+ (16#FF9B#, 16#30ED#),
+ (16#FF9C#, 16#30EF#),
+ (16#FF9D#, 16#30F3#),
+ (16#FF9E#, 16#3099#),
+ (16#FF9F#, 16#309A#),
+ (16#FFA0#, 16#3164#),
+ (16#FFA1#, 16#3131#),
+ (16#FFA2#, 16#3132#),
+ (16#FFA3#, 16#3133#),
+ (16#FFA4#, 16#3134#),
+ (16#FFA5#, 16#3135#),
+ (16#FFA6#, 16#3136#),
+ (16#FFA7#, 16#3137#),
+ (16#FFA8#, 16#3138#),
+ (16#FFA9#, 16#3139#),
+ (16#FFAA#, 16#313A#),
+ (16#FFAB#, 16#313B#),
+ (16#FFAC#, 16#313C#),
+ (16#FFAD#, 16#313D#),
+ (16#FFAE#, 16#313E#),
+ (16#FFAF#, 16#313F#),
+ (16#FFB0#, 16#3140#),
+ (16#FFB1#, 16#3141#),
+ (16#FFB2#, 16#3142#),
+ (16#FFB3#, 16#3143#),
+ (16#FFB4#, 16#3144#),
+ (16#FFB5#, 16#3145#),
+ (16#FFB6#, 16#3146#),
+ (16#FFB7#, 16#3147#),
+ (16#FFB8#, 16#3148#),
+ (16#FFB9#, 16#3149#),
+ (16#FFBA#, 16#314A#),
+ (16#FFBB#, 16#314B#),
+ (16#FFBC#, 16#314C#),
+ (16#FFBD#, 16#314D#),
+ (16#FFBE#, 16#314E#),
+ (16#FFC2#, 16#314F#),
+ (16#FFC3#, 16#3150#),
+ (16#FFC4#, 16#3151#),
+ (16#FFC5#, 16#3152#),
+ (16#FFC6#, 16#3153#),
+ (16#FFC7#, 16#3154#),
+ (16#FFCA#, 16#3155#),
+ (16#FFCB#, 16#3156#),
+ (16#FFCC#, 16#3157#),
+ (16#FFCD#, 16#3158#),
+ (16#FFCE#, 16#3159#),
+ (16#FFCF#, 16#315A#),
+ (16#FFD2#, 16#315B#),
+ (16#FFD3#, 16#315C#),
+ (16#FFD4#, 16#315D#),
+ (16#FFD5#, 16#315E#),
+ (16#FFD6#, 16#315F#),
+ (16#FFD7#, 16#3160#),
+ (16#FFDA#, 16#3161#),
+ (16#FFDB#, 16#3162#),
+ (16#FFDC#, 16#3163#),
+ (16#FFE0#, 16#00A2#),
+ (16#FFE1#, 16#00A3#),
+ (16#FFE2#, 16#00AC#),
+ (16#FFE3#, 16#00AF#),
+ (16#FFE4#, 16#00A6#),
+ (16#FFE5#, 16#00A5#),
+ (16#FFE6#, 16#20A9#),
+ (16#FFE8#, 16#2502#),
+ (16#FFE9#, 16#2190#),
+ (16#FFEA#, 16#2191#),
+ (16#FFEB#, 16#2192#),
+ (16#FFEC#, 16#2193#),
+ (16#FFED#, 16#25A0#),
+ (16#FFEE#, 16#25CB#),
+ (16#1109A#, 16#11099#),
+ (16#1109C#, 16#1109B#),
+ (16#110AB#, 16#110A5#),
+ (16#1112E#, 16#11131#),
+ (16#1112F#, 16#11132#),
+ (16#1134B#, 16#11347#),
+ (16#1134C#, 16#11347#),
+ (16#114BB#, 16#114B9#),
+ (16#114BC#, 16#114B9#),
+ (16#114BE#, 16#114B9#),
+ (16#115BA#, 16#115B8#),
+ (16#115BB#, 16#115B9#),
+ (16#11938#, 16#11935#),
+ (16#1D15E#, 16#1D157#),
+ (16#1D15F#, 16#1D158#),
+ (16#1D160#, 16#1D15F#),
+ (16#1D161#, 16#1D15F#),
+ (16#1D162#, 16#1D15F#),
+ (16#1D163#, 16#1D15F#),
+ (16#1D164#, 16#1D15F#),
+ (16#1D1BB#, 16#1D1B9#),
+ (16#1D1BC#, 16#1D1BA#),
+ (16#1D1BD#, 16#1D1BB#),
+ (16#1D1BE#, 16#1D1BC#),
+ (16#1D1BF#, 16#1D1BB#),
+ (16#1D1C0#, 16#1D1BC#),
+ (16#1D400#, 16#0041#),
+ (16#1D401#, 16#0042#),
+ (16#1D402#, 16#0043#),
+ (16#1D403#, 16#0044#),
+ (16#1D404#, 16#0045#),
+ (16#1D405#, 16#0046#),
+ (16#1D406#, 16#0047#),
+ (16#1D407#, 16#0048#),
+ (16#1D408#, 16#0049#),
+ (16#1D409#, 16#004A#),
+ (16#1D40A#, 16#004B#),
+ (16#1D40B#, 16#004C#),
+ (16#1D40C#, 16#004D#),
+ (16#1D40D#, 16#004E#),
+ (16#1D40E#, 16#004F#),
+ (16#1D40F#, 16#0050#),
+ (16#1D410#, 16#0051#),
+ (16#1D411#, 16#0052#),
+ (16#1D412#, 16#0053#),
+ (16#1D413#, 16#0054#),
+ (16#1D414#, 16#0055#),
+ (16#1D415#, 16#0056#),
+ (16#1D416#, 16#0057#),
+ (16#1D417#, 16#0058#),
+ (16#1D418#, 16#0059#),
+ (16#1D419#, 16#005A#),
+ (16#1D41A#, 16#0061#),
+ (16#1D41B#, 16#0062#),
+ (16#1D41C#, 16#0063#),
+ (16#1D41D#, 16#0064#),
+ (16#1D41E#, 16#0065#),
+ (16#1D41F#, 16#0066#),
+ (16#1D420#, 16#0067#),
+ (16#1D421#, 16#0068#),
+ (16#1D422#, 16#0069#),
+ (16#1D423#, 16#006A#),
+ (16#1D424#, 16#006B#),
+ (16#1D425#, 16#006C#),
+ (16#1D426#, 16#006D#),
+ (16#1D427#, 16#006E#),
+ (16#1D428#, 16#006F#),
+ (16#1D429#, 16#0070#),
+ (16#1D42A#, 16#0071#),
+ (16#1D42B#, 16#0072#),
+ (16#1D42C#, 16#0073#),
+ (16#1D42D#, 16#0074#),
+ (16#1D42E#, 16#0075#),
+ (16#1D42F#, 16#0076#),
+ (16#1D430#, 16#0077#),
+ (16#1D431#, 16#0078#),
+ (16#1D432#, 16#0079#),
+ (16#1D433#, 16#007A#),
+ (16#1D434#, 16#0041#),
+ (16#1D435#, 16#0042#),
+ (16#1D436#, 16#0043#),
+ (16#1D437#, 16#0044#),
+ (16#1D438#, 16#0045#),
+ (16#1D439#, 16#0046#),
+ (16#1D43A#, 16#0047#),
+ (16#1D43B#, 16#0048#),
+ (16#1D43C#, 16#0049#),
+ (16#1D43D#, 16#004A#),
+ (16#1D43E#, 16#004B#),
+ (16#1D43F#, 16#004C#),
+ (16#1D440#, 16#004D#),
+ (16#1D441#, 16#004E#),
+ (16#1D442#, 16#004F#),
+ (16#1D443#, 16#0050#),
+ (16#1D444#, 16#0051#),
+ (16#1D445#, 16#0052#),
+ (16#1D446#, 16#0053#),
+ (16#1D447#, 16#0054#),
+ (16#1D448#, 16#0055#),
+ (16#1D449#, 16#0056#),
+ (16#1D44A#, 16#0057#),
+ (16#1D44B#, 16#0058#),
+ (16#1D44C#, 16#0059#),
+ (16#1D44D#, 16#005A#),
+ (16#1D44E#, 16#0061#),
+ (16#1D44F#, 16#0062#),
+ (16#1D450#, 16#0063#),
+ (16#1D451#, 16#0064#),
+ (16#1D452#, 16#0065#),
+ (16#1D453#, 16#0066#),
+ (16#1D454#, 16#0067#),
+ (16#1D456#, 16#0069#),
+ (16#1D457#, 16#006A#),
+ (16#1D458#, 16#006B#),
+ (16#1D459#, 16#006C#),
+ (16#1D45A#, 16#006D#),
+ (16#1D45B#, 16#006E#),
+ (16#1D45C#, 16#006F#),
+ (16#1D45D#, 16#0070#),
+ (16#1D45E#, 16#0071#),
+ (16#1D45F#, 16#0072#),
+ (16#1D460#, 16#0073#),
+ (16#1D461#, 16#0074#),
+ (16#1D462#, 16#0075#),
+ (16#1D463#, 16#0076#),
+ (16#1D464#, 16#0077#),
+ (16#1D465#, 16#0078#),
+ (16#1D466#, 16#0079#),
+ (16#1D467#, 16#007A#),
+ (16#1D468#, 16#0041#),
+ (16#1D469#, 16#0042#),
+ (16#1D46A#, 16#0043#),
+ (16#1D46B#, 16#0044#),
+ (16#1D46C#, 16#0045#),
+ (16#1D46D#, 16#0046#),
+ (16#1D46E#, 16#0047#),
+ (16#1D46F#, 16#0048#),
+ (16#1D470#, 16#0049#),
+ (16#1D471#, 16#004A#),
+ (16#1D472#, 16#004B#),
+ (16#1D473#, 16#004C#),
+ (16#1D474#, 16#004D#),
+ (16#1D475#, 16#004E#),
+ (16#1D476#, 16#004F#),
+ (16#1D477#, 16#0050#),
+ (16#1D478#, 16#0051#),
+ (16#1D479#, 16#0052#),
+ (16#1D47A#, 16#0053#),
+ (16#1D47B#, 16#0054#),
+ (16#1D47C#, 16#0055#),
+ (16#1D47D#, 16#0056#),
+ (16#1D47E#, 16#0057#),
+ (16#1D47F#, 16#0058#),
+ (16#1D480#, 16#0059#),
+ (16#1D481#, 16#005A#),
+ (16#1D482#, 16#0061#),
+ (16#1D483#, 16#0062#),
+ (16#1D484#, 16#0063#),
+ (16#1D485#, 16#0064#),
+ (16#1D486#, 16#0065#),
+ (16#1D487#, 16#0066#),
+ (16#1D488#, 16#0067#),
+ (16#1D489#, 16#0068#),
+ (16#1D48A#, 16#0069#),
+ (16#1D48B#, 16#006A#),
+ (16#1D48C#, 16#006B#),
+ (16#1D48D#, 16#006C#),
+ (16#1D48E#, 16#006D#),
+ (16#1D48F#, 16#006E#),
+ (16#1D490#, 16#006F#),
+ (16#1D491#, 16#0070#),
+ (16#1D492#, 16#0071#),
+ (16#1D493#, 16#0072#),
+ (16#1D494#, 16#0073#),
+ (16#1D495#, 16#0074#),
+ (16#1D496#, 16#0075#),
+ (16#1D497#, 16#0076#),
+ (16#1D498#, 16#0077#),
+ (16#1D499#, 16#0078#),
+ (16#1D49A#, 16#0079#),
+ (16#1D49B#, 16#007A#),
+ (16#1D49C#, 16#0041#),
+ (16#1D49E#, 16#0043#),
+ (16#1D49F#, 16#0044#),
+ (16#1D4A2#, 16#0047#),
+ (16#1D4A5#, 16#004A#),
+ (16#1D4A6#, 16#004B#),
+ (16#1D4A9#, 16#004E#),
+ (16#1D4AA#, 16#004F#),
+ (16#1D4AB#, 16#0050#),
+ (16#1D4AC#, 16#0051#),
+ (16#1D4AE#, 16#0053#),
+ (16#1D4AF#, 16#0054#),
+ (16#1D4B0#, 16#0055#),
+ (16#1D4B1#, 16#0056#),
+ (16#1D4B2#, 16#0057#),
+ (16#1D4B3#, 16#0058#),
+ (16#1D4B4#, 16#0059#),
+ (16#1D4B5#, 16#005A#),
+ (16#1D4B6#, 16#0061#),
+ (16#1D4B7#, 16#0062#),
+ (16#1D4B8#, 16#0063#),
+ (16#1D4B9#, 16#0064#),
+ (16#1D4BB#, 16#0066#),
+ (16#1D4BD#, 16#0068#),
+ (16#1D4BE#, 16#0069#),
+ (16#1D4BF#, 16#006A#),
+ (16#1D4C0#, 16#006B#),
+ (16#1D4C1#, 16#006C#),
+ (16#1D4C2#, 16#006D#),
+ (16#1D4C3#, 16#006E#),
+ (16#1D4C5#, 16#0070#),
+ (16#1D4C6#, 16#0071#),
+ (16#1D4C7#, 16#0072#),
+ (16#1D4C8#, 16#0073#),
+ (16#1D4C9#, 16#0074#),
+ (16#1D4CA#, 16#0075#),
+ (16#1D4CB#, 16#0076#),
+ (16#1D4CC#, 16#0077#),
+ (16#1D4CD#, 16#0078#),
+ (16#1D4CE#, 16#0079#),
+ (16#1D4CF#, 16#007A#),
+ (16#1D4D0#, 16#0041#),
+ (16#1D4D1#, 16#0042#),
+ (16#1D4D2#, 16#0043#),
+ (16#1D4D3#, 16#0044#),
+ (16#1D4D4#, 16#0045#),
+ (16#1D4D5#, 16#0046#),
+ (16#1D4D6#, 16#0047#),
+ (16#1D4D7#, 16#0048#),
+ (16#1D4D8#, 16#0049#),
+ (16#1D4D9#, 16#004A#),
+ (16#1D4DA#, 16#004B#),
+ (16#1D4DB#, 16#004C#),
+ (16#1D4DC#, 16#004D#),
+ (16#1D4DD#, 16#004E#),
+ (16#1D4DE#, 16#004F#),
+ (16#1D4DF#, 16#0050#),
+ (16#1D4E0#, 16#0051#),
+ (16#1D4E1#, 16#0052#),
+ (16#1D4E2#, 16#0053#),
+ (16#1D4E3#, 16#0054#),
+ (16#1D4E4#, 16#0055#),
+ (16#1D4E5#, 16#0056#),
+ (16#1D4E6#, 16#0057#),
+ (16#1D4E7#, 16#0058#),
+ (16#1D4E8#, 16#0059#),
+ (16#1D4E9#, 16#005A#),
+ (16#1D4EA#, 16#0061#),
+ (16#1D4EB#, 16#0062#),
+ (16#1D4EC#, 16#0063#),
+ (16#1D4ED#, 16#0064#),
+ (16#1D4EE#, 16#0065#),
+ (16#1D4EF#, 16#0066#),
+ (16#1D4F0#, 16#0067#),
+ (16#1D4F1#, 16#0068#),
+ (16#1D4F2#, 16#0069#),
+ (16#1D4F3#, 16#006A#),
+ (16#1D4F4#, 16#006B#),
+ (16#1D4F5#, 16#006C#),
+ (16#1D4F6#, 16#006D#),
+ (16#1D4F7#, 16#006E#),
+ (16#1D4F8#, 16#006F#),
+ (16#1D4F9#, 16#0070#),
+ (16#1D4FA#, 16#0071#),
+ (16#1D4FB#, 16#0072#),
+ (16#1D4FC#, 16#0073#),
+ (16#1D4FD#, 16#0074#),
+ (16#1D4FE#, 16#0075#),
+ (16#1D4FF#, 16#0076#),
+ (16#1D500#, 16#0077#),
+ (16#1D501#, 16#0078#),
+ (16#1D502#, 16#0079#),
+ (16#1D503#, 16#007A#),
+ (16#1D504#, 16#0041#),
+ (16#1D505#, 16#0042#),
+ (16#1D507#, 16#0044#),
+ (16#1D508#, 16#0045#),
+ (16#1D509#, 16#0046#),
+ (16#1D50A#, 16#0047#),
+ (16#1D50D#, 16#004A#),
+ (16#1D50E#, 16#004B#),
+ (16#1D50F#, 16#004C#),
+ (16#1D510#, 16#004D#),
+ (16#1D511#, 16#004E#),
+ (16#1D512#, 16#004F#),
+ (16#1D513#, 16#0050#),
+ (16#1D514#, 16#0051#),
+ (16#1D516#, 16#0053#),
+ (16#1D517#, 16#0054#),
+ (16#1D518#, 16#0055#),
+ (16#1D519#, 16#0056#),
+ (16#1D51A#, 16#0057#),
+ (16#1D51B#, 16#0058#),
+ (16#1D51C#, 16#0059#),
+ (16#1D51E#, 16#0061#),
+ (16#1D51F#, 16#0062#),
+ (16#1D520#, 16#0063#),
+ (16#1D521#, 16#0064#),
+ (16#1D522#, 16#0065#),
+ (16#1D523#, 16#0066#),
+ (16#1D524#, 16#0067#),
+ (16#1D525#, 16#0068#),
+ (16#1D526#, 16#0069#),
+ (16#1D527#, 16#006A#),
+ (16#1D528#, 16#006B#),
+ (16#1D529#, 16#006C#),
+ (16#1D52A#, 16#006D#),
+ (16#1D52B#, 16#006E#),
+ (16#1D52C#, 16#006F#),
+ (16#1D52D#, 16#0070#),
+ (16#1D52E#, 16#0071#),
+ (16#1D52F#, 16#0072#),
+ (16#1D530#, 16#0073#),
+ (16#1D531#, 16#0074#),
+ (16#1D532#, 16#0075#),
+ (16#1D533#, 16#0076#),
+ (16#1D534#, 16#0077#),
+ (16#1D535#, 16#0078#),
+ (16#1D536#, 16#0079#),
+ (16#1D537#, 16#007A#),
+ (16#1D538#, 16#0041#),
+ (16#1D539#, 16#0042#),
+ (16#1D53B#, 16#0044#),
+ (16#1D53C#, 16#0045#),
+ (16#1D53D#, 16#0046#),
+ (16#1D53E#, 16#0047#),
+ (16#1D540#, 16#0049#),
+ (16#1D541#, 16#004A#),
+ (16#1D542#, 16#004B#),
+ (16#1D543#, 16#004C#),
+ (16#1D544#, 16#004D#),
+ (16#1D546#, 16#004F#),
+ (16#1D54A#, 16#0053#),
+ (16#1D54B#, 16#0054#),
+ (16#1D54C#, 16#0055#),
+ (16#1D54D#, 16#0056#),
+ (16#1D54E#, 16#0057#),
+ (16#1D54F#, 16#0058#),
+ (16#1D550#, 16#0059#),
+ (16#1D552#, 16#0061#),
+ (16#1D553#, 16#0062#),
+ (16#1D554#, 16#0063#),
+ (16#1D555#, 16#0064#),
+ (16#1D556#, 16#0065#),
+ (16#1D557#, 16#0066#),
+ (16#1D558#, 16#0067#),
+ (16#1D559#, 16#0068#),
+ (16#1D55A#, 16#0069#),
+ (16#1D55B#, 16#006A#),
+ (16#1D55C#, 16#006B#),
+ (16#1D55D#, 16#006C#),
+ (16#1D55E#, 16#006D#),
+ (16#1D55F#, 16#006E#),
+ (16#1D560#, 16#006F#),
+ (16#1D561#, 16#0070#),
+ (16#1D562#, 16#0071#),
+ (16#1D563#, 16#0072#),
+ (16#1D564#, 16#0073#),
+ (16#1D565#, 16#0074#),
+ (16#1D566#, 16#0075#),
+ (16#1D567#, 16#0076#),
+ (16#1D568#, 16#0077#),
+ (16#1D569#, 16#0078#),
+ (16#1D56A#, 16#0079#),
+ (16#1D56B#, 16#007A#),
+ (16#1D56C#, 16#0041#),
+ (16#1D56D#, 16#0042#),
+ (16#1D56E#, 16#0043#),
+ (16#1D56F#, 16#0044#),
+ (16#1D570#, 16#0045#),
+ (16#1D571#, 16#0046#),
+ (16#1D572#, 16#0047#),
+ (16#1D573#, 16#0048#),
+ (16#1D574#, 16#0049#),
+ (16#1D575#, 16#004A#),
+ (16#1D576#, 16#004B#),
+ (16#1D577#, 16#004C#),
+ (16#1D578#, 16#004D#),
+ (16#1D579#, 16#004E#),
+ (16#1D57A#, 16#004F#),
+ (16#1D57B#, 16#0050#),
+ (16#1D57C#, 16#0051#),
+ (16#1D57D#, 16#0052#),
+ (16#1D57E#, 16#0053#),
+ (16#1D57F#, 16#0054#),
+ (16#1D580#, 16#0055#),
+ (16#1D581#, 16#0056#),
+ (16#1D582#, 16#0057#),
+ (16#1D583#, 16#0058#),
+ (16#1D584#, 16#0059#),
+ (16#1D585#, 16#005A#),
+ (16#1D586#, 16#0061#),
+ (16#1D587#, 16#0062#),
+ (16#1D588#, 16#0063#),
+ (16#1D589#, 16#0064#),
+ (16#1D58A#, 16#0065#),
+ (16#1D58B#, 16#0066#),
+ (16#1D58C#, 16#0067#),
+ (16#1D58D#, 16#0068#),
+ (16#1D58E#, 16#0069#),
+ (16#1D58F#, 16#006A#),
+ (16#1D590#, 16#006B#),
+ (16#1D591#, 16#006C#),
+ (16#1D592#, 16#006D#),
+ (16#1D593#, 16#006E#),
+ (16#1D594#, 16#006F#),
+ (16#1D595#, 16#0070#),
+ (16#1D596#, 16#0071#),
+ (16#1D597#, 16#0072#),
+ (16#1D598#, 16#0073#),
+ (16#1D599#, 16#0074#),
+ (16#1D59A#, 16#0075#),
+ (16#1D59B#, 16#0076#),
+ (16#1D59C#, 16#0077#),
+ (16#1D59D#, 16#0078#),
+ (16#1D59E#, 16#0079#),
+ (16#1D59F#, 16#007A#),
+ (16#1D5A0#, 16#0041#),
+ (16#1D5A1#, 16#0042#),
+ (16#1D5A2#, 16#0043#),
+ (16#1D5A3#, 16#0044#),
+ (16#1D5A4#, 16#0045#),
+ (16#1D5A5#, 16#0046#),
+ (16#1D5A6#, 16#0047#),
+ (16#1D5A7#, 16#0048#),
+ (16#1D5A8#, 16#0049#),
+ (16#1D5A9#, 16#004A#),
+ (16#1D5AA#, 16#004B#),
+ (16#1D5AB#, 16#004C#),
+ (16#1D5AC#, 16#004D#),
+ (16#1D5AD#, 16#004E#),
+ (16#1D5AE#, 16#004F#),
+ (16#1D5AF#, 16#0050#),
+ (16#1D5B0#, 16#0051#),
+ (16#1D5B1#, 16#0052#),
+ (16#1D5B2#, 16#0053#),
+ (16#1D5B3#, 16#0054#),
+ (16#1D5B4#, 16#0055#),
+ (16#1D5B5#, 16#0056#),
+ (16#1D5B6#, 16#0057#),
+ (16#1D5B7#, 16#0058#),
+ (16#1D5B8#, 16#0059#),
+ (16#1D5B9#, 16#005A#),
+ (16#1D5BA#, 16#0061#),
+ (16#1D5BB#, 16#0062#),
+ (16#1D5BC#, 16#0063#),
+ (16#1D5BD#, 16#0064#),
+ (16#1D5BE#, 16#0065#),
+ (16#1D5BF#, 16#0066#),
+ (16#1D5C0#, 16#0067#),
+ (16#1D5C1#, 16#0068#),
+ (16#1D5C2#, 16#0069#),
+ (16#1D5C3#, 16#006A#),
+ (16#1D5C4#, 16#006B#),
+ (16#1D5C5#, 16#006C#),
+ (16#1D5C6#, 16#006D#),
+ (16#1D5C7#, 16#006E#),
+ (16#1D5C8#, 16#006F#),
+ (16#1D5C9#, 16#0070#),
+ (16#1D5CA#, 16#0071#),
+ (16#1D5CB#, 16#0072#),
+ (16#1D5CC#, 16#0073#),
+ (16#1D5CD#, 16#0074#),
+ (16#1D5CE#, 16#0075#),
+ (16#1D5CF#, 16#0076#),
+ (16#1D5D0#, 16#0077#),
+ (16#1D5D1#, 16#0078#),
+ (16#1D5D2#, 16#0079#),
+ (16#1D5D3#, 16#007A#),
+ (16#1D5D4#, 16#0041#),
+ (16#1D5D5#, 16#0042#),
+ (16#1D5D6#, 16#0043#),
+ (16#1D5D7#, 16#0044#),
+ (16#1D5D8#, 16#0045#),
+ (16#1D5D9#, 16#0046#),
+ (16#1D5DA#, 16#0047#),
+ (16#1D5DB#, 16#0048#),
+ (16#1D5DC#, 16#0049#),
+ (16#1D5DD#, 16#004A#),
+ (16#1D5DE#, 16#004B#),
+ (16#1D5DF#, 16#004C#),
+ (16#1D5E0#, 16#004D#),
+ (16#1D5E1#, 16#004E#),
+ (16#1D5E2#, 16#004F#),
+ (16#1D5E3#, 16#0050#),
+ (16#1D5E4#, 16#0051#),
+ (16#1D5E5#, 16#0052#),
+ (16#1D5E6#, 16#0053#),
+ (16#1D5E7#, 16#0054#),
+ (16#1D5E8#, 16#0055#),
+ (16#1D5E9#, 16#0056#),
+ (16#1D5EA#, 16#0057#),
+ (16#1D5EB#, 16#0058#),
+ (16#1D5EC#, 16#0059#),
+ (16#1D5ED#, 16#005A#),
+ (16#1D5EE#, 16#0061#),
+ (16#1D5EF#, 16#0062#),
+ (16#1D5F0#, 16#0063#),
+ (16#1D5F1#, 16#0064#),
+ (16#1D5F2#, 16#0065#),
+ (16#1D5F3#, 16#0066#),
+ (16#1D5F4#, 16#0067#),
+ (16#1D5F5#, 16#0068#),
+ (16#1D5F6#, 16#0069#),
+ (16#1D5F7#, 16#006A#),
+ (16#1D5F8#, 16#006B#),
+ (16#1D5F9#, 16#006C#),
+ (16#1D5FA#, 16#006D#),
+ (16#1D5FB#, 16#006E#),
+ (16#1D5FC#, 16#006F#),
+ (16#1D5FD#, 16#0070#),
+ (16#1D5FE#, 16#0071#),
+ (16#1D5FF#, 16#0072#),
+ (16#1D600#, 16#0073#),
+ (16#1D601#, 16#0074#),
+ (16#1D602#, 16#0075#),
+ (16#1D603#, 16#0076#),
+ (16#1D604#, 16#0077#),
+ (16#1D605#, 16#0078#),
+ (16#1D606#, 16#0079#),
+ (16#1D607#, 16#007A#),
+ (16#1D608#, 16#0041#),
+ (16#1D609#, 16#0042#),
+ (16#1D60A#, 16#0043#),
+ (16#1D60B#, 16#0044#),
+ (16#1D60C#, 16#0045#),
+ (16#1D60D#, 16#0046#),
+ (16#1D60E#, 16#0047#),
+ (16#1D60F#, 16#0048#),
+ (16#1D610#, 16#0049#),
+ (16#1D611#, 16#004A#),
+ (16#1D612#, 16#004B#),
+ (16#1D613#, 16#004C#),
+ (16#1D614#, 16#004D#),
+ (16#1D615#, 16#004E#),
+ (16#1D616#, 16#004F#),
+ (16#1D617#, 16#0050#),
+ (16#1D618#, 16#0051#),
+ (16#1D619#, 16#0052#),
+ (16#1D61A#, 16#0053#),
+ (16#1D61B#, 16#0054#),
+ (16#1D61C#, 16#0055#),
+ (16#1D61D#, 16#0056#),
+ (16#1D61E#, 16#0057#),
+ (16#1D61F#, 16#0058#),
+ (16#1D620#, 16#0059#),
+ (16#1D621#, 16#005A#),
+ (16#1D622#, 16#0061#),
+ (16#1D623#, 16#0062#),
+ (16#1D624#, 16#0063#),
+ (16#1D625#, 16#0064#),
+ (16#1D626#, 16#0065#),
+ (16#1D627#, 16#0066#),
+ (16#1D628#, 16#0067#),
+ (16#1D629#, 16#0068#),
+ (16#1D62A#, 16#0069#),
+ (16#1D62B#, 16#006A#),
+ (16#1D62C#, 16#006B#),
+ (16#1D62D#, 16#006C#),
+ (16#1D62E#, 16#006D#),
+ (16#1D62F#, 16#006E#),
+ (16#1D630#, 16#006F#),
+ (16#1D631#, 16#0070#),
+ (16#1D632#, 16#0071#),
+ (16#1D633#, 16#0072#),
+ (16#1D634#, 16#0073#),
+ (16#1D635#, 16#0074#),
+ (16#1D636#, 16#0075#),
+ (16#1D637#, 16#0076#),
+ (16#1D638#, 16#0077#),
+ (16#1D639#, 16#0078#),
+ (16#1D63A#, 16#0079#),
+ (16#1D63B#, 16#007A#),
+ (16#1D63C#, 16#0041#),
+ (16#1D63D#, 16#0042#),
+ (16#1D63E#, 16#0043#),
+ (16#1D63F#, 16#0044#),
+ (16#1D640#, 16#0045#),
+ (16#1D641#, 16#0046#),
+ (16#1D642#, 16#0047#),
+ (16#1D643#, 16#0048#),
+ (16#1D644#, 16#0049#),
+ (16#1D645#, 16#004A#),
+ (16#1D646#, 16#004B#),
+ (16#1D647#, 16#004C#),
+ (16#1D648#, 16#004D#),
+ (16#1D649#, 16#004E#),
+ (16#1D64A#, 16#004F#),
+ (16#1D64B#, 16#0050#),
+ (16#1D64C#, 16#0051#),
+ (16#1D64D#, 16#0052#),
+ (16#1D64E#, 16#0053#),
+ (16#1D64F#, 16#0054#),
+ (16#1D650#, 16#0055#),
+ (16#1D651#, 16#0056#),
+ (16#1D652#, 16#0057#),
+ (16#1D653#, 16#0058#),
+ (16#1D654#, 16#0059#),
+ (16#1D655#, 16#005A#),
+ (16#1D656#, 16#0061#),
+ (16#1D657#, 16#0062#),
+ (16#1D658#, 16#0063#),
+ (16#1D659#, 16#0064#),
+ (16#1D65A#, 16#0065#),
+ (16#1D65B#, 16#0066#),
+ (16#1D65C#, 16#0067#),
+ (16#1D65D#, 16#0068#),
+ (16#1D65E#, 16#0069#),
+ (16#1D65F#, 16#006A#),
+ (16#1D660#, 16#006B#),
+ (16#1D661#, 16#006C#),
+ (16#1D662#, 16#006D#),
+ (16#1D663#, 16#006E#),
+ (16#1D664#, 16#006F#),
+ (16#1D665#, 16#0070#),
+ (16#1D666#, 16#0071#),
+ (16#1D667#, 16#0072#),
+ (16#1D668#, 16#0073#),
+ (16#1D669#, 16#0074#),
+ (16#1D66A#, 16#0075#),
+ (16#1D66B#, 16#0076#),
+ (16#1D66C#, 16#0077#),
+ (16#1D66D#, 16#0078#),
+ (16#1D66E#, 16#0079#),
+ (16#1D66F#, 16#007A#),
+ (16#1D670#, 16#0041#),
+ (16#1D671#, 16#0042#),
+ (16#1D672#, 16#0043#),
+ (16#1D673#, 16#0044#),
+ (16#1D674#, 16#0045#),
+ (16#1D675#, 16#0046#),
+ (16#1D676#, 16#0047#),
+ (16#1D677#, 16#0048#),
+ (16#1D678#, 16#0049#),
+ (16#1D679#, 16#004A#),
+ (16#1D67A#, 16#004B#),
+ (16#1D67B#, 16#004C#),
+ (16#1D67C#, 16#004D#),
+ (16#1D67D#, 16#004E#),
+ (16#1D67E#, 16#004F#),
+ (16#1D67F#, 16#0050#),
+ (16#1D680#, 16#0051#),
+ (16#1D681#, 16#0052#),
+ (16#1D682#, 16#0053#),
+ (16#1D683#, 16#0054#),
+ (16#1D684#, 16#0055#),
+ (16#1D685#, 16#0056#),
+ (16#1D686#, 16#0057#),
+ (16#1D687#, 16#0058#),
+ (16#1D688#, 16#0059#),
+ (16#1D689#, 16#005A#),
+ (16#1D68A#, 16#0061#),
+ (16#1D68B#, 16#0062#),
+ (16#1D68C#, 16#0063#),
+ (16#1D68D#, 16#0064#),
+ (16#1D68E#, 16#0065#),
+ (16#1D68F#, 16#0066#),
+ (16#1D690#, 16#0067#),
+ (16#1D691#, 16#0068#),
+ (16#1D692#, 16#0069#),
+ (16#1D693#, 16#006A#),
+ (16#1D694#, 16#006B#),
+ (16#1D695#, 16#006C#),
+ (16#1D696#, 16#006D#),
+ (16#1D697#, 16#006E#),
+ (16#1D698#, 16#006F#),
+ (16#1D699#, 16#0070#),
+ (16#1D69A#, 16#0071#),
+ (16#1D69B#, 16#0072#),
+ (16#1D69C#, 16#0073#),
+ (16#1D69D#, 16#0074#),
+ (16#1D69E#, 16#0075#),
+ (16#1D69F#, 16#0076#),
+ (16#1D6A0#, 16#0077#),
+ (16#1D6A1#, 16#0078#),
+ (16#1D6A2#, 16#0079#),
+ (16#1D6A3#, 16#007A#),
+ (16#1D6A4#, 16#0131#),
+ (16#1D6A5#, 16#0237#),
+ (16#1D6A8#, 16#0391#),
+ (16#1D6A9#, 16#0392#),
+ (16#1D6AA#, 16#0393#),
+ (16#1D6AB#, 16#0394#),
+ (16#1D6AC#, 16#0395#),
+ (16#1D6AD#, 16#0396#),
+ (16#1D6AE#, 16#0397#),
+ (16#1D6AF#, 16#0398#),
+ (16#1D6B0#, 16#0399#),
+ (16#1D6B1#, 16#039A#),
+ (16#1D6B2#, 16#039B#),
+ (16#1D6B3#, 16#039C#),
+ (16#1D6B4#, 16#039D#),
+ (16#1D6B5#, 16#039E#),
+ (16#1D6B6#, 16#039F#),
+ (16#1D6B7#, 16#03A0#),
+ (16#1D6B8#, 16#03A1#),
+ (16#1D6B9#, 16#03F4#),
+ (16#1D6BA#, 16#03A3#),
+ (16#1D6BB#, 16#03A4#),
+ (16#1D6BC#, 16#03A5#),
+ (16#1D6BD#, 16#03A6#),
+ (16#1D6BE#, 16#03A7#),
+ (16#1D6BF#, 16#03A8#),
+ (16#1D6C0#, 16#03A9#),
+ (16#1D6C1#, 16#2207#),
+ (16#1D6C2#, 16#03B1#),
+ (16#1D6C3#, 16#03B2#),
+ (16#1D6C4#, 16#03B3#),
+ (16#1D6C5#, 16#03B4#),
+ (16#1D6C6#, 16#03B5#),
+ (16#1D6C7#, 16#03B6#),
+ (16#1D6C8#, 16#03B7#),
+ (16#1D6C9#, 16#03B8#),
+ (16#1D6CA#, 16#03B9#),
+ (16#1D6CB#, 16#03BA#),
+ (16#1D6CC#, 16#03BB#),
+ (16#1D6CD#, 16#03BC#),
+ (16#1D6CE#, 16#03BD#),
+ (16#1D6CF#, 16#03BE#),
+ (16#1D6D0#, 16#03BF#),
+ (16#1D6D1#, 16#03C0#),
+ (16#1D6D2#, 16#03C1#),
+ (16#1D6D3#, 16#03C2#),
+ (16#1D6D4#, 16#03C3#),
+ (16#1D6D5#, 16#03C4#),
+ (16#1D6D6#, 16#03C5#),
+ (16#1D6D7#, 16#03C6#),
+ (16#1D6D8#, 16#03C7#),
+ (16#1D6D9#, 16#03C8#),
+ (16#1D6DA#, 16#03C9#),
+ (16#1D6DB#, 16#2202#),
+ (16#1D6DC#, 16#03F5#),
+ (16#1D6DD#, 16#03D1#),
+ (16#1D6DE#, 16#03F0#),
+ (16#1D6DF#, 16#03D5#),
+ (16#1D6E0#, 16#03F1#),
+ (16#1D6E1#, 16#03D6#),
+ (16#1D6E2#, 16#0391#),
+ (16#1D6E3#, 16#0392#),
+ (16#1D6E4#, 16#0393#),
+ (16#1D6E5#, 16#0394#),
+ (16#1D6E6#, 16#0395#),
+ (16#1D6E7#, 16#0396#),
+ (16#1D6E8#, 16#0397#),
+ (16#1D6E9#, 16#0398#),
+ (16#1D6EA#, 16#0399#),
+ (16#1D6EB#, 16#039A#),
+ (16#1D6EC#, 16#039B#),
+ (16#1D6ED#, 16#039C#),
+ (16#1D6EE#, 16#039D#),
+ (16#1D6EF#, 16#039E#),
+ (16#1D6F0#, 16#039F#),
+ (16#1D6F1#, 16#03A0#),
+ (16#1D6F2#, 16#03A1#),
+ (16#1D6F3#, 16#03F4#),
+ (16#1D6F4#, 16#03A3#),
+ (16#1D6F5#, 16#03A4#),
+ (16#1D6F6#, 16#03A5#),
+ (16#1D6F7#, 16#03A6#),
+ (16#1D6F8#, 16#03A7#),
+ (16#1D6F9#, 16#03A8#),
+ (16#1D6FA#, 16#03A9#),
+ (16#1D6FB#, 16#2207#),
+ (16#1D6FC#, 16#03B1#),
+ (16#1D6FD#, 16#03B2#),
+ (16#1D6FE#, 16#03B3#),
+ (16#1D6FF#, 16#03B4#),
+ (16#1D700#, 16#03B5#),
+ (16#1D701#, 16#03B6#),
+ (16#1D702#, 16#03B7#),
+ (16#1D703#, 16#03B8#),
+ (16#1D704#, 16#03B9#),
+ (16#1D705#, 16#03BA#),
+ (16#1D706#, 16#03BB#),
+ (16#1D707#, 16#03BC#),
+ (16#1D708#, 16#03BD#),
+ (16#1D709#, 16#03BE#),
+ (16#1D70A#, 16#03BF#),
+ (16#1D70B#, 16#03C0#),
+ (16#1D70C#, 16#03C1#),
+ (16#1D70D#, 16#03C2#),
+ (16#1D70E#, 16#03C3#),
+ (16#1D70F#, 16#03C4#),
+ (16#1D710#, 16#03C5#),
+ (16#1D711#, 16#03C6#),
+ (16#1D712#, 16#03C7#),
+ (16#1D713#, 16#03C8#),
+ (16#1D714#, 16#03C9#),
+ (16#1D715#, 16#2202#),
+ (16#1D716#, 16#03F5#),
+ (16#1D717#, 16#03D1#),
+ (16#1D718#, 16#03F0#),
+ (16#1D719#, 16#03D5#),
+ (16#1D71A#, 16#03F1#),
+ (16#1D71B#, 16#03D6#),
+ (16#1D71C#, 16#0391#),
+ (16#1D71D#, 16#0392#),
+ (16#1D71E#, 16#0393#),
+ (16#1D71F#, 16#0394#),
+ (16#1D720#, 16#0395#),
+ (16#1D721#, 16#0396#),
+ (16#1D722#, 16#0397#),
+ (16#1D723#, 16#0398#),
+ (16#1D724#, 16#0399#),
+ (16#1D725#, 16#039A#),
+ (16#1D726#, 16#039B#),
+ (16#1D727#, 16#039C#),
+ (16#1D728#, 16#039D#),
+ (16#1D729#, 16#039E#),
+ (16#1D72A#, 16#039F#),
+ (16#1D72B#, 16#03A0#),
+ (16#1D72C#, 16#03A1#),
+ (16#1D72D#, 16#03F4#),
+ (16#1D72E#, 16#03A3#),
+ (16#1D72F#, 16#03A4#),
+ (16#1D730#, 16#03A5#),
+ (16#1D731#, 16#03A6#),
+ (16#1D732#, 16#03A7#),
+ (16#1D733#, 16#03A8#),
+ (16#1D734#, 16#03A9#),
+ (16#1D735#, 16#2207#),
+ (16#1D736#, 16#03B1#),
+ (16#1D737#, 16#03B2#),
+ (16#1D738#, 16#03B3#),
+ (16#1D739#, 16#03B4#),
+ (16#1D73A#, 16#03B5#),
+ (16#1D73B#, 16#03B6#),
+ (16#1D73C#, 16#03B7#),
+ (16#1D73D#, 16#03B8#),
+ (16#1D73E#, 16#03B9#),
+ (16#1D73F#, 16#03BA#),
+ (16#1D740#, 16#03BB#),
+ (16#1D741#, 16#03BC#),
+ (16#1D742#, 16#03BD#),
+ (16#1D743#, 16#03BE#),
+ (16#1D744#, 16#03BF#),
+ (16#1D745#, 16#03C0#),
+ (16#1D746#, 16#03C1#),
+ (16#1D747#, 16#03C2#),
+ (16#1D748#, 16#03C3#),
+ (16#1D749#, 16#03C4#),
+ (16#1D74A#, 16#03C5#),
+ (16#1D74B#, 16#03C6#),
+ (16#1D74C#, 16#03C7#),
+ (16#1D74D#, 16#03C8#),
+ (16#1D74E#, 16#03C9#),
+ (16#1D74F#, 16#2202#),
+ (16#1D750#, 16#03F5#),
+ (16#1D751#, 16#03D1#),
+ (16#1D752#, 16#03F0#),
+ (16#1D753#, 16#03D5#),
+ (16#1D754#, 16#03F1#),
+ (16#1D755#, 16#03D6#),
+ (16#1D756#, 16#0391#),
+ (16#1D757#, 16#0392#),
+ (16#1D758#, 16#0393#),
+ (16#1D759#, 16#0394#),
+ (16#1D75A#, 16#0395#),
+ (16#1D75B#, 16#0396#),
+ (16#1D75C#, 16#0397#),
+ (16#1D75D#, 16#0398#),
+ (16#1D75E#, 16#0399#),
+ (16#1D75F#, 16#039A#),
+ (16#1D760#, 16#039B#),
+ (16#1D761#, 16#039C#),
+ (16#1D762#, 16#039D#),
+ (16#1D763#, 16#039E#),
+ (16#1D764#, 16#039F#),
+ (16#1D765#, 16#03A0#),
+ (16#1D766#, 16#03A1#),
+ (16#1D767#, 16#03F4#),
+ (16#1D768#, 16#03A3#),
+ (16#1D769#, 16#03A4#),
+ (16#1D76A#, 16#03A5#),
+ (16#1D76B#, 16#03A6#),
+ (16#1D76C#, 16#03A7#),
+ (16#1D76D#, 16#03A8#),
+ (16#1D76E#, 16#03A9#),
+ (16#1D76F#, 16#2207#),
+ (16#1D770#, 16#03B1#),
+ (16#1D771#, 16#03B2#),
+ (16#1D772#, 16#03B3#),
+ (16#1D773#, 16#03B4#),
+ (16#1D774#, 16#03B5#),
+ (16#1D775#, 16#03B6#),
+ (16#1D776#, 16#03B7#),
+ (16#1D777#, 16#03B8#),
+ (16#1D778#, 16#03B9#),
+ (16#1D779#, 16#03BA#),
+ (16#1D77A#, 16#03BB#),
+ (16#1D77B#, 16#03BC#),
+ (16#1D77C#, 16#03BD#),
+ (16#1D77D#, 16#03BE#),
+ (16#1D77E#, 16#03BF#),
+ (16#1D77F#, 16#03C0#),
+ (16#1D780#, 16#03C1#),
+ (16#1D781#, 16#03C2#),
+ (16#1D782#, 16#03C3#),
+ (16#1D783#, 16#03C4#),
+ (16#1D784#, 16#03C5#),
+ (16#1D785#, 16#03C6#),
+ (16#1D786#, 16#03C7#),
+ (16#1D787#, 16#03C8#),
+ (16#1D788#, 16#03C9#),
+ (16#1D789#, 16#2202#),
+ (16#1D78A#, 16#03F5#),
+ (16#1D78B#, 16#03D1#),
+ (16#1D78C#, 16#03F0#),
+ (16#1D78D#, 16#03D5#),
+ (16#1D78E#, 16#03F1#),
+ (16#1D78F#, 16#03D6#),
+ (16#1D790#, 16#0391#),
+ (16#1D791#, 16#0392#),
+ (16#1D792#, 16#0393#),
+ (16#1D793#, 16#0394#),
+ (16#1D794#, 16#0395#),
+ (16#1D795#, 16#0396#),
+ (16#1D796#, 16#0397#),
+ (16#1D797#, 16#0398#),
+ (16#1D798#, 16#0399#),
+ (16#1D799#, 16#039A#),
+ (16#1D79A#, 16#039B#),
+ (16#1D79B#, 16#039C#),
+ (16#1D79C#, 16#039D#),
+ (16#1D79D#, 16#039E#),
+ (16#1D79E#, 16#039F#),
+ (16#1D79F#, 16#03A0#),
+ (16#1D7A0#, 16#03A1#),
+ (16#1D7A1#, 16#03F4#),
+ (16#1D7A2#, 16#03A3#),
+ (16#1D7A3#, 16#03A4#),
+ (16#1D7A4#, 16#03A5#),
+ (16#1D7A5#, 16#03A6#),
+ (16#1D7A6#, 16#03A7#),
+ (16#1D7A7#, 16#03A8#),
+ (16#1D7A8#, 16#03A9#),
+ (16#1D7A9#, 16#2207#),
+ (16#1D7AA#, 16#03B1#),
+ (16#1D7AB#, 16#03B2#),
+ (16#1D7AC#, 16#03B3#),
+ (16#1D7AD#, 16#03B4#),
+ (16#1D7AE#, 16#03B5#),
+ (16#1D7AF#, 16#03B6#),
+ (16#1D7B0#, 16#03B7#),
+ (16#1D7B1#, 16#03B8#),
+ (16#1D7B2#, 16#03B9#),
+ (16#1D7B3#, 16#03BA#),
+ (16#1D7B4#, 16#03BB#),
+ (16#1D7B5#, 16#03BC#),
+ (16#1D7B6#, 16#03BD#),
+ (16#1D7B7#, 16#03BE#),
+ (16#1D7B8#, 16#03BF#),
+ (16#1D7B9#, 16#03C0#),
+ (16#1D7BA#, 16#03C1#),
+ (16#1D7BB#, 16#03C2#),
+ (16#1D7BC#, 16#03C3#),
+ (16#1D7BD#, 16#03C4#),
+ (16#1D7BE#, 16#03C5#),
+ (16#1D7BF#, 16#03C6#),
+ (16#1D7C0#, 16#03C7#),
+ (16#1D7C1#, 16#03C8#),
+ (16#1D7C2#, 16#03C9#),
+ (16#1D7C3#, 16#2202#),
+ (16#1D7C4#, 16#03F5#),
+ (16#1D7C5#, 16#03D1#),
+ (16#1D7C6#, 16#03F0#),
+ (16#1D7C7#, 16#03D5#),
+ (16#1D7C8#, 16#03F1#),
+ (16#1D7C9#, 16#03D6#),
+ (16#1D7CA#, 16#03DC#),
+ (16#1D7CB#, 16#03DD#),
+ (16#1D7CE#, 16#0030#),
+ (16#1D7CF#, 16#0031#),
+ (16#1D7D0#, 16#0032#),
+ (16#1D7D1#, 16#0033#),
+ (16#1D7D2#, 16#0034#),
+ (16#1D7D3#, 16#0035#),
+ (16#1D7D4#, 16#0036#),
+ (16#1D7D5#, 16#0037#),
+ (16#1D7D6#, 16#0038#),
+ (16#1D7D7#, 16#0039#),
+ (16#1D7D8#, 16#0030#),
+ (16#1D7D9#, 16#0031#),
+ (16#1D7DA#, 16#0032#),
+ (16#1D7DB#, 16#0033#),
+ (16#1D7DC#, 16#0034#),
+ (16#1D7DD#, 16#0035#),
+ (16#1D7DE#, 16#0036#),
+ (16#1D7DF#, 16#0037#),
+ (16#1D7E0#, 16#0038#),
+ (16#1D7E1#, 16#0039#),
+ (16#1D7E2#, 16#0030#),
+ (16#1D7E3#, 16#0031#),
+ (16#1D7E4#, 16#0032#),
+ (16#1D7E5#, 16#0033#),
+ (16#1D7E6#, 16#0034#),
+ (16#1D7E7#, 16#0035#),
+ (16#1D7E8#, 16#0036#),
+ (16#1D7E9#, 16#0037#),
+ (16#1D7EA#, 16#0038#),
+ (16#1D7EB#, 16#0039#),
+ (16#1D7EC#, 16#0030#),
+ (16#1D7ED#, 16#0031#),
+ (16#1D7EE#, 16#0032#),
+ (16#1D7EF#, 16#0033#),
+ (16#1D7F0#, 16#0034#),
+ (16#1D7F1#, 16#0035#),
+ (16#1D7F2#, 16#0036#),
+ (16#1D7F3#, 16#0037#),
+ (16#1D7F4#, 16#0038#),
+ (16#1D7F5#, 16#0039#),
+ (16#1D7F6#, 16#0030#),
+ (16#1D7F7#, 16#0031#),
+ (16#1D7F8#, 16#0032#),
+ (16#1D7F9#, 16#0033#),
+ (16#1D7FA#, 16#0034#),
+ (16#1D7FB#, 16#0035#),
+ (16#1D7FC#, 16#0036#),
+ (16#1D7FD#, 16#0037#),
+ (16#1D7FE#, 16#0038#),
+ (16#1D7FF#, 16#0039#),
+ (16#1EE00#, 16#0627#),
+ (16#1EE01#, 16#0628#),
+ (16#1EE02#, 16#062C#),
+ (16#1EE03#, 16#062F#),
+ (16#1EE05#, 16#0648#),
+ (16#1EE06#, 16#0632#),
+ (16#1EE07#, 16#062D#),
+ (16#1EE08#, 16#0637#),
+ (16#1EE09#, 16#064A#),
+ (16#1EE0A#, 16#0643#),
+ (16#1EE0B#, 16#0644#),
+ (16#1EE0C#, 16#0645#),
+ (16#1EE0D#, 16#0646#),
+ (16#1EE0E#, 16#0633#),
+ (16#1EE0F#, 16#0639#),
+ (16#1EE10#, 16#0641#),
+ (16#1EE11#, 16#0635#),
+ (16#1EE12#, 16#0642#),
+ (16#1EE13#, 16#0631#),
+ (16#1EE14#, 16#0634#),
+ (16#1EE15#, 16#062A#),
+ (16#1EE16#, 16#062B#),
+ (16#1EE17#, 16#062E#),
+ (16#1EE18#, 16#0630#),
+ (16#1EE19#, 16#0636#),
+ (16#1EE1A#, 16#0638#),
+ (16#1EE1B#, 16#063A#),
+ (16#1EE1C#, 16#066E#),
+ (16#1EE1D#, 16#06BA#),
+ (16#1EE1E#, 16#06A1#),
+ (16#1EE1F#, 16#066F#),
+ (16#1EE21#, 16#0628#),
+ (16#1EE22#, 16#062C#),
+ (16#1EE24#, 16#0647#),
+ (16#1EE27#, 16#062D#),
+ (16#1EE29#, 16#064A#),
+ (16#1EE2A#, 16#0643#),
+ (16#1EE2B#, 16#0644#),
+ (16#1EE2C#, 16#0645#),
+ (16#1EE2D#, 16#0646#),
+ (16#1EE2E#, 16#0633#),
+ (16#1EE2F#, 16#0639#),
+ (16#1EE30#, 16#0641#),
+ (16#1EE31#, 16#0635#),
+ (16#1EE32#, 16#0642#),
+ (16#1EE34#, 16#0634#),
+ (16#1EE35#, 16#062A#),
+ (16#1EE36#, 16#062B#),
+ (16#1EE37#, 16#062E#),
+ (16#1EE39#, 16#0636#),
+ (16#1EE3B#, 16#063A#),
+ (16#1EE42#, 16#062C#),
+ (16#1EE47#, 16#062D#),
+ (16#1EE49#, 16#064A#),
+ (16#1EE4B#, 16#0644#),
+ (16#1EE4D#, 16#0646#),
+ (16#1EE4E#, 16#0633#),
+ (16#1EE4F#, 16#0639#),
+ (16#1EE51#, 16#0635#),
+ (16#1EE52#, 16#0642#),
+ (16#1EE54#, 16#0634#),
+ (16#1EE57#, 16#062E#),
+ (16#1EE59#, 16#0636#),
+ (16#1EE5B#, 16#063A#),
+ (16#1EE5D#, 16#06BA#),
+ (16#1EE5F#, 16#066F#),
+ (16#1EE61#, 16#0628#),
+ (16#1EE62#, 16#062C#),
+ (16#1EE64#, 16#0647#),
+ (16#1EE67#, 16#062D#),
+ (16#1EE68#, 16#0637#),
+ (16#1EE69#, 16#064A#),
+ (16#1EE6A#, 16#0643#),
+ (16#1EE6C#, 16#0645#),
+ (16#1EE6D#, 16#0646#),
+ (16#1EE6E#, 16#0633#),
+ (16#1EE6F#, 16#0639#),
+ (16#1EE70#, 16#0641#),
+ (16#1EE71#, 16#0635#),
+ (16#1EE72#, 16#0642#),
+ (16#1EE74#, 16#0634#),
+ (16#1EE75#, 16#062A#),
+ (16#1EE76#, 16#062B#),
+ (16#1EE77#, 16#062E#),
+ (16#1EE79#, 16#0636#),
+ (16#1EE7A#, 16#0638#),
+ (16#1EE7B#, 16#063A#),
+ (16#1EE7C#, 16#066E#),
+ (16#1EE7E#, 16#06A1#),
+ (16#1EE80#, 16#0627#),
+ (16#1EE81#, 16#0628#),
+ (16#1EE82#, 16#062C#),
+ (16#1EE83#, 16#062F#),
+ (16#1EE84#, 16#0647#),
+ (16#1EE85#, 16#0648#),
+ (16#1EE86#, 16#0632#),
+ (16#1EE87#, 16#062D#),
+ (16#1EE88#, 16#0637#),
+ (16#1EE89#, 16#064A#),
+ (16#1EE8B#, 16#0644#),
+ (16#1EE8C#, 16#0645#),
+ (16#1EE8D#, 16#0646#),
+ (16#1EE8E#, 16#0633#),
+ (16#1EE8F#, 16#0639#),
+ (16#1EE90#, 16#0641#),
+ (16#1EE91#, 16#0635#),
+ (16#1EE92#, 16#0642#),
+ (16#1EE93#, 16#0631#),
+ (16#1EE94#, 16#0634#),
+ (16#1EE95#, 16#062A#),
+ (16#1EE96#, 16#062B#),
+ (16#1EE97#, 16#062E#),
+ (16#1EE98#, 16#0630#),
+ (16#1EE99#, 16#0636#),
+ (16#1EE9A#, 16#0638#),
+ (16#1EE9B#, 16#063A#),
+ (16#1EEA1#, 16#0628#),
+ (16#1EEA2#, 16#062C#),
+ (16#1EEA3#, 16#062F#),
+ (16#1EEA5#, 16#0648#),
+ (16#1EEA6#, 16#0632#),
+ (16#1EEA7#, 16#062D#),
+ (16#1EEA8#, 16#0637#),
+ (16#1EEA9#, 16#064A#),
+ (16#1EEAB#, 16#0644#),
+ (16#1EEAC#, 16#0645#),
+ (16#1EEAD#, 16#0646#),
+ (16#1EEAE#, 16#0633#),
+ (16#1EEAF#, 16#0639#),
+ (16#1EEB0#, 16#0641#),
+ (16#1EEB1#, 16#0635#),
+ (16#1EEB2#, 16#0642#),
+ (16#1EEB3#, 16#0631#),
+ (16#1EEB4#, 16#0634#),
+ (16#1EEB5#, 16#062A#),
+ (16#1EEB6#, 16#062B#),
+ (16#1EEB7#, 16#062E#),
+ (16#1EEB8#, 16#0630#),
+ (16#1EEB9#, 16#0636#),
+ (16#1EEBA#, 16#0638#),
+ (16#1EEBB#, 16#063A#),
+ (16#1F100#, 16#0030#),
+ (16#1F101#, 16#0030#),
+ (16#1F102#, 16#0031#),
+ (16#1F103#, 16#0032#),
+ (16#1F104#, 16#0033#),
+ (16#1F105#, 16#0034#),
+ (16#1F106#, 16#0035#),
+ (16#1F107#, 16#0036#),
+ (16#1F108#, 16#0037#),
+ (16#1F109#, 16#0038#),
+ (16#1F10A#, 16#0039#),
+ (16#1F110#, 16#0028#),
+ (16#1F111#, 16#0028#),
+ (16#1F112#, 16#0028#),
+ (16#1F113#, 16#0028#),
+ (16#1F114#, 16#0028#),
+ (16#1F115#, 16#0028#),
+ (16#1F116#, 16#0028#),
+ (16#1F117#, 16#0028#),
+ (16#1F118#, 16#0028#),
+ (16#1F119#, 16#0028#),
+ (16#1F11A#, 16#0028#),
+ (16#1F11B#, 16#0028#),
+ (16#1F11C#, 16#0028#),
+ (16#1F11D#, 16#0028#),
+ (16#1F11E#, 16#0028#),
+ (16#1F11F#, 16#0028#),
+ (16#1F120#, 16#0028#),
+ (16#1F121#, 16#0028#),
+ (16#1F122#, 16#0028#),
+ (16#1F123#, 16#0028#),
+ (16#1F124#, 16#0028#),
+ (16#1F125#, 16#0028#),
+ (16#1F126#, 16#0028#),
+ (16#1F127#, 16#0028#),
+ (16#1F128#, 16#0028#),
+ (16#1F129#, 16#0028#),
+ (16#1F12A#, 16#3014#),
+ (16#1F12B#, 16#0043#),
+ (16#1F12C#, 16#0052#),
+ (16#1F12D#, 16#0043#),
+ (16#1F12E#, 16#0057#),
+ (16#1F130#, 16#0041#),
+ (16#1F131#, 16#0042#),
+ (16#1F132#, 16#0043#),
+ (16#1F133#, 16#0044#),
+ (16#1F134#, 16#0045#),
+ (16#1F135#, 16#0046#),
+ (16#1F136#, 16#0047#),
+ (16#1F137#, 16#0048#),
+ (16#1F138#, 16#0049#),
+ (16#1F139#, 16#004A#),
+ (16#1F13A#, 16#004B#),
+ (16#1F13B#, 16#004C#),
+ (16#1F13C#, 16#004D#),
+ (16#1F13D#, 16#004E#),
+ (16#1F13E#, 16#004F#),
+ (16#1F13F#, 16#0050#),
+ (16#1F140#, 16#0051#),
+ (16#1F141#, 16#0052#),
+ (16#1F142#, 16#0053#),
+ (16#1F143#, 16#0054#),
+ (16#1F144#, 16#0055#),
+ (16#1F145#, 16#0056#),
+ (16#1F146#, 16#0057#),
+ (16#1F147#, 16#0058#),
+ (16#1F148#, 16#0059#),
+ (16#1F149#, 16#005A#),
+ (16#1F14A#, 16#0048#),
+ (16#1F14B#, 16#004D#),
+ (16#1F14C#, 16#0053#),
+ (16#1F14D#, 16#0053#),
+ (16#1F14E#, 16#0050#),
+ (16#1F14F#, 16#0057#),
+ (16#1F16A#, 16#004D#),
+ (16#1F16B#, 16#004D#),
+ (16#1F16C#, 16#004D#),
+ (16#1F190#, 16#0044#),
+ (16#1F200#, 16#307B#),
+ (16#1F201#, 16#30B3#),
+ (16#1F202#, 16#30B5#),
+ (16#1F210#, 16#624B#),
+ (16#1F211#, 16#5B57#),
+ (16#1F212#, 16#53CC#),
+ (16#1F213#, 16#30C7#),
+ (16#1F214#, 16#4E8C#),
+ (16#1F215#, 16#591A#),
+ (16#1F216#, 16#89E3#),
+ (16#1F217#, 16#5929#),
+ (16#1F218#, 16#4EA4#),
+ (16#1F219#, 16#6620#),
+ (16#1F21A#, 16#7121#),
+ (16#1F21B#, 16#6599#),
+ (16#1F21C#, 16#524D#),
+ (16#1F21D#, 16#5F8C#),
+ (16#1F21E#, 16#518D#),
+ (16#1F21F#, 16#65B0#),
+ (16#1F220#, 16#521D#),
+ (16#1F221#, 16#7D42#),
+ (16#1F222#, 16#751F#),
+ (16#1F223#, 16#8CA9#),
+ (16#1F224#, 16#58F0#),
+ (16#1F225#, 16#5439#),
+ (16#1F226#, 16#6F14#),
+ (16#1F227#, 16#6295#),
+ (16#1F228#, 16#6355#),
+ (16#1F229#, 16#4E00#),
+ (16#1F22A#, 16#4E09#),
+ (16#1F22B#, 16#904A#),
+ (16#1F22C#, 16#5DE6#),
+ (16#1F22D#, 16#4E2D#),
+ (16#1F22E#, 16#53F3#),
+ (16#1F22F#, 16#6307#),
+ (16#1F230#, 16#8D70#),
+ (16#1F231#, 16#6253#),
+ (16#1F232#, 16#7981#),
+ (16#1F233#, 16#7A7A#),
+ (16#1F234#, 16#5408#),
+ (16#1F235#, 16#6E80#),
+ (16#1F236#, 16#6709#),
+ (16#1F237#, 16#6708#),
+ (16#1F238#, 16#7533#),
+ (16#1F239#, 16#5272#),
+ (16#1F23A#, 16#55B6#),
+ (16#1F23B#, 16#914D#),
+ (16#1F240#, 16#3014#),
+ (16#1F241#, 16#3014#),
+ (16#1F242#, 16#3014#),
+ (16#1F243#, 16#3014#),
+ (16#1F244#, 16#3014#),
+ (16#1F245#, 16#3014#),
+ (16#1F246#, 16#3014#),
+ (16#1F247#, 16#3014#),
+ (16#1F248#, 16#3014#),
+ (16#1F250#, 16#5F97#),
+ (16#1F251#, 16#53EF#),
+ (16#1FBF0#, 16#0030#),
+ (16#1FBF1#, 16#0031#),
+ (16#1FBF2#, 16#0032#),
+ (16#1FBF3#, 16#0033#),
+ (16#1FBF4#, 16#0034#),
+ (16#1FBF5#, 16#0035#),
+ (16#1FBF6#, 16#0036#),
+ (16#1FBF7#, 16#0037#),
+ (16#1FBF8#, 16#0038#),
+ (16#1FBF9#, 16#0039#),
+ (16#2F800#, 16#4E3D#),
+ (16#2F801#, 16#4E38#),
+ (16#2F802#, 16#4E41#),
+ (16#2F803#, 16#20122#),
+ (16#2F804#, 16#4F60#),
+ (16#2F805#, 16#4FAE#),
+ (16#2F806#, 16#4FBB#),
+ (16#2F807#, 16#5002#),
+ (16#2F808#, 16#507A#),
+ (16#2F809#, 16#5099#),
+ (16#2F80A#, 16#50E7#),
+ (16#2F80B#, 16#50CF#),
+ (16#2F80C#, 16#349E#),
+ (16#2F80D#, 16#2063A#),
+ (16#2F80E#, 16#514D#),
+ (16#2F80F#, 16#5154#),
+ (16#2F810#, 16#5164#),
+ (16#2F811#, 16#5177#),
+ (16#2F812#, 16#2051C#),
+ (16#2F813#, 16#34B9#),
+ (16#2F814#, 16#5167#),
+ (16#2F815#, 16#518D#),
+ (16#2F816#, 16#2054B#),
+ (16#2F817#, 16#5197#),
+ (16#2F818#, 16#51A4#),
+ (16#2F819#, 16#4ECC#),
+ (16#2F81A#, 16#51AC#),
+ (16#2F81B#, 16#51B5#),
+ (16#2F81C#, 16#291DF#),
+ (16#2F81D#, 16#51F5#),
+ (16#2F81E#, 16#5203#),
+ (16#2F81F#, 16#34DF#),
+ (16#2F820#, 16#523B#),
+ (16#2F821#, 16#5246#),
+ (16#2F822#, 16#5272#),
+ (16#2F823#, 16#5277#),
+ (16#2F824#, 16#3515#),
+ (16#2F825#, 16#52C7#),
+ (16#2F826#, 16#52C9#),
+ (16#2F827#, 16#52E4#),
+ (16#2F828#, 16#52FA#),
+ (16#2F829#, 16#5305#),
+ (16#2F82A#, 16#5306#),
+ (16#2F82B#, 16#5317#),
+ (16#2F82C#, 16#5349#),
+ (16#2F82D#, 16#5351#),
+ (16#2F82E#, 16#535A#),
+ (16#2F82F#, 16#5373#),
+ (16#2F830#, 16#537D#),
+ (16#2F831#, 16#537F#),
+ (16#2F832#, 16#537F#),
+ (16#2F833#, 16#537F#),
+ (16#2F834#, 16#20A2C#),
+ (16#2F835#, 16#7070#),
+ (16#2F836#, 16#53CA#),
+ (16#2F837#, 16#53DF#),
+ (16#2F838#, 16#20B63#),
+ (16#2F839#, 16#53EB#),
+ (16#2F83A#, 16#53F1#),
+ (16#2F83B#, 16#5406#),
+ (16#2F83C#, 16#549E#),
+ (16#2F83D#, 16#5438#),
+ (16#2F83E#, 16#5448#),
+ (16#2F83F#, 16#5468#),
+ (16#2F840#, 16#54A2#),
+ (16#2F841#, 16#54F6#),
+ (16#2F842#, 16#5510#),
+ (16#2F843#, 16#5553#),
+ (16#2F844#, 16#5563#),
+ (16#2F845#, 16#5584#),
+ (16#2F846#, 16#5584#),
+ (16#2F847#, 16#5599#),
+ (16#2F848#, 16#55AB#),
+ (16#2F849#, 16#55B3#),
+ (16#2F84A#, 16#55C2#),
+ (16#2F84B#, 16#5716#),
+ (16#2F84C#, 16#5606#),
+ (16#2F84D#, 16#5717#),
+ (16#2F84E#, 16#5651#),
+ (16#2F84F#, 16#5674#),
+ (16#2F850#, 16#5207#),
+ (16#2F851#, 16#58EE#),
+ (16#2F852#, 16#57CE#),
+ (16#2F853#, 16#57F4#),
+ (16#2F854#, 16#580D#),
+ (16#2F855#, 16#578B#),
+ (16#2F856#, 16#5832#),
+ (16#2F857#, 16#5831#),
+ (16#2F858#, 16#58AC#),
+ (16#2F859#, 16#214E4#),
+ (16#2F85A#, 16#58F2#),
+ (16#2F85B#, 16#58F7#),
+ (16#2F85C#, 16#5906#),
+ (16#2F85D#, 16#591A#),
+ (16#2F85E#, 16#5922#),
+ (16#2F85F#, 16#5962#),
+ (16#2F860#, 16#216A8#),
+ (16#2F861#, 16#216EA#),
+ (16#2F862#, 16#59EC#),
+ (16#2F863#, 16#5A1B#),
+ (16#2F864#, 16#5A27#),
+ (16#2F865#, 16#59D8#),
+ (16#2F866#, 16#5A66#),
+ (16#2F867#, 16#36EE#),
+ (16#2F868#, 16#36FC#),
+ (16#2F869#, 16#5B08#),
+ (16#2F86A#, 16#5B3E#),
+ (16#2F86B#, 16#5B3E#),
+ (16#2F86C#, 16#219C8#),
+ (16#2F86D#, 16#5BC3#),
+ (16#2F86E#, 16#5BD8#),
+ (16#2F86F#, 16#5BE7#),
+ (16#2F870#, 16#5BF3#),
+ (16#2F871#, 16#21B18#),
+ (16#2F872#, 16#5BFF#),
+ (16#2F873#, 16#5C06#),
+ (16#2F874#, 16#5F53#),
+ (16#2F875#, 16#5C22#),
+ (16#2F876#, 16#3781#),
+ (16#2F877#, 16#5C60#),
+ (16#2F878#, 16#5C6E#),
+ (16#2F879#, 16#5CC0#),
+ (16#2F87A#, 16#5C8D#),
+ (16#2F87B#, 16#21DE4#),
+ (16#2F87C#, 16#5D43#),
+ (16#2F87D#, 16#21DE6#),
+ (16#2F87E#, 16#5D6E#),
+ (16#2F87F#, 16#5D6B#),
+ (16#2F880#, 16#5D7C#),
+ (16#2F881#, 16#5DE1#),
+ (16#2F882#, 16#5DE2#),
+ (16#2F883#, 16#382F#),
+ (16#2F884#, 16#5DFD#),
+ (16#2F885#, 16#5E28#),
+ (16#2F886#, 16#5E3D#),
+ (16#2F887#, 16#5E69#),
+ (16#2F888#, 16#3862#),
+ (16#2F889#, 16#22183#),
+ (16#2F88A#, 16#387C#),
+ (16#2F88B#, 16#5EB0#),
+ (16#2F88C#, 16#5EB3#),
+ (16#2F88D#, 16#5EB6#),
+ (16#2F88E#, 16#5ECA#),
+ (16#2F88F#, 16#2A392#),
+ (16#2F890#, 16#5EFE#),
+ (16#2F891#, 16#22331#),
+ (16#2F892#, 16#22331#),
+ (16#2F893#, 16#8201#),
+ (16#2F894#, 16#5F22#),
+ (16#2F895#, 16#5F22#),
+ (16#2F896#, 16#38C7#),
+ (16#2F897#, 16#232B8#),
+ (16#2F898#, 16#261DA#),
+ (16#2F899#, 16#5F62#),
+ (16#2F89A#, 16#5F6B#),
+ (16#2F89B#, 16#38E3#),
+ (16#2F89C#, 16#5F9A#),
+ (16#2F89D#, 16#5FCD#),
+ (16#2F89E#, 16#5FD7#),
+ (16#2F89F#, 16#5FF9#),
+ (16#2F8A0#, 16#6081#),
+ (16#2F8A1#, 16#393A#),
+ (16#2F8A2#, 16#391C#),
+ (16#2F8A3#, 16#6094#),
+ (16#2F8A4#, 16#226D4#),
+ (16#2F8A5#, 16#60C7#),
+ (16#2F8A6#, 16#6148#),
+ (16#2F8A7#, 16#614C#),
+ (16#2F8A8#, 16#614E#),
+ (16#2F8A9#, 16#614C#),
+ (16#2F8AA#, 16#617A#),
+ (16#2F8AB#, 16#618E#),
+ (16#2F8AC#, 16#61B2#),
+ (16#2F8AD#, 16#61A4#),
+ (16#2F8AE#, 16#61AF#),
+ (16#2F8AF#, 16#61DE#),
+ (16#2F8B0#, 16#61F2#),
+ (16#2F8B1#, 16#61F6#),
+ (16#2F8B2#, 16#6210#),
+ (16#2F8B3#, 16#621B#),
+ (16#2F8B4#, 16#625D#),
+ (16#2F8B5#, 16#62B1#),
+ (16#2F8B6#, 16#62D4#),
+ (16#2F8B7#, 16#6350#),
+ (16#2F8B8#, 16#22B0C#),
+ (16#2F8B9#, 16#633D#),
+ (16#2F8BA#, 16#62FC#),
+ (16#2F8BB#, 16#6368#),
+ (16#2F8BC#, 16#6383#),
+ (16#2F8BD#, 16#63E4#),
+ (16#2F8BE#, 16#22BF1#),
+ (16#2F8BF#, 16#6422#),
+ (16#2F8C0#, 16#63C5#),
+ (16#2F8C1#, 16#63A9#),
+ (16#2F8C2#, 16#3A2E#),
+ (16#2F8C3#, 16#6469#),
+ (16#2F8C4#, 16#647E#),
+ (16#2F8C5#, 16#649D#),
+ (16#2F8C6#, 16#6477#),
+ (16#2F8C7#, 16#3A6C#),
+ (16#2F8C8#, 16#654F#),
+ (16#2F8C9#, 16#656C#),
+ (16#2F8CA#, 16#2300A#),
+ (16#2F8CB#, 16#65E3#),
+ (16#2F8CC#, 16#66F8#),
+ (16#2F8CD#, 16#6649#),
+ (16#2F8CE#, 16#3B19#),
+ (16#2F8CF#, 16#6691#),
+ (16#2F8D0#, 16#3B08#),
+ (16#2F8D1#, 16#3AE4#),
+ (16#2F8D2#, 16#5192#),
+ (16#2F8D3#, 16#5195#),
+ (16#2F8D4#, 16#6700#),
+ (16#2F8D5#, 16#669C#),
+ (16#2F8D6#, 16#80AD#),
+ (16#2F8D7#, 16#43D9#),
+ (16#2F8D8#, 16#6717#),
+ (16#2F8D9#, 16#671B#),
+ (16#2F8DA#, 16#6721#),
+ (16#2F8DB#, 16#675E#),
+ (16#2F8DC#, 16#6753#),
+ (16#2F8DD#, 16#233C3#),
+ (16#2F8DE#, 16#3B49#),
+ (16#2F8DF#, 16#67FA#),
+ (16#2F8E0#, 16#6785#),
+ (16#2F8E1#, 16#6852#),
+ (16#2F8E2#, 16#6885#),
+ (16#2F8E3#, 16#2346D#),
+ (16#2F8E4#, 16#688E#),
+ (16#2F8E5#, 16#681F#),
+ (16#2F8E6#, 16#6914#),
+ (16#2F8E7#, 16#3B9D#),
+ (16#2F8E8#, 16#6942#),
+ (16#2F8E9#, 16#69A3#),
+ (16#2F8EA#, 16#69EA#),
+ (16#2F8EB#, 16#6AA8#),
+ (16#2F8EC#, 16#236A3#),
+ (16#2F8ED#, 16#6ADB#),
+ (16#2F8EE#, 16#3C18#),
+ (16#2F8EF#, 16#6B21#),
+ (16#2F8F0#, 16#238A7#),
+ (16#2F8F1#, 16#6B54#),
+ (16#2F8F2#, 16#3C4E#),
+ (16#2F8F3#, 16#6B72#),
+ (16#2F8F4#, 16#6B9F#),
+ (16#2F8F5#, 16#6BBA#),
+ (16#2F8F6#, 16#6BBB#),
+ (16#2F8F7#, 16#23A8D#),
+ (16#2F8F8#, 16#21D0B#),
+ (16#2F8F9#, 16#23AFA#),
+ (16#2F8FA#, 16#6C4E#),
+ (16#2F8FB#, 16#23CBC#),
+ (16#2F8FC#, 16#6CBF#),
+ (16#2F8FD#, 16#6CCD#),
+ (16#2F8FE#, 16#6C67#),
+ (16#2F8FF#, 16#6D16#),
+ (16#2F900#, 16#6D3E#),
+ (16#2F901#, 16#6D77#),
+ (16#2F902#, 16#6D41#),
+ (16#2F903#, 16#6D69#),
+ (16#2F904#, 16#6D78#),
+ (16#2F905#, 16#6D85#),
+ (16#2F906#, 16#23D1E#),
+ (16#2F907#, 16#6D34#),
+ (16#2F908#, 16#6E2F#),
+ (16#2F909#, 16#6E6E#),
+ (16#2F90A#, 16#3D33#),
+ (16#2F90B#, 16#6ECB#),
+ (16#2F90C#, 16#6EC7#),
+ (16#2F90D#, 16#23ED1#),
+ (16#2F90E#, 16#6DF9#),
+ (16#2F90F#, 16#6F6E#),
+ (16#2F910#, 16#23F5E#),
+ (16#2F911#, 16#23F8E#),
+ (16#2F912#, 16#6FC6#),
+ (16#2F913#, 16#7039#),
+ (16#2F914#, 16#701E#),
+ (16#2F915#, 16#701B#),
+ (16#2F916#, 16#3D96#),
+ (16#2F917#, 16#704A#),
+ (16#2F918#, 16#707D#),
+ (16#2F919#, 16#7077#),
+ (16#2F91A#, 16#70AD#),
+ (16#2F91B#, 16#20525#),
+ (16#2F91C#, 16#7145#),
+ (16#2F91D#, 16#24263#),
+ (16#2F91E#, 16#719C#),
+ (16#2F91F#, 16#243AB#),
+ (16#2F920#, 16#7228#),
+ (16#2F921#, 16#7235#),
+ (16#2F922#, 16#7250#),
+ (16#2F923#, 16#24608#),
+ (16#2F924#, 16#7280#),
+ (16#2F925#, 16#7295#),
+ (16#2F926#, 16#24735#),
+ (16#2F927#, 16#24814#),
+ (16#2F928#, 16#737A#),
+ (16#2F929#, 16#738B#),
+ (16#2F92A#, 16#3EAC#),
+ (16#2F92B#, 16#73A5#),
+ (16#2F92C#, 16#3EB8#),
+ (16#2F92D#, 16#3EB8#),
+ (16#2F92E#, 16#7447#),
+ (16#2F92F#, 16#745C#),
+ (16#2F930#, 16#7471#),
+ (16#2F931#, 16#7485#),
+ (16#2F932#, 16#74CA#),
+ (16#2F933#, 16#3F1B#),
+ (16#2F934#, 16#7524#),
+ (16#2F935#, 16#24C36#),
+ (16#2F936#, 16#753E#),
+ (16#2F937#, 16#24C92#),
+ (16#2F938#, 16#7570#),
+ (16#2F939#, 16#2219F#),
+ (16#2F93A#, 16#7610#),
+ (16#2F93B#, 16#24FA1#),
+ (16#2F93C#, 16#24FB8#),
+ (16#2F93D#, 16#25044#),
+ (16#2F93E#, 16#3FFC#),
+ (16#2F93F#, 16#4008#),
+ (16#2F940#, 16#76F4#),
+ (16#2F941#, 16#250F3#),
+ (16#2F942#, 16#250F2#),
+ (16#2F943#, 16#25119#),
+ (16#2F944#, 16#25133#),
+ (16#2F945#, 16#771E#),
+ (16#2F946#, 16#771F#),
+ (16#2F947#, 16#771F#),
+ (16#2F948#, 16#774A#),
+ (16#2F949#, 16#4039#),
+ (16#2F94A#, 16#778B#),
+ (16#2F94B#, 16#4046#),
+ (16#2F94C#, 16#4096#),
+ (16#2F94D#, 16#2541D#),
+ (16#2F94E#, 16#784E#),
+ (16#2F94F#, 16#788C#),
+ (16#2F950#, 16#78CC#),
+ (16#2F951#, 16#40E3#),
+ (16#2F952#, 16#25626#),
+ (16#2F953#, 16#7956#),
+ (16#2F954#, 16#2569A#),
+ (16#2F955#, 16#256C5#),
+ (16#2F956#, 16#798F#),
+ (16#2F957#, 16#79EB#),
+ (16#2F958#, 16#412F#),
+ (16#2F959#, 16#7A40#),
+ (16#2F95A#, 16#7A4A#),
+ (16#2F95B#, 16#7A4F#),
+ (16#2F95C#, 16#2597C#),
+ (16#2F95D#, 16#25AA7#),
+ (16#2F95E#, 16#25AA7#),
+ (16#2F95F#, 16#7AEE#),
+ (16#2F960#, 16#4202#),
+ (16#2F961#, 16#25BAB#),
+ (16#2F962#, 16#7BC6#),
+ (16#2F963#, 16#7BC9#),
+ (16#2F964#, 16#4227#),
+ (16#2F965#, 16#25C80#),
+ (16#2F966#, 16#7CD2#),
+ (16#2F967#, 16#42A0#),
+ (16#2F968#, 16#7CE8#),
+ (16#2F969#, 16#7CE3#),
+ (16#2F96A#, 16#7D00#),
+ (16#2F96B#, 16#25F86#),
+ (16#2F96C#, 16#7D63#),
+ (16#2F96D#, 16#4301#),
+ (16#2F96E#, 16#7DC7#),
+ (16#2F96F#, 16#7E02#),
+ (16#2F970#, 16#7E45#),
+ (16#2F971#, 16#4334#),
+ (16#2F972#, 16#26228#),
+ (16#2F973#, 16#26247#),
+ (16#2F974#, 16#4359#),
+ (16#2F975#, 16#262D9#),
+ (16#2F976#, 16#7F7A#),
+ (16#2F977#, 16#2633E#),
+ (16#2F978#, 16#7F95#),
+ (16#2F979#, 16#7FFA#),
+ (16#2F97A#, 16#8005#),
+ (16#2F97B#, 16#264DA#),
+ (16#2F97C#, 16#26523#),
+ (16#2F97D#, 16#8060#),
+ (16#2F97E#, 16#265A8#),
+ (16#2F97F#, 16#8070#),
+ (16#2F980#, 16#2335F#),
+ (16#2F981#, 16#43D5#),
+ (16#2F982#, 16#80B2#),
+ (16#2F983#, 16#8103#),
+ (16#2F984#, 16#440B#),
+ (16#2F985#, 16#813E#),
+ (16#2F986#, 16#5AB5#),
+ (16#2F987#, 16#267A7#),
+ (16#2F988#, 16#267B5#),
+ (16#2F989#, 16#23393#),
+ (16#2F98A#, 16#2339C#),
+ (16#2F98B#, 16#8201#),
+ (16#2F98C#, 16#8204#),
+ (16#2F98D#, 16#8F9E#),
+ (16#2F98E#, 16#446B#),
+ (16#2F98F#, 16#8291#),
+ (16#2F990#, 16#828B#),
+ (16#2F991#, 16#829D#),
+ (16#2F992#, 16#52B3#),
+ (16#2F993#, 16#82B1#),
+ (16#2F994#, 16#82B3#),
+ (16#2F995#, 16#82BD#),
+ (16#2F996#, 16#82E6#),
+ (16#2F997#, 16#26B3C#),
+ (16#2F998#, 16#82E5#),
+ (16#2F999#, 16#831D#),
+ (16#2F99A#, 16#8363#),
+ (16#2F99B#, 16#83AD#),
+ (16#2F99C#, 16#8323#),
+ (16#2F99D#, 16#83BD#),
+ (16#2F99E#, 16#83E7#),
+ (16#2F99F#, 16#8457#),
+ (16#2F9A0#, 16#8353#),
+ (16#2F9A1#, 16#83CA#),
+ (16#2F9A2#, 16#83CC#),
+ (16#2F9A3#, 16#83DC#),
+ (16#2F9A4#, 16#26C36#),
+ (16#2F9A5#, 16#26D6B#),
+ (16#2F9A6#, 16#26CD5#),
+ (16#2F9A7#, 16#452B#),
+ (16#2F9A8#, 16#84F1#),
+ (16#2F9A9#, 16#84F3#),
+ (16#2F9AA#, 16#8516#),
+ (16#2F9AB#, 16#273CA#),
+ (16#2F9AC#, 16#8564#),
+ (16#2F9AD#, 16#26F2C#),
+ (16#2F9AE#, 16#455D#),
+ (16#2F9AF#, 16#4561#),
+ (16#2F9B0#, 16#26FB1#),
+ (16#2F9B1#, 16#270D2#),
+ (16#2F9B2#, 16#456B#),
+ (16#2F9B3#, 16#8650#),
+ (16#2F9B4#, 16#865C#),
+ (16#2F9B5#, 16#8667#),
+ (16#2F9B6#, 16#8669#),
+ (16#2F9B7#, 16#86A9#),
+ (16#2F9B8#, 16#8688#),
+ (16#2F9B9#, 16#870E#),
+ (16#2F9BA#, 16#86E2#),
+ (16#2F9BB#, 16#8779#),
+ (16#2F9BC#, 16#8728#),
+ (16#2F9BD#, 16#876B#),
+ (16#2F9BE#, 16#8786#),
+ (16#2F9BF#, 16#45D7#),
+ (16#2F9C0#, 16#87E1#),
+ (16#2F9C1#, 16#8801#),
+ (16#2F9C2#, 16#45F9#),
+ (16#2F9C3#, 16#8860#),
+ (16#2F9C4#, 16#8863#),
+ (16#2F9C5#, 16#27667#),
+ (16#2F9C6#, 16#88D7#),
+ (16#2F9C7#, 16#88DE#),
+ (16#2F9C8#, 16#4635#),
+ (16#2F9C9#, 16#88FA#),
+ (16#2F9CA#, 16#34BB#),
+ (16#2F9CB#, 16#278AE#),
+ (16#2F9CC#, 16#27966#),
+ (16#2F9CD#, 16#46BE#),
+ (16#2F9CE#, 16#46C7#),
+ (16#2F9CF#, 16#8AA0#),
+ (16#2F9D0#, 16#8AED#),
+ (16#2F9D1#, 16#8B8A#),
+ (16#2F9D2#, 16#8C55#),
+ (16#2F9D3#, 16#27CA8#),
+ (16#2F9D4#, 16#8CAB#),
+ (16#2F9D5#, 16#8CC1#),
+ (16#2F9D6#, 16#8D1B#),
+ (16#2F9D7#, 16#8D77#),
+ (16#2F9D8#, 16#27F2F#),
+ (16#2F9D9#, 16#20804#),
+ (16#2F9DA#, 16#8DCB#),
+ (16#2F9DB#, 16#8DBC#),
+ (16#2F9DC#, 16#8DF0#),
+ (16#2F9DD#, 16#208DE#),
+ (16#2F9DE#, 16#8ED4#),
+ (16#2F9DF#, 16#8F38#),
+ (16#2F9E0#, 16#285D2#),
+ (16#2F9E1#, 16#285ED#),
+ (16#2F9E2#, 16#9094#),
+ (16#2F9E3#, 16#90F1#),
+ (16#2F9E4#, 16#9111#),
+ (16#2F9E5#, 16#2872E#),
+ (16#2F9E6#, 16#911B#),
+ (16#2F9E7#, 16#9238#),
+ (16#2F9E8#, 16#92D7#),
+ (16#2F9E9#, 16#92D8#),
+ (16#2F9EA#, 16#927C#),
+ (16#2F9EB#, 16#93F9#),
+ (16#2F9EC#, 16#9415#),
+ (16#2F9ED#, 16#28BFA#),
+ (16#2F9EE#, 16#958B#),
+ (16#2F9EF#, 16#4995#),
+ (16#2F9F0#, 16#95B7#),
+ (16#2F9F1#, 16#28D77#),
+ (16#2F9F2#, 16#49E6#),
+ (16#2F9F3#, 16#96C3#),
+ (16#2F9F4#, 16#5DB2#),
+ (16#2F9F5#, 16#9723#),
+ (16#2F9F6#, 16#29145#),
+ (16#2F9F7#, 16#2921A#),
+ (16#2F9F8#, 16#4A6E#),
+ (16#2F9F9#, 16#4A76#),
+ (16#2F9FA#, 16#97E0#),
+ (16#2F9FB#, 16#2940A#),
+ (16#2F9FC#, 16#4AB2#),
+ (16#2F9FD#, 16#29496#),
+ (16#2F9FE#, 16#980B#),
+ (16#2F9FF#, 16#980B#),
+ (16#2FA00#, 16#9829#),
+ (16#2FA01#, 16#295B6#),
+ (16#2FA02#, 16#98E2#),
+ (16#2FA03#, 16#4B33#),
+ (16#2FA04#, 16#9929#),
+ (16#2FA05#, 16#99A7#),
+ (16#2FA06#, 16#99C2#),
+ (16#2FA07#, 16#99FE#),
+ (16#2FA08#, 16#4BCE#),
+ (16#2FA09#, 16#29B30#),
+ (16#2FA0A#, 16#9B12#),
+ (16#2FA0B#, 16#9C40#),
+ (16#2FA0C#, 16#9CFD#),
+ (16#2FA0D#, 16#4CCE#),
+ (16#2FA0E#, 16#4CED#),
+ (16#2FA0F#, 16#9D67#),
+ (16#2FA10#, 16#2A0CE#),
+ (16#2FA11#, 16#4CF8#),
+ (16#2FA12#, 16#2A105#),
+ (16#2FA13#, 16#2A20E#),
+ (16#2FA14#, 16#2A291#),
+ (16#2FA15#, 16#9EBB#),
+ (16#2FA16#, 16#4D56#),
+ (16#2FA17#, 16#9EF9#),
+ (16#2FA18#, 16#9EFE#),
+ (16#2FA19#, 16#9F05#),
+ (16#2FA1A#, 16#9F0F#),
+ (16#2FA1B#, 16#9F16#),
+ (16#2FA1C#, 16#9F3B#),
+ (16#2FA1D#, 16#2A600#));
+
-----------------------
-- Local Subprograms --
-----------------------
+ function Decomposition_Search
+ (U : UTF_32; R : Unicode_Decomposition_Array) return Natural;
+ -- Searches the given decomposition array and returns the index of the
+ -- matching character U if found, zero otherwise.
+
function Range_Search (U : UTF_32; R : UTF_32_Ranges) return Natural;
-- Searches the given ranges (which must be in ascending order by Lo value)
-- and returns the index of the matching range in R if U matches one of the
@@ -6247,6 +12395,15 @@ package body System.UTF_32 is
return Non_Graphic (C);
end Is_UTF_32_Non_Graphic;
+ --------------------
+ -- Is_UTF_32_NFKC --
+ --------------------
+
+ function Is_UTF_32_NFKC (U : UTF_32) return Boolean is
+ begin
+ return U < 160 or else Range_Search (U, UTF_32_NFKC_QC_No) = 0;
+ end Is_UTF_32_NFKC;
+
---------------------
-- Is_UTF_32_Other --
---------------------
@@ -6289,6 +12446,53 @@ package body System.UTF_32 is
return C = Zs;
end Is_UTF_32_Space;
+ ---------------------
+ -- Is_UTF_32_Basic --
+ ---------------------
+
+ function Is_UTF_32_Basic (U : UTF_32) return Boolean is
+ begin
+ return Decomposition_Search (U, Unicode_Decomposition) = 0;
+ end Is_UTF_32_Basic;
+
+ --------------------------
+ -- Decomposition_Search --
+ --------------------------
+
+ function Decomposition_Search
+ (U : UTF_32; R : Unicode_Decomposition_Array) return Natural
+ is
+ Lo : Integer;
+ Hi : Integer;
+ Mid : Integer;
+
+ begin
+ Lo := R'First;
+ Hi := R'Last;
+
+ loop
+ Mid := (Lo + Hi) / 2;
+
+ if U < R (Mid).Item then
+ Hi := Mid - 1;
+
+ if Hi < Lo then
+ return 0;
+ end if;
+
+ elsif R (Mid).Item < U then
+ Lo := Mid + 1;
+
+ if Hi < Lo then
+ return 0;
+ end if;
+
+ else
+ return Mid;
+ end if;
+ end loop;
+ end Decomposition_Search;
+
------------------
-- Range_Search --
------------------
@@ -6325,6 +12529,21 @@ package body System.UTF_32 is
end loop;
end Range_Search;
+ ---------------------
+ -- UTF_32_To_Basic --
+ ---------------------
+
+ function UTF_32_To_Basic (U : UTF_32) return UTF_32 is
+ Index : constant Integer :=
+ Decomposition_Search (U, Unicode_Decomposition);
+ begin
+ if Index = 0 then
+ return U;
+ else
+ return Unicode_Decomposition (Index).First_Char_Mapping;
+ end if;
+ end UTF_32_To_Basic;
+
--------------------------
-- UTF_32_To_Lower_Case --
--------------------------
diff --git a/gcc/ada/libgnat/s-utf_32.ads b/gcc/ada/libgnat/s-utf_32.ads
index 8e75e48..e3f0e00 100644
--- a/gcc/ada/libgnat/s-utf_32.ads
+++ b/gcc/ada/libgnat/s-utf_32.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -189,6 +189,17 @@ package System.UTF_32 is
-- letters to upper case using this routine. A corresponding routine to
-- fold to lower case is also provided.
+ function Is_UTF_32_NFKC (U : UTF_32) return Boolean;
+ pragma Inline (Is_UTF_32_NFKC);
+ -- Return True if U could be present in a string normalized to
+ -- Normalization Form KC (as defined by Clause 21 of ISO/IEC 10646:2017),
+ -- otherwise returns False.
+
+ function Is_UTF_32_Basic (U : UTF_32) return Boolean;
+ pragma Inline (Is_UTF_32_Basic);
+ -- Return True if U has no Decomposition Mapping in the code charts of
+ -- ISO/IEC 10646:2017.
+
function UTF_32_To_Lower_Case (U : UTF_32) return UTF_32;
pragma Inline (UTF_32_To_Lower_Case);
-- If U represents an upper case letter, returns the corresponding lower
@@ -209,4 +220,10 @@ package System.UTF_32 is
-- code is folded to this CAPITAL LETTER code. Otherwise the input code is
-- returned unchanged.
+ function UTF_32_To_Basic (U : UTF_32) return UTF_32;
+ pragma Inline (UTF_32_To_Basic);
+ -- Returns the UTF_32 character whose code point is given by the first
+ -- value of its Decomposition Mapping in the code charts of ISO/IEC
+ -- 10646:2017 if any; returns Item otherwise.
+
end System.UTF_32;
diff --git a/gcc/ada/libgnat/s-valboo.adb b/gcc/ada/libgnat/s-valboo.adb
index 65dd3a3..e31d2bf 100644
--- a/gcc/ada/libgnat/s-valboo.adb
+++ b/gcc/ada/libgnat/s-valboo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valboo.ads b/gcc/ada/libgnat/s-valboo.ads
index f900621..94b81f9 100644
--- a/gcc/ada/libgnat/s-valboo.ads
+++ b/gcc/ada/libgnat/s-valboo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valcha.adb b/gcc/ada/libgnat/s-valcha.adb
index 5011b4d..70deb33 100644
--- a/gcc/ada/libgnat/s-valcha.adb
+++ b/gcc/ada/libgnat/s-valcha.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valcha.ads b/gcc/ada/libgnat/s-valcha.ads
index b9d5373..a33c032 100644
--- a/gcc/ada/libgnat/s-valcha.ads
+++ b/gcc/ada/libgnat/s-valcha.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valdec.adb b/gcc/ada/libgnat/s-valdec.adb
index 22a3333..99fffaf 100644
--- a/gcc/ada/libgnat/s-valdec.adb
+++ b/gcc/ada/libgnat/s-valdec.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valdec.ads b/gcc/ada/libgnat/s-valdec.ads
index ec10490..05fab98 100644
--- a/gcc/ada/libgnat/s-valdec.ads
+++ b/gcc/ada/libgnat/s-valdec.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valenu.adb b/gcc/ada/libgnat/s-valenu.adb
index 4693462..daa9b43 100644
--- a/gcc/ada/libgnat/s-valenu.adb
+++ b/gcc/ada/libgnat/s-valenu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valenu.ads b/gcc/ada/libgnat/s-valenu.ads
index e2a3a15..97c197f 100644
--- a/gcc/ada/libgnat/s-valenu.ads
+++ b/gcc/ada/libgnat/s-valenu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valint.adb b/gcc/ada/libgnat/s-valint.adb
index 9d7d60d..c40d558 100644
--- a/gcc/ada/libgnat/s-valint.adb
+++ b/gcc/ada/libgnat/s-valint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valint.ads b/gcc/ada/libgnat/s-valint.ads
index d9f15ed..79571da 100644
--- a/gcc/ada/libgnat/s-valint.ads
+++ b/gcc/ada/libgnat/s-valint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-vallld.adb b/gcc/ada/libgnat/s-vallld.adb
index 45bb2c9..4efa969 100644
--- a/gcc/ada/libgnat/s-vallld.adb
+++ b/gcc/ada/libgnat/s-vallld.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-vallld.ads b/gcc/ada/libgnat/s-vallld.ads
index 17db078..652362d 100644
--- a/gcc/ada/libgnat/s-vallld.ads
+++ b/gcc/ada/libgnat/s-vallld.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-vallli.adb b/gcc/ada/libgnat/s-vallli.adb
index 37de032..43bb0a7 100644
--- a/gcc/ada/libgnat/s-vallli.adb
+++ b/gcc/ada/libgnat/s-vallli.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-vallli.ads b/gcc/ada/libgnat/s-vallli.ads
index ee75bdc..0a51bbe 100644
--- a/gcc/ada/libgnat/s-vallli.ads
+++ b/gcc/ada/libgnat/s-vallli.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valllu.adb b/gcc/ada/libgnat/s-valllu.adb
index a01764f..dca0aac 100644
--- a/gcc/ada/libgnat/s-valllu.adb
+++ b/gcc/ada/libgnat/s-valllu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valllu.ads b/gcc/ada/libgnat/s-valllu.ads
index ddb8414..51a31dd 100644
--- a/gcc/ada/libgnat/s-valllu.ads
+++ b/gcc/ada/libgnat/s-valllu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valrea.adb b/gcc/ada/libgnat/s-valrea.adb
index 424ccd0..1a47dc2 100644
--- a/gcc/ada/libgnat/s-valrea.adb
+++ b/gcc/ada/libgnat/s-valrea.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -92,8 +92,7 @@ package body System.Val_Real is
-- As_Digit --
--------------
- function As_Digit (C : Character) return Char_As_Digit
- is
+ function As_Digit (C : Character) return Char_As_Digit is
begin
case C is
when '0' .. '9' =>
@@ -133,7 +132,9 @@ package body System.Val_Real is
Trailing_Zeros : Natural := 0;
-- Number of trailing zeros at a given point.
+
begin
+ pragma Assert (Base in 2 .. 16);
-- If initial Scale is not 0 then it means that Precision_Limit was
-- reached during integral part scanning.
@@ -217,7 +218,6 @@ package body System.Val_Real is
end if;
end if;
end loop;
-
end Scan_Decimal_Digits;
--------------------------
@@ -268,6 +268,8 @@ package body System.Val_Real is
-- Precision limit has been reached so just update the exponent
Scale := Scale + 1;
else
+ pragma Assert (Base /= 0);
+
if Value > (Precision_Limit - Digit) / Base then
-- Updating Value will overflow so ignore this digit and any
-- following ones. Only update the scale
@@ -369,6 +371,10 @@ package body System.Val_Real is
-- First character can be either a decimal digit or a dot.
if Str (Index) in '0' .. '9' then
+ pragma Annotate
+ (CodePeer, Intentional,
+ "test always true", "defensive code below");
+
-- If this is a digit it can indicates either the float decimal
-- part or the base to use
Scan_Integral_Digits
diff --git a/gcc/ada/libgnat/s-valrea.ads b/gcc/ada/libgnat/s-valrea.ads
index b59f345..cb5374c 100644
--- a/gcc/ada/libgnat/s-valrea.ads
+++ b/gcc/ada/libgnat/s-valrea.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valuns.adb b/gcc/ada/libgnat/s-valuns.adb
index a9fbd58..9f9e81e 100644
--- a/gcc/ada/libgnat/s-valuns.adb
+++ b/gcc/ada/libgnat/s-valuns.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valuns.ads b/gcc/ada/libgnat/s-valuns.ads
index 7d261b1..b965ba5 100644
--- a/gcc/ada/libgnat/s-valuns.ads
+++ b/gcc/ada/libgnat/s-valuns.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valuti.adb b/gcc/ada/libgnat/s-valuti.adb
index 6c63282..29042f7 100644
--- a/gcc/ada/libgnat/s-valuti.adb
+++ b/gcc/ada/libgnat/s-valuti.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valuti.ads b/gcc/ada/libgnat/s-valuti.ads
index 4035a68..a453272 100644
--- a/gcc/ada/libgnat/s-valuti.ads
+++ b/gcc/ada/libgnat/s-valuti.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valwch.adb b/gcc/ada/libgnat/s-valwch.adb
index cf61bf9..791171a 100644
--- a/gcc/ada/libgnat/s-valwch.adb
+++ b/gcc/ada/libgnat/s-valwch.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valwch.ads b/gcc/ada/libgnat/s-valwch.ads
index 5179517..a98d048 100644
--- a/gcc/ada/libgnat/s-valwch.ads
+++ b/gcc/ada/libgnat/s-valwch.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-veboop.adb b/gcc/ada/libgnat/s-veboop.adb
index 1ce61c8..ed43ef2 100644
--- a/gcc/ada/libgnat/s-veboop.adb
+++ b/gcc/ada/libgnat/s-veboop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-veboop.ads b/gcc/ada/libgnat/s-veboop.ads
index 5c1fc0f..3570b65 100644
--- a/gcc/ada/libgnat/s-veboop.ads
+++ b/gcc/ada/libgnat/s-veboop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-vector.ads b/gcc/ada/libgnat/s-vector.ads
index 6942570..2fb1004 100644
--- a/gcc/ada/libgnat/s-vector.ads
+++ b/gcc/ada/libgnat/s-vector.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-vercon.adb b/gcc/ada/libgnat/s-vercon.adb
index 6d0289d..ab22726 100644
--- a/gcc/ada/libgnat/s-vercon.adb
+++ b/gcc/ada/libgnat/s-vercon.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-vercon.ads b/gcc/ada/libgnat/s-vercon.ads
index 58976d7..b3ea028 100644
--- a/gcc/ada/libgnat/s-vercon.ads
+++ b/gcc/ada/libgnat/s-vercon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-wchcnv.adb b/gcc/ada/libgnat/s-wchcnv.adb
index 7afbc20..4cc1ff9 100644
--- a/gcc/ada/libgnat/s-wchcnv.adb
+++ b/gcc/ada/libgnat/s-wchcnv.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-wchcnv.ads b/gcc/ada/libgnat/s-wchcnv.ads
index 385c344..a99eef8 100644
--- a/gcc/ada/libgnat/s-wchcnv.ads
+++ b/gcc/ada/libgnat/s-wchcnv.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-wchcon.adb b/gcc/ada/libgnat/s-wchcon.adb
index a13ee66..228aa45 100644
--- a/gcc/ada/libgnat/s-wchcon.adb
+++ b/gcc/ada/libgnat/s-wchcon.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2005-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-wchcon.ads b/gcc/ada/libgnat/s-wchcon.ads
index eb358c3..897ab4e 100644
--- a/gcc/ada/libgnat/s-wchcon.ads
+++ b/gcc/ada/libgnat/s-wchcon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-wchjis.adb b/gcc/ada/libgnat/s-wchjis.adb
index 0e92c18..977e3042 100644
--- a/gcc/ada/libgnat/s-wchjis.adb
+++ b/gcc/ada/libgnat/s-wchjis.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-wchjis.ads b/gcc/ada/libgnat/s-wchjis.ads
index 90445e4..ba904d8 100644
--- a/gcc/ada/libgnat/s-wchjis.ads
+++ b/gcc/ada/libgnat/s-wchjis.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-wchstw.adb b/gcc/ada/libgnat/s-wchstw.adb
index 85d99c0..9803b35 100644
--- a/gcc/ada/libgnat/s-wchstw.adb
+++ b/gcc/ada/libgnat/s-wchstw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-wchstw.ads b/gcc/ada/libgnat/s-wchstw.ads
index 8fb37c3..4ec34ce 100644
--- a/gcc/ada/libgnat/s-wchstw.ads
+++ b/gcc/ada/libgnat/s-wchstw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-wchwts.adb b/gcc/ada/libgnat/s-wchwts.adb
index 21fa657..9bb9979 100644
--- a/gcc/ada/libgnat/s-wchwts.adb
+++ b/gcc/ada/libgnat/s-wchwts.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-wchwts.ads b/gcc/ada/libgnat/s-wchwts.ads
index 083b9ef..2b6b8c1 100644
--- a/gcc/ada/libgnat/s-wchwts.ads
+++ b/gcc/ada/libgnat/s-wchwts.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widboo.adb b/gcc/ada/libgnat/s-widboo.adb
index bbef0e9..0c549f9 100644
--- a/gcc/ada/libgnat/s-widboo.adb
+++ b/gcc/ada/libgnat/s-widboo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widboo.ads b/gcc/ada/libgnat/s-widboo.ads
index 006301b..4bef902 100644
--- a/gcc/ada/libgnat/s-widboo.ads
+++ b/gcc/ada/libgnat/s-widboo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widcha.adb b/gcc/ada/libgnat/s-widcha.adb
index f801365..710e60b 100644
--- a/gcc/ada/libgnat/s-widcha.adb
+++ b/gcc/ada/libgnat/s-widcha.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widcha.ads b/gcc/ada/libgnat/s-widcha.ads
index 2eaa427..eda2451 100644
--- a/gcc/ada/libgnat/s-widcha.ads
+++ b/gcc/ada/libgnat/s-widcha.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widenu.adb b/gcc/ada/libgnat/s-widenu.adb
index 340affd..20b7596 100644
--- a/gcc/ada/libgnat/s-widenu.adb
+++ b/gcc/ada/libgnat/s-widenu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widenu.ads b/gcc/ada/libgnat/s-widenu.ads
index bc0f326..487485c 100644
--- a/gcc/ada/libgnat/s-widenu.ads
+++ b/gcc/ada/libgnat/s-widenu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widlli.adb b/gcc/ada/libgnat/s-widlli.adb
index 8b92889..ff62186e 100644
--- a/gcc/ada/libgnat/s-widlli.adb
+++ b/gcc/ada/libgnat/s-widlli.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widlli.ads b/gcc/ada/libgnat/s-widlli.ads
index b048af6..73e95bc 100644
--- a/gcc/ada/libgnat/s-widlli.ads
+++ b/gcc/ada/libgnat/s-widlli.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widllu.adb b/gcc/ada/libgnat/s-widllu.adb
index 294f407..49ac43f 100644
--- a/gcc/ada/libgnat/s-widllu.adb
+++ b/gcc/ada/libgnat/s-widllu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widllu.ads b/gcc/ada/libgnat/s-widllu.ads
index 29bfb6c..fad814c 100644
--- a/gcc/ada/libgnat/s-widllu.ads
+++ b/gcc/ada/libgnat/s-widllu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widwch.adb b/gcc/ada/libgnat/s-widwch.adb
index 56ff4eb..ed633d9 100644
--- a/gcc/ada/libgnat/s-widwch.adb
+++ b/gcc/ada/libgnat/s-widwch.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widwch.ads b/gcc/ada/libgnat/s-widwch.ads
index 91f8ee5..2ea340f 100644
--- a/gcc/ada/libgnat/s-widwch.ads
+++ b/gcc/ada/libgnat/s-widwch.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-win32.ads b/gcc/ada/libgnat/s-win32.ads
index 853cef0..0fcc6d6 100644
--- a/gcc/ada/libgnat/s-win32.ads
+++ b/gcc/ada/libgnat/s-win32.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-winext.ads b/gcc/ada/libgnat/s-winext.ads
index b29e1cd..3eff109 100644
--- a/gcc/ada/libgnat/s-winext.ads
+++ b/gcc/ada/libgnat/s-winext.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-wwdcha.adb b/gcc/ada/libgnat/s-wwdcha.adb
index 6b1f1a7..fde2280 100644
--- a/gcc/ada/libgnat/s-wwdcha.adb
+++ b/gcc/ada/libgnat/s-wwdcha.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-wwdcha.ads b/gcc/ada/libgnat/s-wwdcha.ads
index 9bfa43db..4d8668d 100644
--- a/gcc/ada/libgnat/s-wwdcha.ads
+++ b/gcc/ada/libgnat/s-wwdcha.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-wwdenu.adb b/gcc/ada/libgnat/s-wwdenu.adb
index 8a648d1..49c3101 100644
--- a/gcc/ada/libgnat/s-wwdenu.adb
+++ b/gcc/ada/libgnat/s-wwdenu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-wwdenu.ads b/gcc/ada/libgnat/s-wwdenu.ads
index bd8ce64..ecc6389 100644
--- a/gcc/ada/libgnat/s-wwdenu.ads
+++ b/gcc/ada/libgnat/s-wwdenu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-wwdwch.adb b/gcc/ada/libgnat/s-wwdwch.adb
index 4ad41d9..34f9133 100644
--- a/gcc/ada/libgnat/s-wwdwch.adb
+++ b/gcc/ada/libgnat/s-wwdwch.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-wwdwch.ads b/gcc/ada/libgnat/s-wwdwch.ads
index 83e3ce7..e2af399 100644
--- a/gcc/ada/libgnat/s-wwdwch.ads
+++ b/gcc/ada/libgnat/s-wwdwch.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/system-aix.ads b/gcc/ada/libgnat/system-aix.ads
index ecb9298..6ffa0f5 100644
--- a/gcc/ada/libgnat/system-aix.ads
+++ b/gcc/ada/libgnat/system-aix.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (AIX/PPC Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-darwin-arm.ads b/gcc/ada/libgnat/system-darwin-arm.ads
index 3d51980..4206b04 100644
--- a/gcc/ada/libgnat/system-darwin-arm.ads
+++ b/gcc/ada/libgnat/system-darwin-arm.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Darwin/ARM Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-darwin-ppc.ads b/gcc/ada/libgnat/system-darwin-ppc.ads
index 9adc2de..b543f63 100644
--- a/gcc/ada/libgnat/system-darwin-ppc.ads
+++ b/gcc/ada/libgnat/system-darwin-ppc.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Darwin/PPC Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-darwin-x86.ads b/gcc/ada/libgnat/system-darwin-x86.ads
index 4fac373..3ceacff 100644
--- a/gcc/ada/libgnat/system-darwin-x86.ads
+++ b/gcc/ada/libgnat/system-darwin-x86.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Darwin/x86 Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-djgpp.ads b/gcc/ada/libgnat/system-djgpp.ads
index e9ac14e..82b496e 100644
--- a/gcc/ada/libgnat/system-djgpp.ads
+++ b/gcc/ada/libgnat/system-djgpp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (DJGPP Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-dragonfly-x86_64.ads b/gcc/ada/libgnat/system-dragonfly-x86_64.ads
index ae5daf3..a77ebd6 100644
--- a/gcc/ada/libgnat/system-dragonfly-x86_64.ads
+++ b/gcc/ada/libgnat/system-dragonfly-x86_64.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (DragonFly BSD/x86_64 Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-freebsd.ads b/gcc/ada/libgnat/system-freebsd.ads
index 1587046..c2afb79 100644
--- a/gcc/ada/libgnat/system-freebsd.ads
+++ b/gcc/ada/libgnat/system-freebsd.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (FreeBSD Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-hpux-ia64.ads b/gcc/ada/libgnat/system-hpux-ia64.ads
index 0ea68ea..c0d5515 100644
--- a/gcc/ada/libgnat/system-hpux-ia64.ads
+++ b/gcc/ada/libgnat/system-hpux-ia64.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (HP-UX/ia64 Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-hpux.ads b/gcc/ada/libgnat/system-hpux.ads
index 0cfa8bf..7acd350 100644
--- a/gcc/ada/libgnat/system-hpux.ads
+++ b/gcc/ada/libgnat/system-hpux.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (HP-UX Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-linux-alpha.ads b/gcc/ada/libgnat/system-linux-alpha.ads
index 073e843..1d1411e 100644
--- a/gcc/ada/libgnat/system-linux-alpha.ads
+++ b/gcc/ada/libgnat/system-linux-alpha.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU-Linux/alpha Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-linux-arm.ads b/gcc/ada/libgnat/system-linux-arm.ads
index c41d5d4..e3ee506 100644
--- a/gcc/ada/libgnat/system-linux-arm.ads
+++ b/gcc/ada/libgnat/system-linux-arm.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU-Linux/ARM Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-linux-hppa.ads b/gcc/ada/libgnat/system-linux-hppa.ads
index af18b41..59aab83 100644
--- a/gcc/ada/libgnat/system-linux-hppa.ads
+++ b/gcc/ada/libgnat/system-linux-hppa.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU/Linux-HPPA Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-linux-ia64.ads b/gcc/ada/libgnat/system-linux-ia64.ads
index 847ea5c..bf36c77 100644
--- a/gcc/ada/libgnat/system-linux-ia64.ads
+++ b/gcc/ada/libgnat/system-linux-ia64.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU-Linux/ia64 Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-linux-m68k.ads b/gcc/ada/libgnat/system-linux-m68k.ads
index 12ea636..571c629 100644
--- a/gcc/ada/libgnat/system-linux-m68k.ads
+++ b/gcc/ada/libgnat/system-linux-m68k.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU/Linux/m68k Version) --
-- --
--- Copyright (C) 2014-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-linux-mips.ads b/gcc/ada/libgnat/system-linux-mips.ads
index aebfac8..c381496 100644
--- a/gcc/ada/libgnat/system-linux-mips.ads
+++ b/gcc/ada/libgnat/system-linux-mips.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU-Linux/MIPS Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-linux-ppc.ads b/gcc/ada/libgnat/system-linux-ppc.ads
index 5722f1e..f3d3712 100644
--- a/gcc/ada/libgnat/system-linux-ppc.ads
+++ b/gcc/ada/libgnat/system-linux-ppc.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU-Linux/PPC Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-linux-riscv.ads b/gcc/ada/libgnat/system-linux-riscv.ads
index 68de015..676394a 100644
--- a/gcc/ada/libgnat/system-linux-riscv.ads
+++ b/gcc/ada/libgnat/system-linux-riscv.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU-Linux/RISC-V Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-linux-s390.ads b/gcc/ada/libgnat/system-linux-s390.ads
index 3a41a1c..916f68d 100644
--- a/gcc/ada/libgnat/system-linux-s390.ads
+++ b/gcc/ada/libgnat/system-linux-s390.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU-Linux/s390 Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-linux-sh4.ads b/gcc/ada/libgnat/system-linux-sh4.ads
index dcdc04c..8940ab0 100644
--- a/gcc/ada/libgnat/system-linux-sh4.ads
+++ b/gcc/ada/libgnat/system-linux-sh4.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU-Linux/sh4 Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-linux-sparc.ads b/gcc/ada/libgnat/system-linux-sparc.ads
index d76b5db..5d93b76 100644
--- a/gcc/ada/libgnat/system-linux-sparc.ads
+++ b/gcc/ada/libgnat/system-linux-sparc.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU/Linux-SPARC Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-linux-x86.ads b/gcc/ada/libgnat/system-linux-x86.ads
index 82cc48f..7e30fee 100644
--- a/gcc/ada/libgnat/system-linux-x86.ads
+++ b/gcc/ada/libgnat/system-linux-x86.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU-Linux/x86 Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-lynxos178-ppc.ads b/gcc/ada/libgnat/system-lynxos178-ppc.ads
index b118fb7..8882034 100644
--- a/gcc/ada/libgnat/system-lynxos178-ppc.ads
+++ b/gcc/ada/libgnat/system-lynxos178-ppc.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (LynxOS-178 PPC Version) --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-lynxos178-x86.ads b/gcc/ada/libgnat/system-lynxos178-x86.ads
index e05746f..3a5f297 100644
--- a/gcc/ada/libgnat/system-lynxos178-x86.ads
+++ b/gcc/ada/libgnat/system-lynxos178-x86.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (LynxOS-178 X86 Version) --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-mingw.ads b/gcc/ada/libgnat/system-mingw.ads
index 42719e4..990c5f5 100644
--- a/gcc/ada/libgnat/system-mingw.ads
+++ b/gcc/ada/libgnat/system-mingw.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Windows Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -185,11 +185,6 @@ private
-- model, but maps them using compression onto the 7 priority levels
-- available in NT and on the 16 priority levels available in 2000/XP.
- -- To replace the default values of the Underlying_Priorities mapping,
- -- copy this source file into your build directory, edit the file to
- -- reflect your desired behavior, and recompile using Makefile.adalib
- -- which can be found under the adalib directory of your gnat installation
-
pragma Linker_Options ("-Wl,--stack=0x2000000");
-- This is used to change the default stack (32 MB) size for non tasking
-- programs. We change this value for GNAT on Windows here because the
diff --git a/gcc/ada/libgnat/system-qnx-aarch64.ads b/gcc/ada/libgnat/system-qnx-aarch64.ads
index 291211e..a04f7b2 100644
--- a/gcc/ada/libgnat/system-qnx-aarch64.ads
+++ b/gcc/ada/libgnat/system-qnx-aarch64.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (QNX/Aarch64 Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-rtems.ads b/gcc/ada/libgnat/system-rtems.ads
index a884ea9..50a96a3 100644
--- a/gcc/ada/libgnat/system-rtems.ads
+++ b/gcc/ada/libgnat/system-rtems.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Compiler Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-solaris-sparc.ads b/gcc/ada/libgnat/system-solaris-sparc.ads
index 16e3d23d..244042c 100644
--- a/gcc/ada/libgnat/system-solaris-sparc.ads
+++ b/gcc/ada/libgnat/system-solaris-sparc.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (SUN Solaris Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-solaris-x86.ads b/gcc/ada/libgnat/system-solaris-x86.ads
index 2200187..c77c916 100644
--- a/gcc/ada/libgnat/system-solaris-x86.ads
+++ b/gcc/ada/libgnat/system-solaris-x86.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (x86 Solaris Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads
index 5c51a9e..1186d8b 100644
--- a/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 6.x ARM RTP) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-arm-rtp.ads b/gcc/ada/libgnat/system-vxworks-arm-rtp.ads
index f5d6da1..ce52c07 100644
--- a/gcc/ada/libgnat/system-vxworks-arm-rtp.ads
+++ b/gcc/ada/libgnat/system-vxworks-arm-rtp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 6.x ARM RTP) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-arm.ads b/gcc/ada/libgnat/system-vxworks-arm.ads
index 34567c8..4dc6be8 100644
--- a/gcc/ada/libgnat/system-vxworks-arm.ads
+++ b/gcc/ada/libgnat/system-vxworks-arm.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks Version ARM) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-e500-kernel.ads b/gcc/ada/libgnat/system-vxworks-e500-kernel.ads
index c1a997b..44b713a 100644
--- a/gcc/ada/libgnat/system-vxworks-e500-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks-e500-kernel.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 6 Kernel Version E500) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads
index eb9880d..a3e8f41 100644
--- a/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 6.x SMP E500 RTP) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-e500-rtp.ads b/gcc/ada/libgnat/system-vxworks-e500-rtp.ads
index 9f53444..5a26eed 100644
--- a/gcc/ada/libgnat/system-vxworks-e500-rtp.ads
+++ b/gcc/ada/libgnat/system-vxworks-e500-rtp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 6.x E500 RTP) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-e500-vthread.ads b/gcc/ada/libgnat/system-vxworks-e500-vthread.ads
index 55e7b97..df96432 100644
--- a/gcc/ada/libgnat/system-vxworks-e500-vthread.ads
+++ b/gcc/ada/libgnat/system-vxworks-e500-vthread.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks e500 AE653 vThreads) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads b/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads
index c927fd1..76ec6eb 100644
--- a/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 6 Kernel Version PPC) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads b/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads
index 7a8b8fe..8485e74 100644
--- a/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads
+++ b/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks/HIE Ravenscar Version PPC) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads
index 8a5cf0e..17b7f2c 100644
--- a/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 6.x SMP PPC RTP) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads b/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads
index 6dcbd54..a57563d 100644
--- a/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads
+++ b/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 6.x PPC RTP) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads b/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads
index 6253f7c..9d2c379 100644
--- a/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads
+++ b/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks PPC AE653 vThreads) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-ppc.ads b/gcc/ada/libgnat/system-vxworks-ppc.ads
index 39f1eda..20b8674 100644
--- a/gcc/ada/libgnat/system-vxworks-ppc.ads
+++ b/gcc/ada/libgnat/system-vxworks-ppc.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 5 Version PPC) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-x86-kernel.ads b/gcc/ada/libgnat/system-vxworks-x86-kernel.ads
index 51db6ed..42d8769 100644
--- a/gcc/ada/libgnat/system-vxworks-x86-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks-x86-kernel.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 6 Kernel Version x86) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads
index 3ede658..8bed920 100644
--- a/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks Version x86 for SMP RTPs) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-x86-rtp.ads b/gcc/ada/libgnat/system-vxworks-x86-rtp.ads
index f07dcfa..fd20986 100644
--- a/gcc/ada/libgnat/system-vxworks-x86-rtp.ads
+++ b/gcc/ada/libgnat/system-vxworks-x86-rtp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks Version x86 for RTPs) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-x86-vthread.ads b/gcc/ada/libgnat/system-vxworks-x86-vthread.ads
index 7ef29eb..418e52b 100644
--- a/gcc/ada/libgnat/system-vxworks-x86-vthread.ads
+++ b/gcc/ada/libgnat/system-vxworks-x86-vthread.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 653 x86 vThreads) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks-x86.ads b/gcc/ada/libgnat/system-vxworks-x86.ads
index 1415752..6059202 100644
--- a/gcc/ada/libgnat/system-vxworks-x86.ads
+++ b/gcc/ada/libgnat/system-vxworks-x86.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 5 Version x86) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads
index 35a19e0..524f967 100644
--- a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 7.x AARCH64 RTP) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64.ads b/gcc/ada/libgnat/system-vxworks7-aarch64.ads
index 51004ff..f1e11ba 100644
--- a/gcc/ada/libgnat/system-vxworks7-aarch64.ads
+++ b/gcc/ada/libgnat/system-vxworks7-aarch64.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 7.x AARCH64 Kernel) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads
index 405334f..032620d 100644
--- a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 7 ARM RTP) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-arm.ads b/gcc/ada/libgnat/system-vxworks7-arm.ads
index 34567c8..4dc6be8 100644
--- a/gcc/ada/libgnat/system-vxworks7-arm.ads
+++ b/gcc/ada/libgnat/system-vxworks7-arm.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks Version ARM) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads b/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads
index af3243a..495cfed 100644
--- a/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 7 Kernel Version E500) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads
index c21a2f4..2633156 100644
--- a/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 7.x E500 RTP) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads b/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads
index e26e3c6..a521d25 100644
--- a/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 7.x E500 RTP) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads b/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads
index 6a188e0..a054aa2 100644
--- a/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 7 Kernel Version PPC) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads
index f3646b7..7e3e16db 100644
--- a/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 7.x PPC RTP) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads b/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads
index 95390ef..87ac8f0 100644
--- a/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 7.x PPC RTP) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads b/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads
index e1c5311..c631a85 100644
--- a/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 7.x PPC64 Kernel) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads
index 5a1670b..9f27913 100644
--- a/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 7.x PPC64 RTP) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads
index 85c166b..5bfe0b3 100644
--- a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 7 Kernel Version x86) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads
index f87cf90..5e66142 100644
--- a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 7 Version x86 for RTPs) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads b/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads
index 29031a4..47ca3e8 100644
--- a/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 7 Version x86 for RTPs) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads
index 8b2da4d..ac90238 100644
--- a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 7 Kernel Version x86_64) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads
index 0d18c68..c3e4a9c 100644
--- a/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks 7 Version x86_64 for RTPs) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/libgnat/system.ads b/gcc/ada/libgnat/system.ads
index aed4577..f54c43f 100644
--- a/gcc/ada/libgnat/system.ads
+++ b/gcc/ada/libgnat/system.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Compiler Version) --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
diff --git a/gcc/ada/link.c b/gcc/ada/link.c
index 02c413a..5cd5ef6 100644
--- a/gcc/ada/link.c
+++ b/gcc/ada/link.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/live.adb b/gcc/ada/live.adb
index 26592e7..bca9cf8 100644
--- a/gcc/ada/live.adb
+++ b/gcc/ada/live.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/live.ads b/gcc/ada/live.ads
index 27a7c1d..a11224b 100644
--- a/gcc/ada/live.ads
+++ b/gcc/ada/live.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/locales.c b/gcc/ada/locales.c
index 9372bdb..c083c8b 100644
--- a/gcc/ada/locales.c
+++ b/gcc/ada/locales.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2010-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2010-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb
index 377072c..0034d1a 100644
--- a/gcc/ada/make.adb
+++ b/gcc/ada/make.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -206,7 +206,7 @@ package body Make is
procedure Add_Library_Search_Dir (Path : String);
-- Call Add_Lib_Search_Dir with an absolute directory path. If Path is
- -- relative path,, it is relative to the current working directory.
+ -- relative path, it is relative to the current working directory.
procedure Add_Source_Search_Dir (Path : String);
-- Call Add_Src_Search_Dir with an absolute directory path. If Path is a
diff --git a/gcc/ada/make.ads b/gcc/ada/make.ads
index 24f15f5..d4e54cc 100644
--- a/gcc/ada/make.ads
+++ b/gcc/ada/make.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/make_util.adb b/gcc/ada/make_util.adb
index 16717ed..0ba957e 100644
--- a/gcc/ada/make_util.adb
+++ b/gcc/ada/make_util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/make_util.ads b/gcc/ada/make_util.ads
index 9bd576a..fab4c74 100644
--- a/gcc/ada/make_util.ads
+++ b/gcc/ada/make_util.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/makeusg.adb b/gcc/ada/makeusg.adb
index 69f634c9..4cc50b1 100644
--- a/gcc/ada/makeusg.adb
+++ b/gcc/ada/makeusg.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/makeusg.ads b/gcc/ada/makeusg.ads
index 135a504..4ac7147 100644
--- a/gcc/ada/makeusg.ads
+++ b/gcc/ada/makeusg.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/mdll-fil.adb b/gcc/ada/mdll-fil.adb
index f6ca8e3..ce51ff0 100644
--- a/gcc/ada/mdll-fil.adb
+++ b/gcc/ada/mdll-fil.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/mdll-fil.ads b/gcc/ada/mdll-fil.ads
index 1091030..5036b0c 100644
--- a/gcc/ada/mdll-fil.ads
+++ b/gcc/ada/mdll-fil.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/mdll-utl.adb b/gcc/ada/mdll-utl.adb
index a2cc77f..632b930 100644
--- a/gcc/ada/mdll-utl.adb
+++ b/gcc/ada/mdll-utl.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/mdll-utl.ads b/gcc/ada/mdll-utl.ads
index d370303..883500f 100644
--- a/gcc/ada/mdll-utl.ads
+++ b/gcc/ada/mdll-utl.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/mdll.adb b/gcc/ada/mdll.adb
index 096a8f0..3319e94 100644
--- a/gcc/ada/mdll.adb
+++ b/gcc/ada/mdll.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/mdll.ads b/gcc/ada/mdll.ads
index 5039e8a..755de4e 100644
--- a/gcc/ada/mdll.ads
+++ b/gcc/ada/mdll.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/mingw32.h b/gcc/ada/mingw32.h
index 3dbf797..c902d04 100644
--- a/gcc/ada/mingw32.h
+++ b/gcc/ada/mingw32.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2002-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2002-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/mkdir.c b/gcc/ada/mkdir.c
index e0efcce..a11b1e5 100644
--- a/gcc/ada/mkdir.c
+++ b/gcc/ada/mkdir.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2002-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2002-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/namet-sp.adb b/gcc/ada/namet-sp.adb
index 1859f6d..d3106bc 100644
--- a/gcc/ada/namet-sp.adb
+++ b/gcc/ada/namet-sp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/namet-sp.ads b/gcc/ada/namet-sp.ads
index ebe9bd7..f4a6fed 100644
--- a/gcc/ada/namet-sp.ads
+++ b/gcc/ada/namet-sp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb
index c5454d4..e39e0b9 100644
--- a/gcc/ada/namet.adb
+++ b/gcc/ada/namet.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,11 +33,9 @@
-- source file must be properly reflected in the C header file namet.h
-- which is created manually from namet.ads and namet.adb.
-with Debug; use Debug;
-with Opt; use Opt;
-with Output; use Output;
-with System; use System;
-with Tree_IO; use Tree_IO;
+with Debug; use Debug;
+with Opt; use Opt;
+with Output; use Output;
with Widechar;
with Interfaces; use Interfaces;
@@ -1181,11 +1179,13 @@ package body Namet is
Hash_Index : Hash_Index_Type;
-- Computed hash index
+ Result : Valid_Name_Id;
+
begin
-- Quick handling for one character names
if Buf.Length = 1 then
- return Valid_Name_Id (First_Name_Id + Character'Pos (Buf.Chars (1)));
+ Result := First_Name_Id + Character'Pos (Buf.Chars (1));
-- Otherwise search hash table for existing matching entry
@@ -1212,7 +1212,8 @@ package body Namet is
end if;
end loop;
- return New_Id;
+ Result := New_Id;
+ goto Done;
-- Current entry in hash chain does not match
@@ -1250,8 +1251,11 @@ package body Namet is
Name_Chars.Append (ASCII.NUL);
- return Name_Entries.Last;
+ Result := Name_Entries.Last;
end if;
+
+ <<Done>>
+ return Result;
end Name_Find;
function Name_Find (S : String) return Valid_Name_Id is
@@ -1261,230 +1265,6 @@ package body Namet is
return Name_Find (Buf);
end Name_Find;
- -------------
- -- Nam_In --
- -------------
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id) return Boolean
- is
- begin
- return T = V1 or else
- T = V2;
- end Nam_In;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3;
- end Nam_In;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4;
- end Nam_In;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id;
- V5 : Name_Id) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5;
- end Nam_In;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id;
- V5 : Name_Id;
- V6 : Name_Id) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6;
- end Nam_In;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id;
- V5 : Name_Id;
- V6 : Name_Id;
- V7 : Name_Id) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7;
- end Nam_In;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id;
- V5 : Name_Id;
- V6 : Name_Id;
- V7 : Name_Id;
- V8 : Name_Id) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7 or else
- T = V8;
- end Nam_In;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id;
- V5 : Name_Id;
- V6 : Name_Id;
- V7 : Name_Id;
- V8 : Name_Id;
- V9 : Name_Id) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7 or else
- T = V8 or else
- T = V9;
- end Nam_In;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id;
- V5 : Name_Id;
- V6 : Name_Id;
- V7 : Name_Id;
- V8 : Name_Id;
- V9 : Name_Id;
- V10 : Name_Id) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7 or else
- T = V8 or else
- T = V9 or else
- T = V10;
- end Nam_In;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id;
- V5 : Name_Id;
- V6 : Name_Id;
- V7 : Name_Id;
- V8 : Name_Id;
- V9 : Name_Id;
- V10 : Name_Id;
- V11 : Name_Id) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7 or else
- T = V8 or else
- T = V9 or else
- T = V10 or else
- T = V11;
- end Nam_In;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id;
- V5 : Name_Id;
- V6 : Name_Id;
- V7 : Name_Id;
- V8 : Name_Id;
- V9 : Name_Id;
- V10 : Name_Id;
- V11 : Name_Id;
- V12 : Name_Id) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7 or else
- T = V8 or else
- T = V9 or else
- T = V10 or else
- T = V11 or else
- T = V12;
- end Nam_In;
-
-----------------
-- Name_Equals --
-----------------
@@ -1729,34 +1509,6 @@ package body Namet is
return Buf.Chars (1 .. Buf.Length);
end To_String;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- Name_Chars.Tree_Read;
- Name_Entries.Tree_Read;
-
- Tree_Read_Data
- (Hash_Table'Address,
- Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Name_Chars.Tree_Write;
- Name_Entries.Tree_Write;
-
- Tree_Write_Data
- (Hash_Table'Address,
- Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
- end Tree_Write;
-
------------
-- Unlock --
------------
diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads
index c00fdef..ce7cac1 100644
--- a/gcc/ada/namet.ads
+++ b/gcc/ada/namet.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -207,130 +207,6 @@ package Namet is
pragma Inline (Present);
-- Determine whether name Nam exists
- ------------------------------
- -- Name_Id Membership Tests --
- ------------------------------
-
- -- The following functions allow a convenient notation for testing whether
- -- a Name_Id value matches any one of a list of possible values. In each
- -- case True is returned if the given T argument is equal to any of the V
- -- arguments. These essentially duplicate the Ada 2012 membership tests,
- -- but we cannot use the latter (yet) in the compiler front end, because
- -- of bootstrap considerations
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id) return Boolean;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id) return Boolean;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id) return Boolean;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id;
- V5 : Name_Id) return Boolean;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id;
- V5 : Name_Id;
- V6 : Name_Id) return Boolean;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id;
- V5 : Name_Id;
- V6 : Name_Id;
- V7 : Name_Id) return Boolean;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id;
- V5 : Name_Id;
- V6 : Name_Id;
- V7 : Name_Id;
- V8 : Name_Id) return Boolean;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id;
- V5 : Name_Id;
- V6 : Name_Id;
- V7 : Name_Id;
- V8 : Name_Id;
- V9 : Name_Id) return Boolean;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id;
- V5 : Name_Id;
- V6 : Name_Id;
- V7 : Name_Id;
- V8 : Name_Id;
- V9 : Name_Id;
- V10 : Name_Id) return Boolean;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id;
- V5 : Name_Id;
- V6 : Name_Id;
- V7 : Name_Id;
- V8 : Name_Id;
- V9 : Name_Id;
- V10 : Name_Id;
- V11 : Name_Id) return Boolean;
-
- function Nam_In
- (T : Name_Id;
- V1 : Name_Id;
- V2 : Name_Id;
- V3 : Name_Id;
- V4 : Name_Id;
- V5 : Name_Id;
- V6 : Name_Id;
- V7 : Name_Id;
- V8 : Name_Id;
- V9 : Name_Id;
- V10 : Name_Id;
- V11 : Name_Id;
- V12 : Name_Id) return Boolean;
-
- pragma Inline (Nam_In);
- -- Inline all above functions
-
-----------------
-- Subprograms --
-----------------
@@ -415,9 +291,7 @@ package Namet is
-- also the suffixes used to indicate package body entities and to
-- distinguish between overloaded entities). Note that names are not
-- qualified until just before the call to gigi, so this routine is only
- -- needed by processing that occurs after gigi has been called. This
- -- includes all ASIS processing, since ASIS works on the tree written
- -- after gigi has been called.
+ -- needed by processing that occurs after gigi has been called.
procedure Append_Unqualified_Decoded
(Buf : in out Bounded_String;
@@ -550,15 +424,6 @@ package Namet is
-- Unlocks the name table to allow use of the extra space reserved by the
-- call to Lock. See gnat1drv for details of the need for this.
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines. Note that Initialize should not be called if
- -- Tree_Read is used. Tree_Read includes all necessary initialization.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
procedure Write_Name (Id : Valid_Name_Id);
-- Write_Name writes the characters of the specified name using the
-- standard output procedures in package Output. The name is written
diff --git a/gcc/ada/namet.h b/gcc/ada/namet.h
index d6011fa..1bc20c0 100644
--- a/gcc/ada/namet.h
+++ b/gcc/ada/namet.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb
index e84388f..29eec04 100644
--- a/gcc/ada/nlists.adb
+++ b/gcc/ada/nlists.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -141,8 +141,7 @@ package body Nlists is
Next_Node.Set_Last (N);
Prev_Node.Set_Last (N);
- -- Make sure we have no uninitialized junk in any new entires added.
- -- This ensures that Tree_Gen will not write out any uninitialized junk.
+ -- Make sure we have no uninitialized junk in any new entries added.
for J in Old_Last + 1 .. N loop
Next_Node.Table (J) := Empty;
@@ -244,7 +243,7 @@ package body Nlists is
N := F;
loop
Set_List_Link (N, To);
- N := Next (N);
+ Next (N);
exit when No (N);
end loop;
@@ -531,7 +530,7 @@ package body Nlists is
loop
Set_List_Link (N, LC);
exit when N = L;
- N := Next (N);
+ Next (N);
end loop;
if Present (Before) then
@@ -598,7 +597,7 @@ package body Nlists is
loop
Set_List_Link (N, LC);
exit when N = L;
- N := Next (N);
+ Next (N);
end loop;
if Present (After) then
@@ -700,7 +699,7 @@ package body Nlists is
Node := First (List);
while Present (Node) loop
Result := Result + 1;
- Node := Next (Node);
+ Next (Node);
end loop;
return Result;
@@ -757,7 +756,7 @@ package body Nlists is
while Present (E) loop
Append (New_Copy (E), NL);
- E := Next (E);
+ Next (E);
end loop;
return NL;
@@ -785,7 +784,7 @@ package body Nlists is
Append (New_Copy (E), NL);
end if;
- E := Next (E);
+ Next (E);
end loop;
return NL;
@@ -991,8 +990,8 @@ package body Nlists is
begin
N := Node;
loop
- N := Next (N);
- exit when not Nkind_In (N, N_Pragma, N_Null_Statement);
+ Next (N);
+ exit when Nkind (N) not in N_Pragma | N_Null_Statement;
end loop;
return N;
@@ -1041,7 +1040,7 @@ package body Nlists is
begin
Elmt := First (List);
for J in 1 .. Index - 1 loop
- Elmt := Next (Elmt);
+ Next (Elmt);
end loop;
return Elmt;
@@ -1470,29 +1469,6 @@ package body Nlists is
Prev_Node.Table (Node) := To;
end Set_Prev;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- pragma Assert (not Locked);
- Lists.Tree_Read;
- Next_Node.Tree_Read;
- Prev_Node.Tree_Read;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Lists.Tree_Write;
- Next_Node.Tree_Write;
- Prev_Node.Tree_Write;
- end Tree_Write;
-
------------
-- Unlock --
------------
diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads
index 1c6ae2c..67fc661 100644
--- a/gcc/ada/nlists.ads
+++ b/gcc/ada/nlists.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -337,8 +337,7 @@ package Nlists is
procedure Initialize;
-- Called at the start of compilation of each new main source file to
- -- initialize the allocation of the list table. Note that Initialize
- -- must not be called if Tree_Read is used.
+ -- initialize the allocation of the list table.
procedure Lock;
-- Called to lock tables before back end is called
@@ -355,15 +354,6 @@ package Nlists is
-- Called to unlock list contents when assertions are enabled; if
-- assertions are not enabled calling this subprogram has no effect.
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines. Note that Initialize should not be called if
- -- Tree_Read is used. Tree_Read includes all necessary initialization.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
function Parent (List : List_Id) return Node_Or_Entity_Id;
pragma Inline (Parent);
-- Node lists may have a parent in the same way as a node. The function
diff --git a/gcc/ada/nlists.h b/gcc/ada/nlists.h
index b678bab..3fa2906 100644
--- a/gcc/ada/nlists.h
+++ b/gcc/ada/nlists.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb
index 4ceffb0..2d21b56 100644
--- a/gcc/ada/opt.adb
+++ b/gcc/ada/opt.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,15 +29,8 @@
-- --
------------------------------------------------------------------------------
-with Gnatvsn; use Gnatvsn;
-with System; use System;
-with Tree_IO; use Tree_IO;
-
package body Opt is
- SU : constant := Storage_Unit;
- -- Shorthand for System.Storage_Unit
-
-------------------------
-- Back_End_Exceptions --
-------------------------
@@ -312,127 +305,4 @@ package body Opt is
Polling_Required := Polling_Required_Config;
end Set_Config_Switches;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- Tree_Version_String_Len : Nat;
- Ada_Version_Config_Val : Nat;
- Ada_Version_Explicit_Config_Val : Nat;
- Assertions_Enabled_Config_Val : Nat;
-
- begin
- Tree_Read_Int (Tree_ASIS_Version_Number);
-
- Tree_Read_Bool (Address_Is_Private);
- Tree_Read_Bool (Brief_Output);
- Tree_Read_Bool (GNAT_Mode);
- Tree_Read_Char (Identifier_Character_Set);
- Tree_Read_Bool (Ignore_Rep_Clauses);
- Tree_Read_Bool (Ignore_Style_Checks_Pragmas);
- Tree_Read_Int (Maximum_File_Name_Length);
- Tree_Read_Data (Suppress_Options'Address,
- (Suppress_Options'Size + SU - 1) / SU);
- Tree_Read_Bool (Verbose_Mode);
- Tree_Read_Data (Warning_Mode'Address,
- (Warning_Mode'Size + SU - 1) / SU);
- Tree_Read_Int (Ada_Version_Config_Val);
- Tree_Read_Int (Ada_Version_Explicit_Config_Val);
- Tree_Read_Int (Assertions_Enabled_Config_Val);
- Tree_Read_Bool (All_Errors_Mode);
- Tree_Read_Bool (Assertions_Enabled);
- Tree_Read_Bool (Check_Float_Overflow);
- Tree_Read_Int (Int (Check_Policy_List));
- Tree_Read_Int (Int (Default_Pool));
- Tree_Read_Bool (Full_List);
-
- Ada_Version_Config :=
- Ada_Version_Type'Val (Ada_Version_Config_Val);
- Ada_Version_Explicit_Config :=
- Ada_Version_Type'Val (Ada_Version_Explicit_Config_Val);
- Assertions_Enabled_Config :=
- Boolean'Val (Assertions_Enabled_Config_Val);
-
- -- Read version string: we have to get the length first
-
- Tree_Read_Int (Tree_Version_String_Len);
-
- declare
- Tmp : String (1 .. Integer (Tree_Version_String_Len));
- begin
- Tree_Read_Data
- (Tmp'Address, Tree_Version_String_Len);
- System.Strings.Free (Tree_Version_String);
- Free (Tree_Version_String);
- Tree_Version_String := new String'(Tmp);
- end;
-
- Tree_Read_Data (Distribution_Stub_Mode'Address,
- (Distribution_Stub_Mode'Size + SU - 1) / Storage_Unit);
- Tree_Read_Bool (Inline_Active);
- Tree_Read_Bool (Inline_Processing_Required);
- Tree_Read_Bool (List_Units);
- Tree_Read_Int (Multiple_Unit_Index);
- Tree_Read_Bool (Configurable_Run_Time_Mode);
- Tree_Read_Data (Operating_Mode'Address,
- (Operating_Mode'Size + SU - 1) / Storage_Unit);
- Tree_Read_Bool (Suppress_Checks);
- Tree_Read_Bool (Try_Semantics);
- Tree_Read_Data (Wide_Character_Encoding_Method'Address,
- (Wide_Character_Encoding_Method'Size + SU - 1) / SU);
- Tree_Read_Bool (Upper_Half_Encoding);
- Tree_Read_Bool (Force_ALI_Tree_File);
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- Version_String : String := Gnat_Version_String;
-
- begin
- Tree_Write_Int (ASIS_Version_Number);
-
- Tree_Write_Bool (Address_Is_Private);
- Tree_Write_Bool (Brief_Output);
- Tree_Write_Bool (GNAT_Mode);
- Tree_Write_Char (Identifier_Character_Set);
- Tree_Write_Bool (Ignore_Rep_Clauses);
- Tree_Write_Bool (Ignore_Style_Checks_Pragmas);
- Tree_Write_Int (Maximum_File_Name_Length);
- Tree_Write_Data (Suppress_Options'Address,
- (Suppress_Options'Size + SU - 1) / SU);
- Tree_Write_Bool (Verbose_Mode);
- Tree_Write_Data (Warning_Mode'Address,
- (Warning_Mode'Size + SU - 1) / Storage_Unit);
- Tree_Write_Int (Ada_Version_Type'Pos (Ada_Version_Config));
- Tree_Write_Int (Ada_Version_Type'Pos (Ada_Version_Explicit_Config));
- Tree_Write_Int (Boolean'Pos (Assertions_Enabled_Config));
- Tree_Write_Bool (All_Errors_Mode);
- Tree_Write_Bool (Assertions_Enabled);
- Tree_Write_Bool (Check_Float_Overflow);
- Tree_Write_Int (Int (Check_Policy_List));
- Tree_Write_Int (Int (Default_Pool));
- Tree_Write_Bool (Full_List);
- Tree_Write_Int (Int (Version_String'Length));
- Tree_Write_Data (Version_String'Address, Version_String'Length);
- Tree_Write_Data (Distribution_Stub_Mode'Address,
- (Distribution_Stub_Mode'Size + SU - 1) / SU);
- Tree_Write_Bool (Inline_Active);
- Tree_Write_Bool (Inline_Processing_Required);
- Tree_Write_Bool (List_Units);
- Tree_Write_Int (Multiple_Unit_Index);
- Tree_Write_Bool (Configurable_Run_Time_Mode);
- Tree_Write_Data (Operating_Mode'Address,
- (Operating_Mode'Size + SU - 1) / SU);
- Tree_Write_Bool (Suppress_Checks);
- Tree_Write_Bool (Try_Semantics);
- Tree_Write_Data (Wide_Character_Encoding_Method'Address,
- (Wide_Character_Encoding_Method'Size + SU - 1) / SU);
- Tree_Write_Bool (Upper_Half_Encoding);
- Tree_Write_Bool (Force_ALI_Tree_File);
- end Tree_Write;
-
end Opt;
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index 291fae8..c982f83 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -57,50 +57,6 @@ package Opt is
-- from a compilation point of view (e.g. spelling of identifiers and
-- white space layout do not count in this computation).
- -- The way the checksum is computed has evolved across the various versions
- -- of GNAT. When gprbuild is called with -m, the checksums must be computed
- -- the same way in gprbuild as it was in the GNAT version of the compiler.
- -- The different ways are
-
- -- Version 6.4 and later:
-
- -- The Accumulate_Token_Checksum procedure is called after each numeric
- -- literal and each identifier/keyword. For keywords, Tok_Identifier is
- -- used in the call to Accumulate_Token_Checksum.
-
- -- Versions 5.04 to 6.3:
-
- -- For keywords, the token value were used in the call to procedure
- -- Accumulate_Token_Checksum. Type Token_Type did not include Tok_Some.
-
- -- Versions 5.03:
-
- -- For keywords, the token value were used in the call to
- -- Accumulate_Token_Checksum. Type Token_Type did not include
- -- Tok_Interface, Tok_Overriding, Tok_Synchronized and Tok_Some.
-
- -- Versions 5.02 and before:
-
- -- No calls to procedure Accumulate_Token_Checksum (the checksum
- -- mechanism was introduced in version 5.03).
-
- -- To signal to the scanner whether Accumulate_Token_Checksum needs to be
- -- called and what versions to call, the following Boolean flags are used:
-
- Checksum_Accumulate_Token_Checksum : Boolean := True;
- -- GPRBUILD
- -- Set to False by gprbuild when the version of GNAT is 5.02 or before. If
- -- this switch is False, then we do not call Accumulate_Token_Checksum, so
- -- the setting of the following two flags is irrelevant.
-
- Checksum_GNAT_6_3 : Boolean := False;
- -- GPRBUILD
- -- Set to True by gprbuild when the version of GNAT is 6.3 or before.
-
- Checksum_GNAT_5_03 : Boolean := False;
- -- GPRBUILD
- -- Set to True by gprbuild when the version of GNAT is 5.03 or before.
-
Checksum_Accumulate_Limited_Checksum : Boolean := False;
-- Used to control the computation of the limited view of a package.
-- (Not currently used, possible optimization for ALI files of units
@@ -158,7 +114,7 @@ package Opt is
-- remains set to Ada_Version_Default). This is used in the rare cases
-- (notably pragma Obsolescent) where we want the explicit version set.
- Ada_Version_Runtime : Ada_Version_Type := Ada_2012;
+ Ada_Version_Runtime : Ada_Version_Type := Ada_2020;
-- GNAT
-- Ada version used to compile the runtime. Used to set Ada_Version (but
-- not Ada_Version_Explicit) when compiling predefined or internal units.
@@ -210,7 +166,7 @@ package Opt is
Allow_Integer_Address : Boolean := False;
-- GNAT
-- Allow use of integer expression in a context requiring System.Address.
- -- Set by the use of configuration pragma Allow_Integer_Address Also set
+ -- Set by the use of configuration pragma Allow_Integer_Address. Also set
-- in relaxed semantics mode for use by CodePeer or when -gnatd.M is used.
All_Sources : Boolean := False;
@@ -223,21 +179,6 @@ package Opt is
-- Set to non-null when Bind_Alternate_Main_Name is True. This value
-- is modified as needed by Gnatbind.Scan_Bind_Arg.
- ASIS_GNSA_Mode : Boolean := False;
- -- GNAT
- -- Enable GNSA back-end processing assuming ASIS_Mode is already set to
- -- True. ASIS_GNSA mode suppresses the call to gigi.
-
- ASIS_Mode : Boolean := False;
- -- GNAT
- -- Enable semantic checks and tree transformations that are important
- -- for ASIS but that are usually skipped if Operating_Mode is set to
- -- Check_Semantics. This flag does not have the corresponding option to set
- -- it ON. It is set ON when Tree_Output is set ON, it can also be set ON
- -- from the code of GNSA-based tool (a client may need to set ON the
- -- Back_Annotate_Rep_Info flag in this case. At the moment this does not
- -- make very much sense, because GNSA cannot do back annotation).
-
Assertions_Enabled : Boolean := False;
-- GNAT
-- Indicates default policy (True = Check, False = Ignore) to be applied
@@ -257,9 +198,9 @@ package Opt is
-- GNAT
-- If set True, enables back annotation of representation information
-- by gigi, even in -gnatc mode. This is set True by the use of -gnatR
- -- (list representation information) or -gnatt (generate tree). It is
- -- also set true if certain Unchecked_Conversion instantiations require
- -- checking based on annotated values.
+ -- (list representation information). It is also set true if certain
+ -- Unchecked_Conversion instantiations require checking based on annotated
+ -- values.
Back_End_Handles_Limited_Types : Boolean;
-- This flag is set true if the back end can properly handle limited or
@@ -432,9 +373,9 @@ package Opt is
Configurable_Run_Time_Mode : Boolean := False;
-- GNAT, GNATBIND
-- Set True if the compiler is operating in configurable run-time mode.
- -- This happens if the flag Targparm.Configurable_Run_TimeMode_On_Target
- -- is set True, or if pragma No_Run_Time is used. See the spec of Rtsfind
- -- for details on the handling of the latter pragma.
+ -- This happens if the flag Targparm.Configurable_Run_Time_On_Target is
+ -- True, or if pragma No_Run_Time is used. See the spec of Rtsfind for
+ -- details on the handling of the latter pragma.
Constant_Condition_Warnings : Boolean := False;
-- GNAT
@@ -507,6 +448,14 @@ package Opt is
-- PROJECT MANAGER
-- Set to False with switch -f of gnatclean and gprclean
+ Disable_FE_Inline : Boolean := False;
+ -- GNAT
+ -- Request to disable front end inlining from pragma Inline in the
+ -- presence of the -fno-inline back end flag on the command line,
+ -- regardless of any other switches that are set.
+ -- It remains the back end's reponsibility to honor -fno-inline at the
+ -- back end level.
+
Display_Compilation_Progress : Boolean := False;
-- GNATMAKE, GPRBUILD
-- Set True (-d switch) to display information on progress while compiling
@@ -671,7 +620,7 @@ package Opt is
Extensions_Allowed : Boolean := False;
-- GNAT
-- Set to True by switch -gnatX if GNAT specific language extensions
- -- are allowed. Currently there are no such defined extensions.
+ -- are allowed. See GNAT RM for details.
type External_Casing_Type is (
As_Is, -- External names cased as they appear in the Ada source
@@ -710,10 +659,10 @@ package Opt is
-- Indicates the current setting of Fast_Math mode, as set by the use
-- of a Fast_Math pragma (set True by Fast_Math (On)).
- Force_ALI_Tree_File : Boolean := False;
+ Force_ALI_File : Boolean := False;
-- GNAT
- -- Force generation of ALI file even if errors are encountered. Also forces
- -- generation of tree file if -gnatt is also set. Set on by use of -gnatQ.
+ -- Force generation of ALI file even if errors are encountered.
+ -- Set on by use of -gnatQ.
Disable_ALI_File : Boolean := False;
-- GNAT
@@ -854,7 +803,7 @@ package Opt is
Ignore_Rep_Clauses : Boolean := False;
-- GNAT
-- Set True to ignore all representation clauses. Useful when compiling
- -- code from foreign compilers for checking or ASIS purposes. Can be
+ -- code from foreign compilers for checking purposes. Can be
-- set True by use of -gnatI.
Ignore_SPARK_Mode_Pragmas_In_Instance : Boolean := False;
@@ -966,7 +915,7 @@ package Opt is
Leap_Seconds_Support : Boolean := False;
-- GNATBIND
-- Set to True to enable leap seconds support in Ada.Calendar and its
- -- children.
+ -- children. Set by -y.
Legacy_Elaboration_Checks : Boolean := False;
-- GNAT
@@ -1058,6 +1007,10 @@ package Opt is
-- before preprocessing occurs. Set to True by switch -s of gnatprep or
-- -s in preprocessing data file for the compiler.
+ XDR_Stream : Boolean := False;
+ -- GNATBIND
+ -- Set to True to enable XDR in s-stratt.adb. Set by -xdr.
+
type Create_Repinfo_File_Proc is access procedure (Src : String);
type Write_Repinfo_Line_Proc is access procedure (Info : String);
type Close_Repinfo_File_Proc is access procedure;
@@ -1072,6 +1025,7 @@ package Opt is
-- to the three corresponding procedures in Osint-C. The reason for this
-- slightly strange interface is to stop Repinfo from dragging in Osint in
-- ASIS mode, which would include lots of unwanted units in the ASIS build.
+ -- ??? Revisit this now that ASIS mode is gone.
type Create_List_File_Proc is access procedure (S : String);
type Write_List_Info_Proc is access procedure (S : String);
@@ -1258,11 +1212,6 @@ package Opt is
-- cannot be simultaneous compilations with the object files in the same
-- object directory, if project files are used.
- OpenAcc_Enabled : Boolean := False;
- -- GNAT
- -- Indicates whether OpenAcc pragmas should be taken into account. Set to
- -- True by the use of -fopenacc.
-
type Operating_Mode_Type is (Check_Syntax, Check_Semantics, Generate_Code);
pragma Ordered (Operating_Mode_Type);
Operating_Mode : Operating_Mode_Type := Generate_Code;
@@ -1528,15 +1477,6 @@ package Opt is
-- with'ed indirectly. It is set True by use of either the -gnatg or
-- -gnaty switches, but not by use of the Style_Checks pragma.
- Disable_FE_Inline : Boolean := False;
- Disable_FE_Inline_Always : Boolean := False;
- -- GNAT
- -- Request to disable front end inlining from pragma Inline or pragma
- -- Inline_Always out of the presence of the -fno-inline back end flag
- -- on the command line, regardless of any other switches that are set.
- -- It remains the back end's reponsibility to honor -fno-inline at the
- -- back end level.
-
Suppress_Control_Flow_Optimizations : Boolean := False;
-- GNAT
-- Set by -fpreserve-control-flow. Suppresses control flow optimizations
@@ -1658,10 +1598,6 @@ package Opt is
-- Set True to treat pragma Restrictions as Restriction_Warnings. Set by
-- -gnatr switch.
- Tree_Output : Boolean := False;
- -- GNAT
- -- Set to True (-gnatt) to generate output tree file
-
Try_Semantics : Boolean := False;
-- GNAT
-- Flag set to force attempt at semantic analysis, even if parser errors
@@ -1975,7 +1911,8 @@ package Opt is
-- Controls treatment of warning messages. If set to Suppress, warning
-- messages are not generated at all. In Normal mode, they are generated
-- but do not count as errors. In Treat_As_Error mode, warning messages are
- -- generated and treated as errors. In Treat_Run_Time_Warnings_As_Errors,
+ -- generated and treated as errors, except for warnings emitted by the
+ -- Compile_Time_Warning pragma. In Treat_Run_Time_Warnings_As_Errors,
-- warning messages regarding errors raised at run time are treated as
-- errors. Note that Warning_Mode = Suppress causes pragma Warnings to be
-- ignored (except for legality checks), unless we are in GNATprove_Mode,
@@ -2229,12 +2166,12 @@ package Opt is
-- allocated dispatch tables. If it is True, then the front end will
-- generate static aggregates for dispatch tables that contain forward
-- references to addresses of subprograms not seen yet, and the back end
- -- must be prepared to handle this case. If it is False, then the front
- -- end generates assignments to initialize the dispatch table, and there
- -- are no such forward references. By default we build statically allocated
- -- dispatch tables for all library level tagged types in all platforms.This
- -- behavior can be disabled using switch -gnatd.t which will set this flag
- -- to False and revert to the previous dynamic behavior.
+ -- must be prepared to handle this case. If it is False, then the front end
+ -- generates assignments to initialize the dispatch table, and there are
+ -- no such forward references. By default we build statically allocated
+ -- dispatch tables for all library-level tagged types in all platforms.
+ -- This behavior can be disabled using switch -gnatd.t which will set
+ -- this flag to False and revert to the previous dynamic behavior.
Expander_Active : Boolean := False;
-- A flag that indicates if expansion is active (True) or deactivated
@@ -2246,41 +2183,9 @@ package Opt is
-- be in the spec of Expander, but it is referenced by Errout, and it
-- really seems wrong for Errout to depend on Expander.
- -----------------------
- -- Tree I/O Routines --
- -----------------------
-
- procedure Tree_Read;
- -- Reads switch settings from current tree file using Tree_Read
-
- procedure Tree_Write;
- -- Writes out switch settings to current tree file using Tree_Write
-
- --------------------------
- -- ASIS Version Control --
- --------------------------
-
- -- These two variables (Tree_Version_String and Tree_ASIS_Version_Number)
- -- are supposed to be used in the GNAT/ASIS version check performed in
- -- the ASIS code (this package is also a part of the ASIS implementation).
- -- They are set by Tree_Read procedure, so they represent the version
- -- number (and the version string) of the compiler which has created the
- -- tree, and they are supposed to be compared with the corresponding values
- -- from the Tree_IO and Gnatvsn packages which also are a part of ASIS
- -- implementation.
-
- Tree_Version_String : String_Access;
- -- Used to store the compiler version string read from a tree file to check
- -- if it is from the same date as stored in the version string in Gnatvsn.
- -- We require that ASIS Pro can be used only with GNAT Pro, but we allow
- -- non-Pro ASIS and ASIS-based tools to be used with any version of the
- -- GNAT compiler. Therefore, we need the possibility to compare the dates
- -- of the corresponding source sets, using version strings that may be
- -- of different lengths.
-
- Tree_ASIS_Version_Number : Int;
- -- Used to store the ASIS version number read from a tree file to check if
- -- it is the same as stored in the ASIS version number in Tree_IO.
+ Tagged_Seen : Boolean := False;
+ -- Set True by the parser if the "tagged" reserved word is seen. This is
+ -- needed in Exp_Put_Image (see that package for documentation).
-----------------------------------
-- Modes for Formal Verification --
diff --git a/gcc/ada/osint-b.adb b/gcc/ada/osint-b.adb
index 302a512..b8b45f8 100644
--- a/gcc/ada/osint-b.adb
+++ b/gcc/ada/osint-b.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/osint-b.ads b/gcc/ada/osint-b.ads
index 8aafdfb..fc88082 100644
--- a/gcc/ada/osint-b.ads
+++ b/gcc/ada/osint-b.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/osint-c.adb b/gcc/ada/osint-c.adb
index 9fb9ee3..0010a8d 100644
--- a/gcc/ada/osint-c.adb
+++ b/gcc/ada/osint-c.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -23,8 +23,7 @@
-- --
------------------------------------------------------------------------------
-with Opt; use Opt;
-with Tree_IO; use Tree_IO;
+with Opt; use Opt;
package body Osint.C is
@@ -413,22 +412,23 @@ package body Osint.C is
-- Remove extension preparing to replace it
declare
- Name : String := Name_Buffer (1 .. Dot_Index);
- First : Positive;
+ Name : String := Name_Buffer (1 .. Dot_Index);
+ Output : String := Output_Object_File_Name.all;
+ First : Positive;
begin
- Name_Buffer (1 .. Output_Object_File_Name'Length) :=
- Output_Object_File_Name.all;
+ Name_Buffer (1 .. Output_Object_File_Name'Length) := Output;
-- Put two names in canonical case, to allow object file names
-- with upper-case letters on Windows.
+ -- Do it with a copy (Output) and keep Name_Buffer as is since we
+ -- want to preserve the original casing.
Canonical_Case_File_Name (Name);
- Canonical_Case_File_Name
- (Name_Buffer (1 .. Output_Object_File_Name'Length));
+ Canonical_Case_File_Name (Output);
Dot_Index := 0;
- for J in reverse Output_Object_File_Name'Range loop
+ for J in reverse Output'Range loop
if Name_Buffer (J) = '.' then
Dot_Index := J;
exit;
@@ -452,7 +452,7 @@ package body Osint.C is
-- Check name of object file is what we expect
- if Name /= Name_Buffer (First .. Dot_Index) then
+ if Name /= Output (First .. Dot_Index) then
Fail ("incorrect object file name");
end if;
end;
@@ -490,69 +490,6 @@ package body Osint.C is
Output_Object_File_Name := new String'(Name);
end Set_Output_Object_File_Name;
- ----------------
- -- Tree_Close --
- ----------------
-
- procedure Tree_Close is
- Status : Boolean;
- begin
- Tree_Write_Terminate;
- Close (Output_FD, Status);
-
- if not Status then
- Fail
- ("error while closing tree file "
- & Get_Name_String (Output_File_Name));
- end if;
- end Tree_Close;
-
- -----------------
- -- Tree_Create --
- -----------------
-
- procedure Tree_Create is
- Dot_Index : Natural;
-
- begin
- Get_Name_String (Current_Main);
-
- -- If an object file has been specified, then the ALI file
- -- will be in the same directory as the object file;
- -- so, we put the tree file in this same directory,
- -- even though no object file needs to be generated.
-
- if Output_Object_File_Name /= null then
- Name_Len := Output_Object_File_Name'Length;
- Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
- end if;
-
- Dot_Index := Name_Len + 1;
-
- for J in reverse 1 .. Name_Len loop
- if Name_Buffer (J) = '.' then
- Dot_Index := J;
- exit;
- end if;
- end loop;
-
- -- Should be impossible to not have an extension
-
- pragma Assert (Dot_Index /= 0);
-
- -- Change extension to adt
-
- Name_Buffer (Dot_Index) := '.';
- Name_Buffer (Dot_Index + 1) := 'a';
- Name_Buffer (Dot_Index + 2) := 'd';
- Name_Buffer (Dot_Index + 3) := 't';
- Name_Buffer (Dot_Index + 4) := ASCII.NUL;
- Name_Len := Dot_Index + 3;
- Create_File_And_Check (Output_FD, Binary);
-
- Tree_Write_Initialize (Output_FD);
- end Tree_Create;
-
-----------------------
-- Write_Debug_Info --
-----------------------
diff --git a/gcc/ada/osint-c.ads b/gcc/ada/osint-c.ads
index 2d58f92..6862e30 100644
--- a/gcc/ada/osint-c.ads
+++ b/gcc/ada/osint-c.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -197,16 +197,4 @@ package Osint.C is
procedure Close_List_File;
-- Close file previously opened by Create_List_File
- --------------------------------
- -- Semantic Tree Input-Output --
- --------------------------------
-
- procedure Tree_Create;
- -- Creates the tree output file for the source file which is currently
- -- being compiled (i.e. the file which was most recently returned by
- -- Next_Main_Source), and initializes Tree_IO.Tree_Write for output.
-
- procedure Tree_Close;
- -- Closes the file previously opened by Tree_Create
-
end Osint.C;
diff --git a/gcc/ada/osint-l.adb b/gcc/ada/osint-l.adb
index 908a1d9..ad29e94 100644
--- a/gcc/ada/osint-l.adb
+++ b/gcc/ada/osint-l.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/osint-l.ads b/gcc/ada/osint-l.ads
index 0a64913..6a5fe03 100644
--- a/gcc/ada/osint-l.ads
+++ b/gcc/ada/osint-l.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/osint-m.adb b/gcc/ada/osint-m.adb
index 43719eb..536adb3 100644
--- a/gcc/ada/osint-m.adb
+++ b/gcc/ada/osint-m.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/osint-m.ads b/gcc/ada/osint-m.ads
index 6017ccc..eff7bdd 100644
--- a/gcc/ada/osint-m.ads
+++ b/gcc/ada/osint-m.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb
index ac89187..3ae76cf 100644
--- a/gcc/ada/osint.adb
+++ b/gcc/ada/osint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -100,6 +100,10 @@ package body Osint is
-- executable is stored in directory "/foo/bar/bin", this routine returns
-- "/foo/bar/". Return "" if location is not recognized as described above.
+ function File_Names_Equal (File1, File2 : String) return Boolean;
+ -- Compare File1 and File2 taking into account the case insensitivity
+ -- of the OS.
+
function Update_Path (Path : String_Ptr) return String_Ptr;
-- Update the specified path to replace the prefix with the location where
-- GNAT is installed. See the file prefix.c in GCC for details.
@@ -852,30 +856,22 @@ package body Osint is
end if;
if Add_Suffix then
- declare
- Buffer : String := Name_Buffer (1 .. Name_Len);
-
- begin
- -- Get the file name in canonical case to accept as is. Names
- -- end with ".EXE" on Windows.
-
- Canonical_Case_File_Name (Buffer);
-
- -- If Executable doesn't end with the executable suffix, add it
-
- if Buffer'Length <= Exec_Suffix'Length
- or else
- Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last)
- /= Exec_Suffix.all
- then
- Name_Buffer
- (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
- Exec_Suffix.all;
- Name_Len := Name_Len + Exec_Suffix'Length;
- Free (Exec_Suffix);
- return Name_Find;
- end if;
- end;
+ -- If Executable doesn't end with the executable suffix, add it
+
+ if Name_Len <= Exec_Suffix'Length
+ or else not
+ File_Names_Equal
+ (Name_Buffer
+ (Name_Len - Exec_Suffix'Length + 1 .. Name_Len),
+ Exec_Suffix.all)
+ then
+ Name_Buffer
+ (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
+ Exec_Suffix.all;
+ Name_Len := Name_Len + Exec_Suffix'Length;
+ Free (Exec_Suffix);
+ return Name_Find;
+ end if;
end if;
end if;
@@ -889,7 +885,6 @@ package body Osint is
is
Exec_Suffix : String_Access;
Add_Suffix : Boolean;
- Canonical_Name : String := Name;
begin
if Executable_Extension_On_Target = No_Name then
@@ -909,25 +904,26 @@ package body Osint is
begin
Free (Exec_Suffix);
- Canonical_Case_File_Name (Canonical_Name);
-
Add_Suffix := True;
+
if Only_If_No_Suffix then
- for J in reverse Canonical_Name'Range loop
- if Canonical_Name (J) = '.' then
+ for J in reverse Name'Range loop
+ if Name (J) = '.' then
Add_Suffix := False;
exit;
- elsif Is_Directory_Separator (Canonical_Name (J)) then
+ elsif Is_Directory_Separator (Name (J)) then
exit;
end if;
end loop;
end if;
if Add_Suffix and then
- (Canonical_Name'Length <= Suffix'Length
- or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
- .. Canonical_Name'Last) /= Suffix)
+ (Name'Length <= Suffix'Length
+ or else not
+ File_Names_Equal
+ (Name (Name'Last - Suffix'Length + 1 .. Name'Last),
+ Suffix))
then
declare
Result : String (1 .. Name'Length + Suffix'Length);
@@ -1057,6 +1053,19 @@ package body Osint is
Exit_Program (E_Fatal);
end Fail;
+ ----------------------
+ -- File_Names_Equal --
+ ----------------------
+
+ function File_Names_Equal (File1, File2 : String) return Boolean is
+ begin
+ if File_Names_Case_Sensitive then
+ return File1 = File2;
+ else
+ return To_Lower (File1) = To_Lower (File2);
+ end if;
+ end File_Names_Equal;
+
---------------
-- File_Hash --
---------------
diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads
index a0b046c..28f90aa 100644
--- a/gcc/ada/osint.ads
+++ b/gcc/ada/osint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb
index 212f1cc..971819b 100644
--- a/gcc/ada/output.adb
+++ b/gcc/ada/output.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -45,6 +45,13 @@ package body Output is
Current_FD : File_Descriptor := Standout;
-- File descriptor for current output
+ type FD_Array is array (Nat range 1 .. 3) of File_Descriptor;
+ FD_Stack : FD_Array;
+ FD_Stack_Idx : Nat := FD_Array'First - 1;
+ -- Maintain a small stack for Push_Output and Pop_Output. We'd normally
+ -- use Table for this and allow an unlimited depth, but we're the target
+ -- of a pragma Elaborate_All in Table, so we can't use it here.
+
Special_Output_Proc : Output_Proc := null;
-- Record argument to last call to Set_Special_Output. If this is
-- non-null, then we are in special output mode.
@@ -228,6 +235,28 @@ package body Output is
(Cur_Indentation - Indentation_Amount) mod Indentation_Limit;
end Outdent;
+ ----------------
+ -- Pop_Output --
+ ----------------
+
+ procedure Pop_Output is
+ begin
+ pragma Assert (FD_Stack_Idx >= FD_Array'First);
+ Current_FD := FD_Stack (FD_Stack_Idx);
+ FD_Stack_Idx := FD_Stack_Idx - 1;
+ end Pop_Output;
+
+ -----------------
+ -- Push_Output --
+ -----------------
+
+ procedure Push_Output is
+ begin
+ pragma Assert (FD_Stack_Idx < FD_Array'Last);
+ FD_Stack_Idx := FD_Stack_Idx + 1;
+ FD_Stack (FD_Stack_Idx) := Current_FD;
+ end Push_Output;
+
---------------------------
-- Restore_Output_Buffer --
---------------------------
diff --git a/gcc/ada/output.ads b/gcc/ada/output.ads
index 4086e2a..55d308a 100644
--- a/gcc/ada/output.ads
+++ b/gcc/ada/output.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -95,6 +95,15 @@ package Output is
-- output will appear on the given file descriptor only after special
-- output has been cancelled.
+ procedure Push_Output;
+ -- Saves the current output destination on a stack, but leaves it
+ -- unchanged. This subprogram only supports a small stack and is normally
+ -- used with a depth of one.
+
+ procedure Pop_Output;
+ -- Changes the current output destination to be the last output destination
+ -- popped using Push_Output.
+
procedure Indent;
-- Increases the current indentation level. Whenever a line is written
-- (triggered by Eol), an appropriate amount of whitespace is added to the
diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb
index 34323b8..e4298e8 100644
--- a/gcc/ada/par-ch10.adb
+++ b/gcc/ada/par-ch10.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -511,7 +511,7 @@ package body Ch10 is
-- Another error from which it is hard to recover
- if Nkind_In (Unit_Node, N_Subprogram_Body_Stub, N_Package_Body_Stub) then
+ if Nkind (Unit_Node) in N_Subprogram_Body_Stub | N_Package_Body_Stub then
Cunit_Error_Flag := True;
return Error;
end if;
@@ -527,10 +527,10 @@ package body Ch10 is
Unit_Node := Specification (Unit_Node);
end if;
- if Nkind_In (Unit_Node, N_Package_Declaration,
- N_Subprogram_Declaration,
- N_Subprogram_Body,
- N_Subprogram_Renaming_Declaration)
+ if Nkind (Unit_Node) in N_Package_Declaration
+ | N_Subprogram_Declaration
+ | N_Subprogram_Body
+ | N_Subprogram_Renaming_Declaration
then
Unit_Node := Specification (Unit_Node);
@@ -541,27 +541,26 @@ package body Ch10 is
end if;
end if;
- if Nkind_In (Unit_Node, N_Task_Body,
- N_Protected_Body,
- N_Task_Type_Declaration,
- N_Protected_Type_Declaration,
- N_Single_Task_Declaration,
- N_Single_Protected_Declaration)
+ if Nkind (Unit_Node) in N_Task_Body
+ | N_Protected_Body
+ | N_Task_Type_Declaration
+ | N_Protected_Type_Declaration
+ | N_Single_Task_Declaration
+ | N_Single_Protected_Declaration
then
Name_Node := Defining_Identifier (Unit_Node);
- elsif Nkind_In (Unit_Node, N_Function_Instantiation,
- N_Function_Specification,
- N_Generic_Function_Renaming_Declaration,
- N_Generic_Package_Renaming_Declaration,
- N_Generic_Procedure_Renaming_Declaration)
- or else
- Nkind_In (Unit_Node, N_Package_Body,
- N_Package_Instantiation,
- N_Package_Renaming_Declaration,
- N_Package_Specification,
- N_Procedure_Instantiation,
- N_Procedure_Specification)
+ elsif Nkind (Unit_Node) in N_Function_Instantiation
+ | N_Function_Specification
+ | N_Generic_Function_Renaming_Declaration
+ | N_Generic_Package_Renaming_Declaration
+ | N_Generic_Procedure_Renaming_Declaration
+ or else Nkind (Unit_Node) in N_Package_Body
+ | N_Package_Instantiation
+ | N_Package_Renaming_Declaration
+ | N_Package_Specification
+ | N_Procedure_Instantiation
+ | N_Procedure_Specification
then
Name_Node := Defining_Unit_Name (Unit_Node);
diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb
index e385966..468ba03a 100644
--- a/gcc/ada/par-ch11.adb
+++ b/gcc/ada/par-ch11.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -57,27 +57,9 @@ package body Ch11 is
function P_Handled_Sequence_Of_Statements return Node_Id is
Handled_Stmt_Seq_Node : Node_Id;
- Seq_Is_Hidden_In_SPARK : Boolean;
- Hidden_Region_Start : Source_Ptr;
-
begin
Handled_Stmt_Seq_Node :=
New_Node (N_Handled_Sequence_Of_Statements, Token_Ptr);
-
- -- In SPARK, a HIDE directive can be placed at the beginning of a
- -- package initialization, thus hiding the sequence of statements (and
- -- possible exception handlers) from SPARK tool-set. No violation of the
- -- SPARK restriction should be issued on nodes in a hidden part, which
- -- is obtained by marking such hidden parts.
-
- if Token = Tok_SPARK_Hide then
- Seq_Is_Hidden_In_SPARK := True;
- Hidden_Region_Start := Token_Ptr;
- Scan; -- past HIDE directive
- else
- Seq_Is_Hidden_In_SPARK := False;
- end if;
-
Set_Statements
(Handled_Stmt_Seq_Node, P_Sequence_Of_Statements (SS_Extm_Sreq));
@@ -87,10 +69,6 @@ package body Ch11 is
(Handled_Stmt_Seq_Node, Parse_Exception_Handlers);
end if;
- if Seq_Is_Hidden_In_SPARK then
- Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr);
- end if;
-
return Handled_Stmt_Seq_Node;
end P_Handled_Sequence_Of_Statements;
@@ -282,24 +260,8 @@ package body Ch11 is
function Parse_Exception_Handlers return List_Id is
Handler : Node_Id;
Handlers_List : List_Id;
- Handler_Is_Hidden_In_SPARK : Boolean;
- Hidden_Region_Start : Source_Ptr;
begin
- -- In SPARK, a HIDE directive can be placed at the beginning of a
- -- sequence of exception handlers for a subprogram implementation, thus
- -- hiding the exception handlers from SPARK tool-set. No violation of
- -- the SPARK restriction should be issued on nodes in a hidden part,
- -- which is obtained by marking such hidden parts.
-
- if Token = Tok_SPARK_Hide then
- Handler_Is_Hidden_In_SPARK := True;
- Hidden_Region_Start := Token_Ptr;
- Scan; -- past HIDE directive
- else
- Handler_Is_Hidden_In_SPARK := False;
- end if;
-
Handlers_List := New_List;
P_Pragmas_Opt (Handlers_List);
@@ -320,10 +282,6 @@ package body Ch11 is
end loop;
end if;
- if Handler_Is_Hidden_In_SPARK then
- Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr);
- end if;
-
return Handlers_List;
end Parse_Exception_Handlers;
diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb
index 0ecac2e..c53f7cb 100644
--- a/gcc/ada/par-ch12.adb
+++ b/gcc/ada/par-ch12.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -972,8 +972,14 @@ package body Ch12 is
if Token = Tok_With then
- if Ada_Version >= Ada_2020 and Token /= Tok_Private then
+ if Ada_Version >= Ada_2020 and not Next_Token_Is (Tok_Private) then
+
-- Formal type has aspect specifications, parsed later.
+ -- Otherwise this is a formal derived type. Note that it may
+ -- also include later aspect specifications, as in:
+
+ -- type DT is new T with private with atomic;
+
return Def_Node;
else
diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb
index e26e83f..0b0319d 100644
--- a/gcc/ada/par-ch13.adb
+++ b/gcc/ada/par-ch13.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb
index ae055af..78febbf 100644
--- a/gcc/ada/par-ch2.adb
+++ b/gcc/ada/par-ch2.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -324,8 +324,7 @@ package body Ch2 is
(Identifier_Seen => Identifier_Seen,
Association => Assoc_Node,
Reserved_Words_OK =>
- Nam_In (Prag_Name, Name_Restriction_Warnings,
- Name_Restrictions));
+ Prag_Name in Name_Restriction_Warnings | Name_Restrictions);
if Arg_Count = 2 and then Import_Check_Required then
-- Here is where we cancel the SIS active status if this pragma
@@ -444,7 +443,7 @@ package body Ch2 is
P := P_Pragma;
if Nkind (P) /= N_Error
- and then Nam_In (Pragma_Name_Unmapped (P), Name_Assert, Name_Debug)
+ and then Pragma_Name_Unmapped (P) in Name_Assert | Name_Debug
then
Error_Msg_Name_1 := Pragma_Name_Unmapped (P);
Error_Msg_N
diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb
index 2b054b2..adaa3e2 100644
--- a/gcc/ada/par-ch3.adb
+++ b/gcc/ada/par-ch3.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -78,18 +78,24 @@ package body Ch3 is
-- it very unlikely that this will ever arise in practice.
procedure P_Declarative_Items
- (Decls : List_Id;
- Done : out Boolean;
- In_Spec : Boolean);
+ (Decls : List_Id;
+ Done : out Boolean;
+ Declare_Expression : Boolean;
+ In_Spec : Boolean);
-- Scans out a single declarative item, or, in the case of a declaration
-- with a list of identifiers, a list of declarations, one for each of the
-- identifiers in the list. The declaration or declarations scanned are
-- appended to the given list. Done indicates whether or not there may be
-- additional declarative items to scan. If Done is True, then a decision
-- has been made that there are no more items to scan. If Done is False,
- -- then there may be additional declarations to scan. In_Spec is true if
- -- we are scanning a package declaration, and is used to generate an
- -- appropriate message if a statement is encountered in such a context.
+ -- then there may be additional declarations to scan.
+ --
+ -- Declare_Expression is true if we are parsing a declare_expression, in
+ -- which case we want to suppress certain style checking.
+ --
+ -- In_Spec is true if we are scanning a package declaration, and is used to
+ -- generate an appropriate message if a statement is encountered in such a
+ -- context.
procedure P_Identifier_Declarations
(Decls : List_Id;
@@ -117,11 +123,12 @@ package body Ch3 is
procedure Check_Restricted_Expression (N : Node_Id) is
begin
- if Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor, N_And_Then, N_Or_Else) then
+ if Nkind (N) in N_Op_And | N_Op_Or | N_Op_Xor | N_And_Then | N_Or_Else
+ then
Check_Restricted_Expression (Left_Opnd (N));
Check_Restricted_Expression (Right_Opnd (N));
- elsif Nkind_In (N, N_In, N_Not_In)
+ elsif Nkind (N) in N_In | N_Not_In
and then Paren_Count (N) = 0
then
Error_Msg_N ("|this expression must be parenthesized!", N);
@@ -1480,6 +1487,32 @@ package body Ch3 is
Done := False;
return;
+ -- AI12-0275: Object renaming declaration without subtype_mark or
+ -- access_definition
+
+ elsif Token = Tok_Renames then
+ if Ada_Version < Ada_2020 then
+ Error_Msg_SC
+ ("object renaming without subtype is an Ada 202x feature");
+ Error_Msg_SC ("\compile with -gnat2020");
+ end if;
+
+ Scan; -- past renames
+
+ Decl_Node :=
+ New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
+ Set_Name (Decl_Node, P_Name);
+ Set_Defining_Identifier (Decl_Node, Idents (1));
+
+ P_Aspect_Specifications (Decl_Node, Semicolon => False);
+
+ T_Semicolon;
+
+ Append (Decl_Node, Decls);
+ Done := False;
+
+ return;
+
-- Otherwise we have an error situation
else
@@ -4284,7 +4317,8 @@ package body Ch3 is
-- Loop to scan out the declarations
loop
- P_Declarative_Items (Decls, Done, In_Spec => False);
+ P_Declarative_Items
+ (Decls, Done, Declare_Expression => False, In_Spec => False);
exit when Done;
end loop;
@@ -4311,16 +4345,20 @@ package body Ch3 is
-- then the scan is set past the next semicolon and Error is returned.
procedure P_Declarative_Items
- (Decls : List_Id;
- Done : out Boolean;
- In_Spec : Boolean)
+ (Decls : List_Id;
+ Done : out Boolean;
+ Declare_Expression : Boolean;
+ In_Spec : Boolean)
is
Scan_State : Saved_Scan_State;
begin
Done := False;
- if Style_Check then
+ -- In -gnatg mode, we don't want a "bad indentation" error inside a
+ -- declare_expression.
+
+ if Style_Check and not Declare_Expression then
Style.Check_Indentation;
end if;
@@ -4676,7 +4714,9 @@ package body Ch3 is
-- the scan pointer is repositioned past the next semicolon, and the scan
-- for declarative items continues.
- function P_Basic_Declarative_Items return List_Id is
+ function P_Basic_Declarative_Items
+ (Declare_Expression : Boolean) return List_Id
+ is
Decl : Node_Id;
Decls : List_Id;
Kind : Node_Kind;
@@ -4699,7 +4739,8 @@ package body Ch3 is
Decls := New_List;
loop
- P_Declarative_Items (Decls, Done, In_Spec => True);
+ P_Declarative_Items
+ (Decls, Done, Declare_Expression, In_Spec => True);
exit when Done;
end loop;
@@ -4724,12 +4765,20 @@ package body Ch3 is
Kind = N_Task_Body or else
Kind = N_Protected_Body
then
- Error_Msg ("proper body not allowed in package spec", Sloc (Decl));
+ if Declare_Expression then
+ Error_Msg
+ ("proper body not allowed in declare_expression",
+ Sloc (Decl));
+ else
+ Error_Msg
+ ("proper body not allowed in package spec",
+ Sloc (Decl));
+ end if;
-- Complete declaration of mangled subprogram body, for better
-- recovery if analysis is attempted.
- if Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body)
+ if Nkind (Decl) in N_Subprogram_Body | N_Package_Body | N_Task_Body
and then No (Handled_Statement_Sequence (Decl))
then
Set_Handled_Statement_Sequence (Decl,
@@ -4791,7 +4840,8 @@ package body Ch3 is
Dummy_Done : Boolean;
pragma Warnings (Off, Dummy_Done);
begin
- P_Declarative_Items (S, Dummy_Done, False);
+ P_Declarative_Items
+ (S, Dummy_Done, Declare_Expression => False, In_Spec => False);
end Skip_Declaration;
-----------------------------------------
diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb
index 355aeb8..9815ca1 100644
--- a/gcc/ada/par-ch4.adb
+++ b/gcc/ada/par-ch4.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -51,7 +51,7 @@ package body Ch4 is
-- or a type. For those attributes, a left parenthesis after the attribute
-- should not be analyzed as the beginning of a parameters list because it
-- may denote a slice operation (X'Img (1 .. 2)) or a type conversion
- -- (X'Class (Y)). The Ada 2012 attribute 'Old is in this category.
+ -- (X'Class (Y)).
-- Note: Loop_Entry is in this list because, although it can take an
-- optional argument (the loop name), we can't distinguish that at parse
@@ -72,23 +72,24 @@ package body Ch4 is
-- Local Subprograms --
-----------------------
- function P_Aggregate_Or_Paren_Expr return Node_Id;
- function P_Allocator return Node_Id;
- function P_Case_Expression_Alternative return Node_Id;
- function P_Iterated_Component_Association return Node_Id;
- function P_Record_Or_Array_Component_Association return Node_Id;
- function P_Factor return Node_Id;
- function P_Primary return Node_Id;
- function P_Relation return Node_Id;
- function P_Term return Node_Id;
+ function P_Aggregate_Or_Paren_Expr return Node_Id;
+ function P_Allocator return Node_Id;
+ function P_Case_Expression_Alternative return Node_Id;
+ function P_Iterated_Component_Association return Node_Id;
+ function P_Record_Or_Array_Component_Association return Node_Id;
+ function P_Factor return Node_Id;
+ function P_Primary return Node_Id;
+ function P_Relation return Node_Id;
+ function P_Term return Node_Id;
+ function P_Declare_Expression return Node_Id;
function P_Reduction_Attribute_Reference (S : Node_Id)
return Node_Id;
- function P_Binary_Adding_Operator return Node_Kind;
- function P_Logical_Operator return Node_Kind;
- function P_Multiplying_Operator return Node_Kind;
- function P_Relational_Operator return Node_Kind;
- function P_Unary_Adding_Operator return Node_Kind;
+ function P_Binary_Adding_Operator return Node_Kind;
+ function P_Logical_Operator return Node_Kind;
+ function P_Multiplying_Operator return Node_Kind;
+ function P_Relational_Operator return Node_Kind;
+ function P_Unary_Adding_Operator return Node_Kind;
procedure Bad_Range_Attribute (Loc : Source_Ptr);
-- Called to place complaint about bad range attribute at the given
@@ -107,11 +108,18 @@ package body Ch4 is
-- prefix. The current token is known to be an apostrophe and the
-- following token is known to be RANGE.
- function P_Unparen_Cond_Case_Quant_Expression return Node_Id;
- -- This function is called with Token pointing to IF, CASE, or FOR, in a
- -- context that allows a case, conditional, or quantified expression if
- -- it is surrounded by parentheses. If not surrounded by parentheses, the
- -- expression is still returned, but an error message is issued.
+ function P_Case_Expression return Node_Id;
+ -- Scans out a case expression. Called with Token pointing to the CASE
+ -- keyword, and returns pointing to the terminating right parent,
+ -- semicolon, or comma, but does not consume this terminating token.
+
+ function P_Unparen_Cond_Expr_Etc return Node_Id;
+ -- This function is called with Token pointing to IF, CASE, FOR, or
+ -- DECLARE, in a context that allows a conditional (if or case) expression,
+ -- a quantified expression, an iterated component association, or a declare
+ -- expression, if it is surrounded by parentheses. If not surrounded by
+ -- parentheses, the expression is still returned, but an error message is
+ -- issued.
-------------------------
-- Bad_Range_Attribute --
@@ -1385,7 +1393,7 @@ package body Ch4 is
if Token = Tok_Left_Bracket and then Ada_Version >= Ada_2020 then
Scan;
- -- Special case for null aggregate in Ada2020.
+ -- Special case for null aggregate in Ada 2020
if Token = Tok_Right_Bracket then
Scan; -- past ]
@@ -1690,8 +1698,10 @@ package body Ch4 is
Set_Component_Associations (Aggregate_Node, Assoc_List);
Set_Is_Homogeneous_Aggregate (Aggregate_Node);
Scan; -- past right bracket
+
if Token = Tok_Apostrophe then
Scan;
+
if Token = Tok_Identifier then
return P_Reduction_Attribute_Reference (Aggregate_Node);
end if;
@@ -1897,7 +1907,7 @@ package body Ch4 is
Logop := P_Logical_Operator;
Restore_Scan_State (Scan_State); -- to comma/semicolon
- if Nkind_In (Logop, N_And_Then, N_Or_Else) then
+ if Logop in N_And_Then | N_Or_Else then
Scan; -- past comma/semicolon
if Com then
@@ -1942,8 +1952,12 @@ package body Ch4 is
begin
-- Case of conditional, case or quantified expression
- if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then
- return P_Unparen_Cond_Case_Quant_Expression;
+ if Token = Tok_Case
+ or else Token = Tok_If
+ or else Token = Tok_For
+ or else Token = Tok_Declare
+ then
+ return P_Unparen_Cond_Expr_Etc;
-- Normal case, not case/conditional/quantified expression
@@ -2051,8 +2065,12 @@ package body Ch4 is
begin
-- Case of conditional, case or quantified expression
- if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then
- return P_Unparen_Cond_Case_Quant_Expression;
+ if Token = Tok_Case
+ or else Token = Tok_If
+ or else Token = Tok_For
+ or else Token = Tok_Declare
+ then
+ return P_Unparen_Cond_Expr_Etc;
-- Normal case, not one of the above expression types
@@ -2928,7 +2946,7 @@ package body Ch4 is
when Tok_At_Sign => -- AI12-0125 : target_name
if Ada_Version < Ada_2020 then
Error_Msg_SC ("target name is an Ada 202x feature");
- Error_Msg_SC ("\compile with -gnatX");
+ Error_Msg_SC ("\compile with -gnat2020");
end if;
Node1 := P_Name;
@@ -3384,26 +3402,86 @@ package body Ch4 is
-- ITERATED_COMPONENT_ASSOCIATION ::=
-- for DEFINING_IDENTIFIER in DISCRETE_CHOICE_LIST => EXPRESSION
+ -- for ITERATOR_SPECIFICATION => EXPRESSION
function P_Iterated_Component_Association return Node_Id is
Assoc_Node : Node_Id;
+ Id : Node_Id;
+ Iter_Spec : Node_Id;
+ Loop_Spec : Node_Id;
+ State : Saved_Scan_State;
-- Start of processing for P_Iterated_Component_Association
begin
Scan; -- past FOR
+ Save_Scan_State (State);
+
+ -- A lookahead is necessary to differentiate between the
+ -- Ada 2012 form with a choice list, and the Ada 202x element
+ -- iterator form, recognized by the presence of "OF". Other
+ -- disambiguation requires context and is done during semantic
+ -- analysis. Note that "for X in E" is syntactically ambiguous:
+ -- if E is a subtype indication this is a loop parameter spec,
+ -- while if E a name it is an iterator_specification, and the
+ -- disambiguation takes place during semantic analysis.
+ -- In addition, if "use" is present after the specification,
+ -- this is an Iterated_Element_Association that carries a
+ -- key_expression, and we generate the appropriate node.
+
+ Id := P_Defining_Identifier;
Assoc_Node :=
New_Node (N_Iterated_Component_Association, Prev_Token_Ptr);
- Set_Defining_Identifier (Assoc_Node, P_Defining_Identifier);
- T_In;
- Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List);
- TF_Arrow;
- Set_Expression (Assoc_Node, P_Expression);
+ if Token = Tok_In then
+ Set_Defining_Identifier (Assoc_Node, Id);
+ T_In;
+ Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List);
+
+ if Token = Tok_Use then
+
+ -- Key-expression is present, rewrite node as an
+ -- iterated_Element_Awwoiation.
+
+ Scan; -- past USE
+ Loop_Spec :=
+ New_Node (N_Loop_Parameter_Specification, Prev_Token_Ptr);
+ Set_Defining_Identifier (Loop_Spec, Id);
+ Set_Discrete_Subtype_Definition (Loop_Spec,
+ First (Discrete_Choices (Assoc_Node)));
+ Set_Loop_Parameter_Specification (Assoc_Node, Loop_Spec);
+ Set_Key_Expression (Assoc_Node, P_Expression);
+ end if;
+
+ TF_Arrow;
+ Set_Expression (Assoc_Node, P_Expression);
+
+ elsif Ada_Version >= Ada_2020
+ and then Token = Tok_Of
+ then
+ Restore_Scan_State (State);
+ Scan; -- past OF
+ Set_Defining_Identifier (Assoc_Node, Id);
+ Iter_Spec := P_Iterator_Specification (Id);
+ Set_Iterator_Specification (Assoc_Node, Iter_Spec);
+
+ if Token = Tok_Use then
+ Scan; -- past USE
+ -- This is an iterated_elenent_qssociation.
+
+ Assoc_Node :=
+ New_Node (N_Iterated_Element_Association, Prev_Token_Ptr);
+ Set_Iterator_Specification (Assoc_Node, Iter_Spec);
+ Set_Key_Expression (Assoc_Node, P_Expression);
+ end if;
+
+ TF_Arrow;
+ Set_Expression (Assoc_Node, P_Expression);
+ end if;
if Ada_Version < Ada_2020 then
Error_Msg_SC ("iterated component is an Ada 202x feature");
- Error_Msg_SC ("\compile with -gnatX");
+ Error_Msg_SC ("\compile with -gnat2020");
end if;
return Assoc_Node;
@@ -3440,7 +3518,7 @@ package body Ch4 is
(Loc : Source_Ptr;
Cond : Node_Id) return Node_Id
is
- Exprs : constant List_Id := New_List;
+ Exprs : constant List_Id := New_List;
Expr : Node_Id;
State : Saved_Scan_State;
Eptr : Source_Ptr;
@@ -3555,11 +3633,54 @@ package body Ch4 is
return If_Expr;
end P_If_Expression;
+ --------------------------
+ -- P_Declare_Expression --
+ --------------------------
+
+ -- DECLARE_EXPRESSION ::=
+ -- DECLARE {DECLARE_ITEM}
+ -- begin BODY_EXPRESSION
+
+ -- DECLARE_ITEM ::= OBJECT_DECLARATION
+ -- | OBJECT_RENAMING_DECLARATION
+
+ function P_Declare_Expression return Node_Id is
+ Loc : constant Source_Ptr := Token_Ptr;
+ begin
+ Scan; -- past DECLARE
+
+ declare
+ Actions : constant List_Id := P_Basic_Declarative_Items
+ (Declare_Expression => True);
+ -- Most declarative items allowed by P_Basic_Declarative_Items are
+ -- illegal; semantic analysis will deal with that.
+ begin
+ if Token = Tok_Begin then
+ Scan;
+ else
+ Error_Msg_SC -- CODEFIX
+ ("BEGIN expected!");
+ end if;
+
+ declare
+ Expression : constant Node_Id := P_Expression;
+ Result : constant Node_Id :=
+ Make_Expression_With_Actions (Loc, Actions, Expression);
+ begin
+ if Ada_Version < Ada_2020 then
+ Error_Msg ("declare_expression is an Ada 2020 feature", Loc);
+ end if;
+
+ return Result;
+ end;
+ end;
+ end P_Declare_Expression;
+
-----------------------
-- P_Membership_Test --
-----------------------
- -- MEMBERSHIP_CHOICE_LIST ::= MEMBERHIP_CHOICE {'|' MEMBERSHIP_CHOICE}
+ -- MEMBERSHIP_CHOICE_LIST ::= MEMBERSHIP_CHOICE {'|' MEMBERSHIP_CHOICE}
-- MEMBERSHIP_CHOICE ::= CHOICE_EXPRESSION | range | subtype_mark
procedure P_Membership_Test (N : Node_Id) is
@@ -3592,11 +3713,11 @@ package body Ch4 is
end if;
end P_Membership_Test;
- ------------------------------------------
- -- P_Unparen_Cond_Case_Quant_Expression --
- ------------------------------------------
+ -----------------------------
+ -- P_Unparen_Cond_Expr_Etc --
+ -----------------------------
- function P_Unparen_Cond_Case_Quant_Expression return Node_Id is
+ function P_Unparen_Cond_Expr_Etc return Node_Id is
Lparen : constant Boolean := Prev_Token = Tok_Left_Paren;
Result : Node_Id;
@@ -3645,6 +3766,15 @@ package body Ch4 is
Result := P_Iterated_Component_Association;
end if;
+ -- Declare expression
+
+ elsif Token = Tok_Declare then
+ Result := P_Declare_Expression;
+
+ if not (Lparen and then Token = Tok_Right_Paren) then
+ Error_Msg_N ("declare expression must be parenthesized!", Result);
+ end if;
+
-- No other possibility should exist (caller was supposed to check)
else
@@ -3654,6 +3784,6 @@ package body Ch4 is
-- Return expression (possibly after having given message)
return Result;
- end P_Unparen_Cond_Case_Quant_Expression;
+ end P_Unparen_Cond_Expr_Etc;
end Ch4;
diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb
index 426bbd5..5b002c4 100644
--- a/gcc/ada/par-ch5.adb
+++ b/gcc/ada/par-ch5.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -62,11 +62,6 @@ package body Ch5 is
-- the N_Identifier node for the label on the loop. If Loop_Name is
-- Empty on entry (the default), then the for statement is unlabeled.
- function P_Iterator_Specification (Def_Id : Node_Id) return Node_Id;
- -- Parse an iterator specification. The defining identifier has already
- -- been scanned, as it is the common prefix between loop and iterator
- -- specification.
-
function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
-- Parse loop statement. If Loop_Name is non-Empty on entry, it is
-- the N_Identifier node for the label on the loop. If Loop_Name is
@@ -1312,9 +1307,9 @@ package body Ch5 is
else
if Style_Check and then Paren_Count (Cond) > 0 then
- if not Nkind_In (Cond, N_If_Expression,
- N_Case_Expression,
- N_Quantified_Expression)
+ if Nkind (Cond) not in N_If_Expression
+ | N_Case_Expression
+ | N_Quantified_Expression
or else Paren_Count (Cond) > 1
then
Style.Check_Xtra_Parens (First_Sloc (Cond));
@@ -1660,6 +1655,7 @@ package body Ch5 is
-- LOOP_PARAMETER_SPECIFICATION ::=
-- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
+ -- [Iterator_Filter]
-- Error recovery: cannot raise Error_Resync
@@ -1715,6 +1711,15 @@ package body Ch5 is
Set_Discrete_Subtype_Definition
(Loop_Param_Specification_Node, P_Discrete_Subtype_Definition);
+
+ if Ada_Version >= Ada_2020
+ and then Token = Tok_When
+ then
+ Scan; -- past WHEN
+ Set_Iterator_Filter
+ (Loop_Param_Specification_Node, P_Condition);
+ end if;
+
return Loop_Param_Specification_Node;
exception
@@ -1767,6 +1772,15 @@ package body Ch5 is
end if;
Set_Name (Node1, P_Name);
+
+ if Ada_Version >= Ada_2020
+ and then Token = Tok_When
+ then
+ Scan; -- past WHEN
+ Set_Iterator_Filter
+ (Node1, P_Condition);
+ end if;
+
return Node1;
end P_Iterator_Specification;
diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb
index 8445a4e..1ff7950 100644
--- a/gcc/ada/par-ch6.adb
+++ b/gcc/ada/par-ch6.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -707,9 +707,6 @@ package body Ch6 is
else
Scan_Body_Or_Expression_Function : declare
- Body_Is_Hidden_In_SPARK : Boolean;
- Hidden_Region_Start : Source_Ptr;
-
function Likely_Expression_Function return Boolean;
-- Returns True if we have a probable case of an expression
-- function omitting the parentheses, if so, returns True
@@ -886,9 +883,9 @@ package body Ch6 is
-- with syntactic parentheses.
if not (Paren_Count (Expr) /= 0
- or else Nkind_In (Expr, N_Aggregate,
- N_Extension_Aggregate,
- N_Quantified_Expression))
+ or else Nkind (Expr) in N_Aggregate
+ | N_Extension_Aggregate
+ | N_Quantified_Expression)
then
Error_Msg
("expression function must be enclosed in "
@@ -942,25 +939,7 @@ package body Ch6 is
Set_Aspect_Specifications (Body_Node, Aspects);
end if;
- -- In SPARK, a HIDE directive can be placed at the beginning
- -- of a subprogram implementation, thus hiding the
- -- subprogram body from SPARK tool-set. No violation of the
- -- SPARK restriction should be issued on nodes in a hidden
- -- part, which is obtained by marking such hidden parts.
-
- if Token = Tok_SPARK_Hide then
- Body_Is_Hidden_In_SPARK := True;
- Hidden_Region_Start := Token_Ptr;
- Scan; -- past HIDE directive
- else
- Body_Is_Hidden_In_SPARK := False;
- end if;
-
Parse_Decls_Begin_End (Body_Node);
-
- if Body_Is_Hidden_In_SPARK then
- Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr);
- end if;
end if;
return Body_Node;
@@ -980,6 +959,16 @@ package body Ch6 is
-- the collected aspects, if any, to the body.
if Token = Tok_Is then
+
+ -- If the subprogram is a procedure and already has a
+ -- specification, we can't define another.
+
+ if Nkind (Specification (Decl_Node)) = N_Procedure_Specification
+ and then Null_Present (Specification (Decl_Node))
+ then
+ Error_Msg_AP ("null procedure cannot have a body");
+ end if;
+
Scan;
goto Subprogram_Body;
@@ -1867,6 +1856,7 @@ package body Ch6 is
if Token = Tok_Colon_Equal then
Scan; -- past :=
Set_Expression (Decl_Node, P_Expression_No_Right_Paren);
+ Set_Has_Init_Expression (Decl_Node);
end if;
return Decl_Node;
diff --git a/gcc/ada/par-ch7.adb b/gcc/ada/par-ch7.adb
index c8150a4..9645250 100644
--- a/gcc/ada/par-ch7.adb
+++ b/gcc/ada/par-ch7.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -115,10 +115,6 @@ package body Ch7 is
-- Dummy node to attach aspect specifications to until we properly
-- figure out where they eventually belong.
- Body_Is_Hidden_In_SPARK : Boolean;
- Private_Part_Is_Hidden_In_SPARK : Boolean;
- Hidden_Region_Start : Source_Ptr;
-
begin
Push_Scope_Stack;
Scopes (Scope.Last).Etyp := E_Name;
@@ -185,25 +181,7 @@ package body Ch7 is
Move_Aspects (From => Dummy_Node, To => Package_Node);
end if;
- -- In SPARK, a HIDE directive can be placed at the beginning of a
- -- package implementation, thus hiding the package body from SPARK
- -- tool-set. No violation of the SPARK restriction should be
- -- issued on nodes in a hidden part, which is obtained by marking
- -- such hidden parts.
-
- if Token = Tok_SPARK_Hide then
- Body_Is_Hidden_In_SPARK := True;
- Hidden_Region_Start := Token_Ptr;
- Scan; -- past HIDE directive
- else
- Body_Is_Hidden_In_SPARK := False;
- end if;
-
Parse_Decls_Begin_End (Package_Node);
-
- if Body_Is_Hidden_In_SPARK then
- Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr);
- end if;
end if;
-- Cases other than Package_Body
@@ -287,7 +265,8 @@ package body Ch7 is
Set_Defining_Unit_Name (Specification_Node, Name_Node);
Set_Visible_Declarations
- (Specification_Node, P_Basic_Declarative_Items);
+ (Specification_Node,
+ P_Basic_Declarative_Items (Declare_Expression => False));
if Token = Tok_Private then
Error_Msg_Col := Scopes (Scope.Last).Ecol;
@@ -303,26 +282,9 @@ package body Ch7 is
Scan; -- past PRIVATE
- if Token = Tok_SPARK_Hide then
- Private_Part_Is_Hidden_In_SPARK := True;
- Hidden_Region_Start := Token_Ptr;
- Scan; -- past HIDE directive
- else
- Private_Part_Is_Hidden_In_SPARK := False;
- end if;
-
Set_Private_Declarations
- (Specification_Node, P_Basic_Declarative_Items);
-
- -- In SPARK, a HIDE directive can be placed at the beginning
- -- of a private part, thus hiding all declarations in the
- -- private part from SPARK tool-set. No violation of the
- -- SPARK restriction should be issued on nodes in a hidden
- -- part, which is obtained by marking such hidden parts.
-
- if Private_Part_Is_Hidden_In_SPARK then
- Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr);
- end if;
+ (Specification_Node,
+ P_Basic_Declarative_Items (Declare_Expression => False));
-- Deal gracefully with multiple PRIVATE parts
@@ -330,8 +292,10 @@ package body Ch7 is
Error_Msg_SC
("only one private part allowed per package");
Scan; -- past PRIVATE
- Append_List (P_Basic_Declarative_Items,
- Private_Declarations (Specification_Node));
+ Append_List
+ (P_Basic_Declarative_Items
+ (Declare_Expression => False),
+ Private_Declarations (Specification_Node));
end loop;
end if;
diff --git a/gcc/ada/par-ch8.adb b/gcc/ada/par-ch8.adb
index e7fd1dc..cfcc6e0 100644
--- a/gcc/ada/par-ch8.adb
+++ b/gcc/ada/par-ch8.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb
index d6c6dfc..2672e52 100644
--- a/gcc/ada/par-ch9.adb
+++ b/gcc/ada/par-ch9.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb
index 705b7fb..4beb051 100644
--- a/gcc/ada/par-endh.adb
+++ b/gcc/ada/par-endh.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/par-labl.adb b/gcc/ada/par-labl.adb
index 899905e..6be1e47 100644
--- a/gcc/ada/par-labl.adb
+++ b/gcc/ada/par-labl.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/par-load.adb b/gcc/ada/par-load.adb
index 70bc5cb..a1857dc 100644
--- a/gcc/ada/par-load.adb
+++ b/gcc/ada/par-load.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index 65ee035..265f187 100644
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -102,10 +102,6 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
-- are some obsolescent features (e.g. character replacements) which are
-- handled at parse time.
--
- -- SPARK must be processed at parse time, since this restriction controls
- -- whether the scanner recognizes a spark HIDE directive formatted as an
- -- Ada comment (and generates a Tok_SPARK_Hide token for the directive).
- --
-- No_Dependence must be processed at parse time, since otherwise it gets
-- handled too late.
--
@@ -173,7 +169,7 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
begin
if Nkind (Expression (Arg)) /= N_Identifier
- or else not Nam_In (Chars (Argx), Name_On, Name_Off)
+ or else Chars (Argx) not in Name_On | Name_Off
then
Error_Msg_Name_2 := Name_On;
Error_Msg_Name_3 := Name_Off;
@@ -257,12 +253,11 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
Restriction_Warnings (No_Obsolescent_Features) :=
Prag_Id = Pragma_Restriction_Warnings;
- when Name_SPARK
- | Name_SPARK_05
- =>
- Set_Restriction (SPARK_05, Pragma_Node);
- Restriction_Warnings (SPARK_05) :=
- Prag_Id = Pragma_Restriction_Warnings;
+ when Name_SPARK_05 =>
+ Error_Msg_Name_1 := Chars (Expr);
+ Error_Msg_N
+ ("??% restriction is obsolete and ignored, consider " &
+ "using 'S'P'A'R'K_'Mode and gnatprove instead", Arg);
when others =>
null;
@@ -440,7 +435,7 @@ begin
if Chars (Expression (Arg1)) = Name_On then
Extensions_Allowed := True;
- Ada_Version := Ada_2012;
+ Ada_Version := Ada_Version_Type'Last;
else
Extensions_Allowed := False;
Ada_Version := Ada_Version_Explicit;
@@ -1114,7 +1109,7 @@ begin
-- DETAILS ::= static_string_EXPRESSION
-- DETAILS ::= On | Off, static_string_EXPRESSION
- -- TOOL_NAME ::= GNAT | GNATProve
+ -- TOOL_NAME ::= GNAT | GNATprove
-- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
@@ -1157,11 +1152,11 @@ begin
return Nkind (Arg1) = N_Identifier
-- Return True if the tool name is GNAT, and we're not in
- -- GNATprove or CodePeer or ASIS mode...
+ -- GNATprove or CodePeer mode...
and then ((Chars (Arg1) = Name_Gnat
and then not
- (CodePeer_Mode or GNATprove_Mode or ASIS_Mode))
+ (CodePeer_Mode or GNATprove_Mode))
-- or if the tool name is GNATprove, and we're in GNATprove
-- mode.
@@ -1315,65 +1310,63 @@ begin
when Pragma_Abort_Defer
| Pragma_Abstract_State
- | Pragma_Acc_Data
- | Pragma_Acc_Kernels
- | Pragma_Acc_Loop
- | Pragma_Acc_Parallel
| Pragma_Aggregate_Individually_Assign
- | Pragma_Async_Readers
- | Pragma_Async_Writers
- | Pragma_Assertion_Policy
- | Pragma_Assume
- | Pragma_Assume_No_Invalid_Values
| Pragma_All_Calls_Remote
| Pragma_Allow_Integer_Address
| Pragma_Annotate
| Pragma_Assert
| Pragma_Assert_And_Cut
+ | Pragma_Assertion_Policy
+ | Pragma_Assume
+ | Pragma_Assume_No_Invalid_Values
+ | Pragma_Async_Readers
+ | Pragma_Async_Writers
| Pragma_Asynchronous
| Pragma_Atomic
| Pragma_Atomic_Components
| Pragma_Attach_Handler
| Pragma_Attribute_Definition
- | Pragma_Check
- | Pragma_Check_Float_Overflow
- | Pragma_Check_Name
- | Pragma_Check_Policy
- | Pragma_Compile_Time_Error
- | Pragma_Compile_Time_Warning
- | Pragma_Constant_After_Elaboration
- | Pragma_Contract_Cases
- | Pragma_Convention_Identifier
| Pragma_CPP_Class
| Pragma_CPP_Constructor
| Pragma_CPP_Virtual
| Pragma_CPP_Vtable
| Pragma_CPU
+ | Pragma_CUDA_Execute
+ | Pragma_CUDA_Global
| Pragma_C_Pass_By_Copy
+ | Pragma_Check
+ | Pragma_Check_Float_Overflow
+ | Pragma_Check_Name
+ | Pragma_Check_Policy
| Pragma_Comment
| Pragma_Common_Object
+ | Pragma_Compile_Time_Error
+ | Pragma_Compile_Time_Warning
| Pragma_Complete_Representation
| Pragma_Complex_Representation
| Pragma_Component_Alignment
+ | Pragma_Constant_After_Elaboration
+ | Pragma_Contract_Cases
| Pragma_Controlled
| Pragma_Convention
+ | Pragma_Convention_Identifier
| Pragma_Deadline_Floor
| Pragma_Debug_Policy
- | Pragma_Depends
- | Pragma_Detect_Blocking
| Pragma_Default_Initial_Condition
| Pragma_Default_Scalar_Storage_Order
| Pragma_Default_Storage_Pool
+ | Pragma_Depends
+ | Pragma_Detect_Blocking
| Pragma_Disable_Atomic_Synchronization
| Pragma_Discard_Names
| Pragma_Dispatching_Domain
| Pragma_Effective_Reads
| Pragma_Effective_Writes
- | Pragma_Eliminate
| Pragma_Elaborate
| Pragma_Elaborate_All
| Pragma_Elaborate_Body
| Pragma_Elaboration_Checks
+ | Pragma_Eliminate
| Pragma_Enable_Atomic_Synchronization
| Pragma_Export
| Pragma_Export_Function
@@ -1385,8 +1378,8 @@ begin
| Pragma_Extensions_Visible
| Pragma_External
| Pragma_External_Name_Casing
- | Pragma_Favor_Top_Level
| Pragma_Fast_Math
+ | Pragma_Favor_Top_Level
| Pragma_Finalize_Storage_Only
| Pragma_Ghost
| Pragma_Global
@@ -1411,8 +1404,8 @@ begin
| Pragma_Interface
| Pragma_Interface_Name
| Pragma_Interrupt_Handler
- | Pragma_Interrupt_State
| Pragma_Interrupt_Priority
+ | Pragma_Interrupt_State
| Pragma_Invariant
| Pragma_Keep_Names
| Pragma_License
@@ -1446,28 +1439,28 @@ begin
| Pragma_No_Tagged_Streams
| Pragma_Normalize_Scalars
| Pragma_Obsolescent
- | Pragma_Ordered
| Pragma_Optimize
| Pragma_Optimize_Alignment
+ | Pragma_Ordered
| Pragma_Overflow_Mode
| Pragma_Overriding_Renamings
| Pragma_Pack
| Pragma_Part_Of
| Pragma_Partition_Elaboration_Policy
| Pragma_Passive
- | Pragma_Preelaborable_Initialization
- | Pragma_Polling
- | Pragma_Prefix_Exception_Messages
| Pragma_Persistent_BSS
+ | Pragma_Polling
| Pragma_Post
- | Pragma_Postcondition
| Pragma_Post_Class
+ | Pragma_Postcondition
| Pragma_Pre
+ | Pragma_Pre_Class
| Pragma_Precondition
| Pragma_Predicate
| Pragma_Predicate_Failure
+ | Pragma_Preelaborable_Initialization
| Pragma_Preelaborate
- | Pragma_Pre_Class
+ | Pragma_Prefix_Exception_Messages
| Pragma_Priority
| Pragma_Priority_Specific_Dispatching
| Pragma_Profile
@@ -1478,6 +1471,8 @@ begin
| Pragma_Pure
| Pragma_Pure_Function
| Pragma_Queuing_Policy
+ | Pragma_Rational
+ | Pragma_Ravenscar
| Pragma_Refined_Depends
| Pragma_Refined_Global
| Pragma_Refined_Post
@@ -1486,11 +1481,10 @@ begin
| Pragma_Remote_Access_Type
| Pragma_Remote_Call_Interface
| Pragma_Remote_Types
- | Pragma_Restricted_Run_Time
- | Pragma_Rational
- | Pragma_Ravenscar
| Pragma_Rename_Pragma
+ | Pragma_Restricted_Run_Time
| Pragma_Reviewable
+ | Pragma_SPARK_Mode
| Pragma_Secondary_Stack_Size
| Pragma_Share_Generic
| Pragma_Shared
@@ -1498,10 +1492,9 @@ begin
| Pragma_Short_Circuit_And_Or
| Pragma_Short_Descriptors
| Pragma_Simple_Storage_Pool_Type
- | Pragma_SPARK_Mode
+ | Pragma_Static_Elaboration_Desired
| Pragma_Storage_Size
| Pragma_Storage_Unit
- | Pragma_Static_Elaboration_Desired
| Pragma_Stream_Convert
| Pragma_Subtitle
| Pragma_Suppress
@@ -1531,12 +1524,12 @@ begin
| Pragma_Unsuppress
| Pragma_Unused
| Pragma_Use_VADS_Size
+ | Pragma_Validity_Checks
| Pragma_Volatile
| Pragma_Volatile_Components
| Pragma_Volatile_Full_Access
| Pragma_Volatile_Function
| Pragma_Weak_External
- | Pragma_Validity_Checks
=>
null;
diff --git a/gcc/ada/par-sync.adb b/gcc/ada/par-sync.adb
index 3bc900f..4df97ac 100644
--- a/gcc/ada/par-sync.adb
+++ b/gcc/ada/par-sync.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/par-tchk.adb b/gcc/ada/par-tchk.adb
index 9626c06..8eb705e 100644
--- a/gcc/ada/par-tchk.adb
+++ b/gcc/ada/par-tchk.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb
index 6379c4a..1f26075 100644
--- a/gcc/ada/par-util.adb
+++ b/gcc/ada/par-util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -181,7 +181,7 @@ package body Util is
if Ada_Version = Ada_95
and then Warn_On_Ada_2005_Compatibility
then
- if Nam_In (Token_Name, Name_Overriding, Name_Synchronized)
+ if Token_Name in Name_Overriding | Name_Synchronized
or else (Token_Name = Name_Interface
and then Prev_Token /= Tok_Pragma)
then
@@ -276,7 +276,7 @@ package body Util is
-- If we have a right paren, then that is taken as ending the list
-- i.e. no comma is present.
- -- Ditto for a right bracket in Ada2020.
+ -- Ditto for a right bracket in Ada 2020.
elsif Token = Tok_Right_Paren
or else (Token = Tok_Right_Bracket and then Ada_Version >= Ada_2020)
diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb
index 0e3fa40..1dee1e7 100644
--- a/gcc/ada/par.adb
+++ b/gcc/ada/par.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -679,7 +679,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- begin message if indeed the BEGIN is missing.
function P_Array_Type_Definition return Node_Id;
- function P_Basic_Declarative_Items return List_Id;
function P_Constraint_Opt return Node_Id;
function P_Declarative_Part return List_Id;
function P_Discrete_Choice_List return List_Id;
@@ -694,6 +693,15 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
function P_Subtype_Mark_Resync return Node_Id;
function P_Unknown_Discriminant_Part_Opt return Boolean;
+ function P_Basic_Declarative_Items
+ (Declare_Expression : Boolean) return List_Id;
+ -- Used to parse the declarative items in a package visible or
+ -- private part (in which case Declare_Expression is False), and
+ -- the declare_items of a declare_expression (in which case
+ -- Declare_Expression is True). Declare_Expression is used to
+ -- affect the wording of error messages, and to control style
+ -- checking.
+
function P_Access_Definition
(Null_Exclusion_Present : Boolean) return Node_Id;
-- Ada 2005 (AI-231/AI-254): The caller parses the null-exclusion part
@@ -787,11 +795,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
function P_Simple_Expression return Node_Id;
function P_Simple_Expression_Or_Range_Attribute return Node_Id;
- function P_Case_Expression return Node_Id;
- -- Scans out a case expression. Called with Token pointing to the CASE
- -- keyword, and returns pointing to the terminating right parent,
- -- semicolon, or comma, but does not consume this terminating token.
-
function P_Expression_If_OK return Node_Id;
-- Scans out an expression allowing an unparenthesized case expression,
-- if expression, or quantified expression to appear without enclosing
@@ -839,6 +842,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- conditional expression and passes it as an argument. This form of
-- the call does not check for a following right parenthesis.
+ function P_Iterator_Specification (Def_Id : Node_Id) return Node_Id;
+ -- Parse an iterator specification. The defining identifier has already
+ -- been scanned, as it is the common prefix between loop and iterator
+ -- specification.
+
function P_Loop_Parameter_Specification return Node_Id;
-- Used in loop constructs and quantified expressions.
diff --git a/gcc/ada/par.ads b/gcc/ada/par.ads
index 10d58bc..10d0e40 100644
--- a/gcc/ada/par.ads
+++ b/gcc/ada/par.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb
index 0fe248c..1579653 100644
--- a/gcc/ada/par_sco.adb
+++ b/gcc/ada/par_sco.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -459,9 +459,9 @@ package body Par_SCO is
function Is_Logical_Operator (N : Node_Id) return Tristate is
begin
- if Nkind_In (N, N_And_Then, N_Op_Not, N_Or_Else) then
+ if Nkind (N) in N_And_Then | N_Op_Not | N_Or_Else then
return True;
- elsif Nkind_In (N, N_Op_And, N_Op_Or) then
+ elsif Nkind (N) in N_Op_And | N_Op_Or then
return Unknown;
else
return False;
@@ -599,9 +599,9 @@ package body Par_SCO is
else
L := Left_Opnd (N);
- if Nkind_In (N, N_Op_Or, N_Or_Else) then
+ if Nkind (N) in N_Op_Or | N_Or_Else then
C1 := '|';
- else pragma Assert (Nkind_In (N, N_Op_And, N_And_Then));
+ else pragma Assert (Nkind (N) in N_Op_And | N_And_Then);
C1 := '&';
end if;
end if;
@@ -688,9 +688,9 @@ package body Par_SCO is
-- Doesn't this requirement of using First_Sloc need to be
-- documented in the spec ???
- if Nkind_In (Parent (N), N_Accept_Alternative,
- N_Delay_Alternative,
- N_Terminate_Alternative)
+ if Nkind (Parent (N)) in N_Accept_Alternative
+ | N_Delay_Alternative
+ | N_Terminate_Alternative
then
Loc := First_Sloc (N);
else
@@ -1747,7 +1747,7 @@ package body Par_SCO is
-- chain.
Current_Dominant := No_Dominant;
- Extend_Statement_Sequence (N, Typ => ' ');
+ Extend_Statement_Sequence (N, Typ => 'X');
-- For the case of an expression-function, collect decisions
-- embedded in the expression now.
diff --git a/gcc/ada/par_sco.ads b/gcc/ada/par_sco.ads
index 97874ca..8cb2118 100644
--- a/gcc/ada/par_sco.ads
+++ b/gcc/ada/par_sco.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/pprint.adb b/gcc/ada/pprint.adb
index 54dbae5..c00962d 100644
--- a/gcc/ada/pprint.adb
+++ b/gcc/ada/pprint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -329,12 +329,10 @@ package body Pprint is
(Constraint (Subtype_Indication (N)));
if List_Length (Ranges) = 1
- and then
- Nkind_In
- (First (Ranges),
- N_Range,
- N_Real_Range_Specification,
- N_Signed_Integer_Type_Definition)
+ and then Nkind (First (Ranges)) in
+ N_Range |
+ N_Real_Range_Specification |
+ N_Signed_Integer_Type_Definition
then
if Id = Attribute_First then
return
@@ -765,8 +763,7 @@ package body Pprint is
-- If argument does not already account for a closing
-- parenthesis, count one here.
- if not Nkind_In (Right, N_Aggregate,
- N_Quantified_Expression)
+ if Nkind (Right) not in N_Aggregate | N_Quantified_Expression
then
Append_Paren := Append_Paren + 1;
end if;
diff --git a/gcc/ada/pprint.ads b/gcc/ada/pprint.ads
index f2ffcb2..4b8bd9c 100644
--- a/gcc/ada/pprint.ads
+++ b/gcc/ada/pprint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb
index 8549f79..044fe20 100644
--- a/gcc/ada/prep.adb
+++ b/gcc/ada/prep.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/prep.ads b/gcc/ada/prep.ads
index f270646..5ee6c49 100644
--- a/gcc/ada/prep.ads
+++ b/gcc/ada/prep.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/prepcomp.adb b/gcc/ada/prepcomp.adb
index 0b93314..61628ba 100644
--- a/gcc/ada/prepcomp.adb
+++ b/gcc/ada/prepcomp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/prepcomp.ads b/gcc/ada/prepcomp.ads
index 2cc7d1e..de6db1b 100644
--- a/gcc/ada/prepcomp.ads
+++ b/gcc/ada/prepcomp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/put_scos.adb b/gcc/ada/put_scos.adb
index 5a22237..3b02468 100644
--- a/gcc/ada/put_scos.adb
+++ b/gcc/ada/put_scos.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/put_scos.ads b/gcc/ada/put_scos.ads
index be8abb3..3b1a7bc 100644
--- a/gcc/ada/put_scos.ads
+++ b/gcc/ada/put_scos.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c
index 3b6c21f..1446bfa 100644
--- a/gcc/ada/raise-gcc.c
+++ b/gcc/ada/raise-gcc.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -1611,7 +1611,7 @@ __gnat_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame,
/* Define __gnat_personality_v0 for convenience */
-PERSONALITY_STORAGE _Unwind_Reason_Code
+PERSONALITY_STORAGE ATTRIBUTE_UNUSED _Unwind_Reason_Code
__gnat_personality_v0 (version_arg_t version_arg,
phases_arg_t phases_arg,
_Unwind_Exception_Class uw_exception_class,
diff --git a/gcc/ada/raise.c b/gcc/ada/raise.c
index bf8a879..0454c20 100644
--- a/gcc/ada/raise.c
+++ b/gcc/ada/raise.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/raise.h b/gcc/ada/raise.h
index 89a24b1..2e42656 100644
--- a/gcc/ada/raise.h
+++ b/gcc/ada/raise.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/repinfo-input.adb b/gcc/ada/repinfo-input.adb
index 92ca510..e00fa1d 100644
--- a/gcc/ada/repinfo-input.adb
+++ b/gcc/ada/repinfo-input.adb
@@ -6,23 +6,17 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2018-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
+-- 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 distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
@@ -36,13 +30,12 @@ with Namet; use Namet;
with Output; use Output;
with Snames; use Snames;
with Table;
+with Ttypes;
package body Repinfo.Input is
- SSU : constant := 8;
- -- Value for Storage_Unit, we do not want to get this from TTypes, since
- -- this introduces problematic dependencies in ASIS, and in any case this
- -- value is assumed to be 8 for the implementation of the DDA.
+ SSU : Pos renames Ttypes.System_Storage_Unit;
+ -- Value for Storage_Unit
type JSON_Entity_Kind is (JE_Record_Type, JE_Array_Type, JE_Other);
-- Kind of an entiy
diff --git a/gcc/ada/repinfo-input.ads b/gcc/ada/repinfo-input.ads
index e418feb..ead9a4b 100644
--- a/gcc/ada/repinfo-input.ads
+++ b/gcc/ada/repinfo-input.ads
@@ -6,23 +6,17 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2018-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
+-- 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 distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb
index 219fa3b..dff3272 100644
--- a/gcc/ada/repinfo.adb
+++ b/gcc/ada/repinfo.adb
@@ -6,23 +6,17 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
+-- 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 distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
@@ -30,23 +24,25 @@
------------------------------------------------------------------------------
with Alloc;
-with Atree; use Atree;
-with Casing; use Casing;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Lib; use Lib;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Output; use Output;
-with Sem_Aux; use Sem_Aux;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with Stringt; use Stringt;
+with Atree; use Atree;
+with Casing; use Casing;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Output; use Output;
+with Sem_Aux; use Sem_Aux;
+with Sem_Eval; use Sem_Eval;
+with Sinfo; use Sinfo;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stringt; use Stringt;
with Table;
-with Uname; use Uname;
-with Urealp; use Urealp;
+with Ttypes;
+with Uname; use Uname;
+with Urealp; use Urealp;
with Ada.Unchecked_Conversion;
@@ -54,18 +50,15 @@ with GNAT.HTable;
package body Repinfo is
- SSU : constant := 8;
- -- Value for Storage_Unit, we do not want to get this from TTypes, since
- -- this introduces problematic dependencies in ASIS, and in any case this
- -- value is assumed to be 8 for the implementation of the DDA.
+ SSU : Pos renames Ttypes.System_Storage_Unit;
+ -- Value for Storage_Unit
---------------------------------------
-- Representation of GCC Expressions --
---------------------------------------
-- A table internal to this unit is used to hold the values of back
- -- annotated expressions. This table is written out by -gnatt and read
- -- back in for ASIS processing.
+ -- annotated expressions.
-- Node values are stored as Uint values using the negative of the node
-- index in this table. Constants appear as non-negative Uint values.
@@ -79,7 +72,7 @@ package body Repinfo is
-- The following representation clause ensures that the above record
-- has no holes. We do this so that when instances of this record are
- -- written by Tree_Gen, we do not write uninitialized values to the file.
+ -- written, we do not write uninitialized values to the file.
for Exp_Node use record
Expr at 0 range 0 .. 31;
@@ -148,7 +141,7 @@ package body Repinfo is
function Back_End_Layout return Boolean;
-- Test for layout mode, True = back end, False = front end. This function
-- is used rather than checking the configuration parameter because we do
- -- not want Repinfo to depend on Targparm (for ASIS)
+ -- not want Repinfo to depend on Targparm.
procedure List_Entities
(Ent : Entity_Id;
@@ -534,9 +527,9 @@ package body Repinfo is
List_Entities (E, Bytes_Big_Endian, True);
- elsif Ekind_In (E, E_Entry,
- E_Entry_Family,
- E_Subprogram_Type)
+ elsif Ekind (E) in E_Entry
+ | E_Entry_Family
+ | E_Subprogram_Type
then
if List_Representation_Info_Mechanisms then
List_Subprogram_Info (E);
@@ -565,9 +558,9 @@ package body Repinfo is
-- Note that formals are not annotated so we skip them here
- elsif Ekind_In (E, E_Constant,
- E_Loop_Parameter,
- E_Variable)
+ elsif Ekind (E) in E_Constant
+ | E_Loop_Parameter
+ | E_Variable
then
if List_Representation_Info >= 2 then
List_Object_Info (E);
@@ -585,12 +578,12 @@ package body Repinfo is
-- Recurse into bodies
- elsif Ekind_In (E, E_Package_Body,
- E_Protected_Body,
- E_Protected_Type,
- E_Subprogram_Body,
- E_Task_Body,
- E_Task_Type)
+ elsif Ekind (E) in E_Package_Body
+ | E_Protected_Body
+ | E_Protected_Type
+ | E_Subprogram_Body
+ | E_Task_Body
+ | E_Task_Type
then
List_Entities (E, Bytes_Big_Endian);
@@ -601,7 +594,7 @@ package body Repinfo is
end if;
end if;
- E := Next_Entity (E);
+ Next_Entity (E);
end loop;
-- For a package body, the entities of the visible subprograms are
@@ -831,36 +824,9 @@ package body Repinfo is
-------------------------
procedure List_Linker_Section (Ent : Entity_Id) is
- function Expr_Value_S (N : Node_Id) return Node_Id;
- -- Returns the folded value of the expression. This function is called
- -- in instances where it has already been determined that the expression
- -- is static or its value is known at compile time. This version is used
- -- for string types and returns the corresponding N_String_Literal node.
- -- NOTE: This is an exact copy of Sem_Eval.Expr_Value_S. Licensing stops
- -- Repinfo from within Sem_Eval. Once ASIS is removed, and the licenses
- -- are modified, Repinfo should be able to rely on Sem_Eval.
-
- ------------------
- -- Expr_Value_S --
- ------------------
-
- function Expr_Value_S (N : Node_Id) return Node_Id is
- begin
- if Nkind (N) = N_String_Literal then
- return N;
- else
- pragma Assert (Ekind (Entity (N)) = E_Constant);
- return Expr_Value_S (Constant_Value (Entity (N)));
- end if;
- end Expr_Value_S;
-
- -- Local variables
-
Args : List_Id;
Sect : Node_Id;
- -- Start of processing for List_Linker_Section
-
begin
if Present (Linker_Section_Pragma (Ent)) then
Args := Pragma_Argument_Associations (Linker_Section_Pragma (Ent));
@@ -1040,10 +1006,12 @@ package body Repinfo is
Comp := First_Component_Or_Discriminant (Ent);
while Present (Comp) loop
- -- Skip discriminant in unchecked union (since it is not there!)
+ -- Skip a completely hidden discriminant or a discriminant in an
+ -- unchecked union (since it is not there).
if Ekind (Comp) = E_Discriminant
- and then Is_Unchecked_Union (Ent)
+ and then (Is_Completely_Hidden (Comp)
+ or else Is_Unchecked_Union (Ent))
then
goto Continue;
end if;
@@ -1312,10 +1280,12 @@ package body Repinfo is
Comp := First_Component_Or_Discriminant (Ent);
while Present (Comp) loop
- -- Skip discriminant in unchecked union (since it is not there!)
+ -- Skip a completely hidden discriminant or a discriminant in an
+ -- unchecked union (since it is not there).
if Ekind (Comp) = E_Discriminant
- and then Is_Unchecked_Union (Ent)
+ and then (Is_Completely_Hidden (Comp)
+ or else Is_Unchecked_Union (Ent))
then
goto Continue;
end if;
@@ -1404,7 +1374,7 @@ package body Repinfo is
Derived_Disc : Entity_Id;
begin
- Derived_Disc := First_Stored_Discriminant (Outer_Ent);
+ Derived_Disc := First_Discriminant (Outer_Ent);
-- Loop over the discriminants of the extension
@@ -1428,7 +1398,7 @@ package body Repinfo is
end if;
end if;
- Next_Stored_Discriminant (Derived_Disc);
+ Next_Discriminant (Derived_Disc);
end loop;
-- Disc is not constrained by a discriminant of Outer_Ent
@@ -1497,12 +1467,13 @@ package body Repinfo is
end if;
-- If the record has discriminants and is not an unchecked
- -- union, then display them now.
+ -- union, then display them now. Note that, even if this is
+ -- a structural layout, we list the visible discriminants.
if Has_Discriminants (Ent)
and then not Is_Unchecked_Union (Ent)
then
- Disc := First_Stored_Discriminant (Ent);
+ Disc := First_Discriminant (Ent);
while Present (Disc) loop
-- If this is a record extension and the discriminant is
@@ -1540,7 +1511,7 @@ package body Repinfo is
List_Component_Layout (Listed_Disc, Indent => Indent);
<<Continue_Disc>>
- Next_Stored_Discriminant (Disc);
+ Next_Discriminant (Disc);
end loop;
end if;
@@ -1936,6 +1907,21 @@ package body Repinfo is
when Convention_C =>
Write_Str ("C");
+ when Convention_C_Variadic =>
+ declare
+ N : Nat :=
+ Convention_Id'Pos (Convention (Ent)) -
+ Convention_Id'Pos (Convention_C_Variadic_0);
+ begin
+ Write_Str ("C_Variadic_");
+ if N >= 10 then
+ Write_Char ('1');
+ N := N - 10;
+ end if;
+ pragma Assert (N < 10);
+ Write_Char (Character'Val (Character'Pos ('0') + N));
+ end;
+
when Convention_COBOL =>
Write_Str ("COBOL");
@@ -2336,24 +2322,6 @@ package body Repinfo is
end loop;
end Spaces;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- Rep_Table.Tree_Read;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Rep_Table.Tree_Write;
- end Tree_Write;
-
---------------------
-- Write_Info_Line --
---------------------
diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads
index c8eb350..6731dff 100644
--- a/gcc/ada/repinfo.ads
+++ b/gcc/ada/repinfo.ads
@@ -6,23 +6,17 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
+-- 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 distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
@@ -31,9 +25,7 @@
-- This package contains the routines to handle back annotation of the
-- tree to fill in representation information, and also the routines used
--- by -gnatR to output this information. This unit is used both in the
--- compiler and in ASIS (it is used in ASIS as part of the implementation
--- of the Data Decomposition Annex).
+-- by -gnatR to output this information.
-- WARNING: There is a C version of this package. Any changes to this
-- source file must be properly reflected in the C header file repinfo.h
@@ -112,12 +104,12 @@ package Repinfo is
-- in terms of the variables represented symbolically.
-- Note: the extended back annotation for the dynamic case is needed only
- -- for -gnatR3 output, and for proper operation of the ASIS DDA. Since it
- -- can be expensive to do this back annotation (for discriminated records
- -- with many variable-length arrays), we only do the full back annotation
- -- in -gnatR3 mode, or ASIS mode. In any other mode, the back-end just sets
- -- the value to Uint_Minus_1, indicating that the value of the attribute
- -- depends on discriminant information, but not giving further details.
+ -- for -gnatR3 output. Since it can be expensive to do this back annotation
+ -- (for discriminated records with many variable-length arrays), we only do
+ -- the full back annotation in -gnatR3 mode. In any other mode, the
+ -- back-end just sets the value to Uint_Minus_1, indicating that the value
+ -- of the attribute depends on discriminant information, but not giving
+ -- further details.
-- GCC expressions are represented with a Uint value that is negative.
-- See the body of this package for details on the representation used.
@@ -129,8 +121,8 @@ package Repinfo is
-- with a given set of discriminant values, indicates whether the variant
-- is present for that set of values (result is True, i.e. non-zero) or
-- not present (result is False, i.e. zero). Again, the full annotation of
- -- this field is done only in -gnatR3 mode or in ASIS mode, and in other
- -- modes, the value is set to Uint_Minus_1.
+ -- this field is done only in -gnatR3 mode, and in other modes, the value
+ -- is set to Uint_Minus_1.
subtype Node_Ref is Uint;
-- Subtype used for negative Uint values used to represent nodes
@@ -282,9 +274,9 @@ package Repinfo is
-- number of elements of the value of "operands" is specified by the
-- operands column in the line associated with the symbol in the table.
- -- As documented above, the full back annotation is only done in -gnatR3
- -- or ASIS mode. In the other cases, if the numerical expression is not
- -- a number, then it is replaced with the "??" string.
+ -- As documented above, the full back annotation is only done in -gnatR3.
+ -- In the other cases, if the numerical expression is not a number, then
+ -- it is replaced with the "??" string.
------------------------
-- The gigi Interface --
@@ -375,9 +367,9 @@ package Repinfo is
-- and entity id values and the back end makes Get_Dynamic_SO_Ref
-- calls to retrieve them.
- --------------------
- -- ASIS_Interface --
- --------------------
+ ------------------------------
+ -- External tools Interface --
+ ------------------------------
type Discrim_List is array (Pos range <>) of Uint;
-- Type used to represent list of discriminant values
@@ -390,10 +382,6 @@ package Repinfo is
-- as an argument value, and return it unmodified. A No_Uint value is
-- also returned unmodified.
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines.
-
------------------------
-- Compiler Interface --
------------------------
@@ -402,10 +390,6 @@ package Repinfo is
-- Procedure to list representation information. Bytes_Big_Endian is the
-- value from Ttypes (Repinfo cannot have a dependency on Ttypes).
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
--------------------------
-- Debugging Procedures --
--------------------------
diff --git a/gcc/ada/repinfo.h b/gcc/ada/repinfo.h
index 30c3e6d..e6835c3 100644
--- a/gcc/ada/repinfo.h
+++ b/gcc/ada/repinfo.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1999-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1999-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb
index 8a8e2fa..c63c881 100644
--- a/gcc/ada/restrict.adb
+++ b/gcc/ada/restrict.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -35,37 +35,14 @@ with Opt; use Opt;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Stand; use Stand;
+with Targparm; use Targparm;
with Uname; use Uname;
package body Restrict is
- -------------------------------
- -- SPARK Restriction Control --
- -------------------------------
-
- -- SPARK HIDE directives allow the effect of the SPARK_05 restriction to be
- -- turned off for a specified region of code, and the following tables are
- -- the data structures used to keep track of these regions.
-
- -- The table contains pairs of source locations, the first being the start
- -- location for hidden region, and the second being the end location.
-
- -- Note that the start location is included in the hidden region, while
- -- the end location is excluded from it. (It typically corresponds to the
- -- next token during scanning.)
-
- type SPARK_Hide_Entry is record
- Start : Source_Ptr;
- Stop : Source_Ptr;
- end record;
-
- package SPARK_Hides is new Table.Table (
- Table_Component_Type => SPARK_Hide_Entry,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 100,
- Table_Increment => 200,
- Table_Name => "SPARK Hides");
+ Global_Restriction_No_Tasking : Boolean := False;
+ -- Set to True when No_Tasking is set in the run-time package System
+ -- or in a configuration pragmas file (for example, gnat.adc).
--------------------------------
-- Package Local Declarations --
@@ -260,7 +237,7 @@ package body Restrict is
-- For type conversion, check converted expression
- elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
+ elsif Nkind (Obj) in N_Unchecked_Type_Conversion | N_Type_Conversion then
Check_No_Implicit_Aliasing (Expression (Obj));
return;
@@ -511,13 +488,6 @@ package body Restrict is
return;
end if;
- -- In SPARK 05 mode, issue an error for any use of class-wide, even if
- -- the No_Dispatch restriction is not set.
-
- if R = No_Dispatch then
- Check_SPARK_05_Restriction ("class-wide is not allowed", N);
- end if;
-
if UI_Is_In_Int_Range (V) then
VV := Integer (UI_To_Int (V));
else
@@ -656,7 +626,14 @@ package body Restrict is
return;
end if;
- Id := Identifier (N);
+ if Nkind (N) = N_Pragma then
+ Id := Pragma_Identifier (N);
+ elsif Nkind (N) = N_Attribute_Definition_Clause then
+ Id := N;
+ else
+ Id := Identifier (N);
+ end if;
+
A_Id := Get_Aspect_Id (Chars (Id));
pragma Assert (A_Id /= No_Aspect);
@@ -769,7 +746,7 @@ package body Restrict is
and then Chars (Scope (Ent)) = Name_Ada
and then Scope (Scope (Ent)) = Standard_Standard)
then
- if Nkind_In (Expr, N_Identifier, N_Operator_Symbol)
+ if Nkind (Expr) in N_Identifier | N_Operator_Symbol
and then Chars (Ent) = Chars (Expr)
then
Error_Msg_Node_1 := N;
@@ -786,7 +763,7 @@ package body Restrict is
-- Here if at outer level of entity name in table
- elsif Nkind_In (Expr, N_Identifier, N_Operator_Symbol) then
+ elsif Nkind (Expr) in N_Identifier | N_Operator_Symbol then
exit;
-- Here if neither at the outer level
@@ -846,94 +823,6 @@ package body Restrict is
end if;
end Check_Restriction_No_Use_Of_Pragma;
- --------------------------------
- -- Check_SPARK_05_Restriction --
- --------------------------------
-
- procedure Check_SPARK_05_Restriction
- (Msg : String;
- N : Node_Id;
- Force : Boolean := False)
- is
- Msg_Issued : Boolean;
- Save_Error_Msg_Sloc : Source_Ptr;
- Onode : constant Node_Id := Original_Node (N);
-
- begin
- -- Output message if Force set
-
- if Force
-
- -- Or if this node comes from source
-
- or else Comes_From_Source (N)
-
- -- Or if this is a range node which rewrites a range attribute and
- -- the range attribute comes from source.
-
- or else (Nkind (N) = N_Range
- and then Nkind (Onode) = N_Attribute_Reference
- and then Attribute_Name (Onode) = Name_Range
- and then Comes_From_Source (Onode))
-
- -- Or this is an expression that does not come from source, which is
- -- a rewriting of an expression that does come from source.
-
- or else (Nkind (N) in N_Subexpr and then Comes_From_Source (Onode))
- then
- if Restriction_Check_Required (SPARK_05)
- and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
- then
- return;
- end if;
-
- -- Since the call to Restriction_Msg from Check_Restriction may set
- -- Error_Msg_Sloc to the location of the pragma restriction, save and
- -- restore the previous value of the global variable around the call.
-
- Save_Error_Msg_Sloc := Error_Msg_Sloc;
- Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
- Error_Msg_Sloc := Save_Error_Msg_Sloc;
-
- if Msg_Issued then
- Error_Msg_F ("\\| " & Msg, N);
- end if;
- end if;
- end Check_SPARK_05_Restriction;
-
- procedure Check_SPARK_05_Restriction
- (Msg1 : String;
- Msg2 : String;
- N : Node_Id)
- is
- Msg_Issued : Boolean;
- Save_Error_Msg_Sloc : Source_Ptr;
-
- begin
- pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\');
-
- if Comes_From_Source (Original_Node (N)) then
- if Restriction_Check_Required (SPARK_05)
- and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
- then
- return;
- end if;
-
- -- Since the call to Restriction_Msg from Check_Restriction may set
- -- Error_Msg_Sloc to the location of the pragma restriction, save and
- -- restore the previous value of the global variable around the call.
-
- Save_Error_Msg_Sloc := Error_Msg_Sloc;
- Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
- Error_Msg_Sloc := Save_Error_Msg_Sloc;
-
- if Msg_Issued then
- Error_Msg_F ("\\| " & Msg1, N);
- Error_Msg_F (Msg2, N);
- end if;
- end if;
- end Check_SPARK_05_Restriction;
-
--------------------------------------
-- Check_Wide_Character_Restriction --
--------------------------------------
@@ -1021,24 +910,15 @@ package body Restrict is
return Not_A_Restriction_Id;
end Get_Restriction_Id;
- --------------------------------
- -- Is_In_Hidden_Part_In_SPARK --
- --------------------------------
+ -----------------------
+ -- Global_No_Tasking --
+ -----------------------
- function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean is
+ function Global_No_Tasking return Boolean is
begin
- -- Loop through table of hidden ranges
-
- for J in SPARK_Hides.First .. SPARK_Hides.Last loop
- if SPARK_Hides.Table (J).Start <= Loc
- and then Loc < SPARK_Hides.Table (J).Stop
- then
- return True;
- end if;
- end loop;
-
- return False;
- end Is_In_Hidden_Part_In_SPARK;
+ return Global_Restriction_No_Tasking
+ or else Targparm.Restrictions_On_Target.Set (No_Tasking);
+ end Global_No_Tasking;
-------------------------------
-- No_Exception_Handlers_Set --
@@ -1097,7 +977,7 @@ package body Restrict is
and then
OK_No_Use_Of_Entity_Name (Selector_Name (N));
- elsif Nkind_In (N, N_Identifier, N_Operator_Symbol) then
+ elsif Nkind (N) in N_Identifier | N_Operator_Symbol then
return True;
else
@@ -1134,21 +1014,11 @@ package body Restrict is
when Name_No_Task_Attributes =>
New_Name := Name_No_Task_Attributes_Package;
- -- SPARK is special in that we unconditionally warn
-
- when Name_SPARK =>
- Error_Msg_Name_1 := Name_SPARK;
- Error_Msg_N ("restriction identifier % is obsolescent??", N);
- Error_Msg_Name_1 := Name_SPARK_05;
- Error_Msg_N ("|use restriction identifier % instead??", N);
- return Name_SPARK_05;
-
when others =>
return Old_Name;
end case;
- -- Output warning if we are warning on obsolescent features for all
- -- cases other than SPARK.
+ -- Output warning if we are warning on obsolescent features.
if Warn_On_Obsolescent_Feature then
Error_Msg_Name_1 := Old_Name;
@@ -1250,8 +1120,7 @@ package body Restrict is
-- Append given string to Msg, bumping Len appropriately
procedure Id_Case (S : String; Quotes : Boolean := True);
- -- Given a string S, case it according to current identifier casing,
- -- except for SPARK_05 (an acronym) which is set all upper case, and
+ -- Given a string S, case it according to current identifier casing, and
-- store in Error_Msg_String. Then append `~` to the message buffer
-- to output the string unchanged surrounded in quotes. The quotes
-- are suppressed if Quotes = False.
@@ -1284,13 +1153,7 @@ package body Restrict is
begin
Name_Buffer (1 .. S'Last) := S;
Name_Len := S'Length;
-
- if R = SPARK_05 then
- Set_All_Upper_Case;
- else
- Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
- end if;
-
+ Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
Error_Msg_Strlen := Name_Len;
Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
@@ -1395,15 +1258,15 @@ package body Restrict is
function Same_Entity (E1, E2 : Node_Id) return Boolean is
begin
- if Nkind_In (E1, N_Identifier, N_Operator_Symbol)
+ if Nkind (E1) in N_Identifier | N_Operator_Symbol
and then
- Nkind_In (E2, N_Identifier, N_Operator_Symbol)
+ Nkind (E2) in N_Identifier | N_Operator_Symbol
then
return Chars (E1) = Chars (E2);
- elsif Nkind_In (E1, N_Selected_Component, N_Expanded_Name)
+ elsif Nkind (E1) in N_Selected_Component | N_Expanded_Name
and then
- Nkind_In (E2, N_Selected_Component, N_Expanded_Name)
+ Nkind (E2) in N_Selected_Component | N_Expanded_Name
then
return Same_Unit (Prefix (E1), Prefix (E2))
and then
@@ -1422,9 +1285,9 @@ package body Restrict is
if Nkind (U1) = N_Identifier and then Nkind (U2) = N_Identifier then
return Chars (U1) = Chars (U2);
- elsif Nkind_In (U1, N_Selected_Component, N_Expanded_Name)
+ elsif Nkind (U1) in N_Selected_Component | N_Expanded_Name
and then
- Nkind_In (U2, N_Selected_Component, N_Expanded_Name)
+ Nkind (U2) in N_Selected_Component | N_Expanded_Name
then
return Same_Unit (Prefix (U1), Prefix (U2))
and then
@@ -1444,17 +1307,6 @@ package body Restrict is
end Save_Config_Cunit_Boolean_Restrictions;
------------------------------
- -- Set_Hidden_Part_In_SPARK --
- ------------------------------
-
- procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr) is
- begin
- SPARK_Hides.Increment_Last;
- SPARK_Hides.Table (SPARK_Hides.Last).Start := Loc1;
- SPARK_Hides.Table (SPARK_Hides.Last).Stop := Loc2;
- end Set_Hidden_Part_In_SPARK;
-
- ------------------------------
-- Set_Profile_Restrictions --
------------------------------
@@ -1502,8 +1354,6 @@ package body Restrict is
-- Set_Restriction --
---------------------
- -- Case of Boolean restriction
-
procedure Set_Restriction
(R : All_Boolean_Restrictions;
N : Node_Id)
@@ -1543,8 +1393,6 @@ package body Restrict is
end if;
end Set_Restriction;
- -- Case of parameter restriction
-
procedure Set_Restriction
(R : All_Parameter_Restrictions;
N : Node_Id;
@@ -1594,6 +1442,29 @@ package body Restrict is
Restriction_Profile_Name (R) := No_Profile;
end Set_Restriction;
+ procedure Set_Restriction
+ (R : All_Restrictions;
+ N : Node_Id;
+ Warn : Boolean;
+ V : Integer := Integer'First)
+ is
+ Set : Boolean := True;
+ begin
+ if Warn and then Restriction_Active (R) then
+ Set := False;
+ end if;
+
+ if Set then
+ if R in All_Boolean_Restrictions then
+ Set_Restriction (R, N);
+ else
+ Set_Restriction (R, N, V);
+ end if;
+
+ Restriction_Warnings (R) := Warn;
+ end if;
+ end Set_Restriction;
+
-----------------------------------
-- Set_Restriction_No_Dependence --
-----------------------------------
@@ -1633,7 +1504,7 @@ package body Restrict is
procedure Set_Restriction_No_Use_Of_Entity
(Entity : Node_Id;
- Warning : Boolean;
+ Warn : Boolean;
Profile : Profile_Name := No_Profile)
is
Nam : Node_Id;
@@ -1649,7 +1520,7 @@ package body Restrict is
-- Error has precedence over warning
- if not Warning then
+ if not Warn then
No_Use_Of_Entity.Table (J).Warn := False;
end if;
@@ -1659,17 +1530,17 @@ package body Restrict is
-- Entry is not currently in table
- No_Use_Of_Entity.Append ((Entity, Warning, Profile));
+ No_Use_Of_Entity.Append ((Entity, Warn, Profile));
-- Now we need to find the direct name and set Boolean2 flag
- if Nkind_In (Entity, N_Identifier, N_Operator_Symbol) then
+ if Nkind (Entity) in N_Identifier | N_Operator_Symbol then
Nam := Entity;
else
pragma Assert (Nkind (Entity) = N_Selected_Component);
Nam := Selector_Name (Entity);
- pragma Assert (Nkind_In (Nam, N_Identifier, N_Operator_Symbol));
+ pragma Assert (Nkind (Nam) in N_Identifier | N_Operator_Symbol);
end if;
Set_Name_Table_Boolean2 (Chars (Nam), True);
@@ -1680,15 +1551,15 @@ package body Restrict is
------------------------------------------------
procedure Set_Restriction_No_Specification_Of_Aspect
- (N : Node_Id;
- Warning : Boolean)
+ (N : Node_Id;
+ Warn : Boolean)
is
A_Id : constant Aspect_Id_Exclude_No_Aspect := Get_Aspect_Id (Chars (N));
begin
No_Specification_Of_Aspect_Set := True;
No_Specification_Of_Aspects (A_Id) := Sloc (N);
- No_Specification_Of_Aspect_Warning (A_Id) := Warning;
+ No_Specification_Of_Aspect_Warning (A_Id) := Warn;
end Set_Restriction_No_Specification_Of_Aspect;
procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id) is
@@ -1703,15 +1574,15 @@ package body Restrict is
-----------------------------------------
procedure Set_Restriction_No_Use_Of_Attribute
- (N : Node_Id;
- Warning : Boolean)
+ (N : Node_Id;
+ Warn : Boolean)
is
A_Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
begin
No_Use_Of_Attribute_Set := True;
No_Use_Of_Attribute (A_Id) := Sloc (N);
- No_Use_Of_Attribute_Warning (A_Id) := Warning;
+ No_Use_Of_Attribute_Warning (A_Id) := Warn;
end Set_Restriction_No_Use_Of_Attribute;
procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id) is
@@ -1726,15 +1597,15 @@ package body Restrict is
--------------------------------------
procedure Set_Restriction_No_Use_Of_Pragma
- (N : Node_Id;
- Warning : Boolean)
+ (N : Node_Id;
+ Warn : Boolean)
is
A_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N));
begin
No_Use_Of_Pragma_Set := True;
No_Use_Of_Pragma (A_Id) := Sloc (N);
- No_Use_Of_Pragma_Warning (A_Id) := Warning;
+ No_Use_Of_Pragma_Warning (A_Id) := Warn;
end Set_Restriction_No_Use_Of_Pragma;
procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id) is
@@ -1744,6 +1615,15 @@ package body Restrict is
No_Use_Of_Pragma_Warning (A_Id) := False;
end Set_Restriction_No_Use_Of_Pragma;
+ ---------------------------
+ -- Set_Global_No_Tasking --
+ ---------------------------
+
+ procedure Set_Global_No_Tasking is
+ begin
+ Global_Restriction_No_Tasking := True;
+ end Set_Global_No_Tasking;
+
----------------------------------
-- Suppress_Restriction_Message --
----------------------------------
diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads
index 80cd012..7a84d37 100644
--- a/gcc/ada/restrict.ads
+++ b/gcc/ada/restrict.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -89,6 +89,7 @@ package Restrict is
(No_Delay, "calendar"),
(No_Dynamic_Priorities, "a-dynpri"),
(No_Finalization, "a-finali"),
+ (No_IO, "a-direct"),
(No_IO, "a-direio"),
(No_IO, "directio"),
(No_IO, "a-sequio"),
@@ -282,9 +283,10 @@ package Restrict is
-- the node to which an error will be attached if necessary.
procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id);
- -- N is the node id for an N_Aspect_Specification. An error message
- -- (warning) will be issued if a restriction (warning) was previously set
- -- for this aspect using Set_No_Specification_Of_Aspect.
+ -- N is the node id for an N_Aspect_Specification, an N_Pragma, or an
+ -- N_Attribute_Definition_Clause. An error message (warning) will be issued
+ -- if a restriction (warning) was previously set for this aspect using
+ -- Set_No_Specification_Of_Aspect.
procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id);
-- N denotes an attribute definition clause or an attribute reference. An
@@ -309,22 +311,6 @@ package Restrict is
-- WARNING: There is a matching C declaration of this subprogram in fe.h
- procedure Check_SPARK_05_Restriction
- (Msg : String;
- N : Node_Id;
- Force : Boolean := False);
- -- Node N represents a construct not allowed in SPARK_05 mode. If this is
- -- a source node, or if the restriction is forced (Force = True), and
- -- the SPARK_05 restriction is set, then an error is issued on N. Msg
- -- is appended to the restriction failure message.
-
- procedure Check_SPARK_05_Restriction
- (Msg1 : String;
- Msg2 : String;
- N : Node_Id);
- -- Same as Check_SPARK_05_Restriction except there is a continuation
- -- message Msg2 following the initial message Msg1.
-
procedure Check_No_Implicit_Aliasing (Obj : Node_Id);
-- Obj is a node for which Is_Aliased_View is True, which is being used in
-- a context (e.g. 'Access) where no implicit aliasing is allowed if the
@@ -391,10 +377,6 @@ package Restrict is
-- pragma Restrictions_Warning, or attribute Restriction_Set. Returns
-- True if N has the proper form for an entity name, False otherwise.
- function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean;
- -- Determine if given location is covered by a hidden region range in the
- -- SPARK hides table.
-
function No_Exception_Handlers_Set return Boolean;
-- Test to see if current restrictions settings specify that no exception
-- handlers are present. This function is called by Gigi when it needs to
@@ -441,10 +423,9 @@ package Restrict is
-- of individual Restrictions pragmas). Returns True only if all the
-- required restrictions are set.
- procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr);
- -- Insert a new hidden region range in the SPARK hides table. The effect
- -- is to hide any SPARK violation messages which are in the range Loc1 to
- -- Loc2-1 (i.e. Loc2 is the first location for reenabling checks).
+ procedure Set_Global_No_Tasking;
+ -- Used in call from Sem_Prag when restriction No_Tasking is set in the
+ -- run-time package System or in a configuration pragmas file.
procedure Set_Profile_Restrictions
(P : Profile_Name;
@@ -471,6 +452,20 @@ package Restrict is
-- Similar to the above, except that this is used for the case of a
-- parameter restriction, and the corresponding value V is given.
+ procedure Set_Restriction
+ (R : All_Restrictions;
+ N : Node_Id;
+ Warn : Boolean;
+ V : Integer := Integer'First);
+ -- Same as above two, except also takes care of setting the
+ -- Restriction_Warnings flag. V is ignored for Boolean
+ -- restrictions.
+ --
+ -- If this is the first time we've seen this restriction, the warning flag
+ -- is set to Warn. If this is a second or subsequent time, Warn = False
+ -- wins; that is, errors always trump warnings. In that case, the warning
+ -- flag can be set to False, but never to True.
+
procedure Set_Restriction_No_Dependence
(Unit : Node_Id;
Warn : Boolean;
@@ -482,8 +477,8 @@ package Restrict is
-- No_Dependence restriction comes from a Profile pragma.
procedure Set_Restriction_No_Specification_Of_Aspect
- (N : Node_Id;
- Warning : Boolean);
+ (N : Node_Id;
+ Warn : Boolean);
-- N is the node id for an identifier from a pragma Restrictions for the
-- No_Specification_Of_Aspect pragma. An error message will be issued if
-- the identifier is not a valid aspect name. Warning is set True for the
@@ -494,8 +489,8 @@ package Restrict is
-- Version used by Get_Target_Parameters (via Tbuild)
procedure Set_Restriction_No_Use_Of_Attribute
- (N : Node_Id;
- Warning : Boolean);
+ (N : Node_Id;
+ Warn : Boolean);
-- N is the node id for the identifier in a pragma Restrictions for
-- No_Use_Of_Attribute. Caller has verified that this is a valid attribute
-- designator.
@@ -505,7 +500,7 @@ package Restrict is
procedure Set_Restriction_No_Use_Of_Entity
(Entity : Node_Id;
- Warning : Boolean;
+ Warn : Boolean;
Profile : Profile_Name := No_Profile);
-- Sets given No_Use_Of_Entity restriction in table if not there already.
-- Warn is True if from Restriction_Warnings, or for Restrictions if the
@@ -516,8 +511,8 @@ package Restrict is
-- the entity (to optimize table searches).
procedure Set_Restriction_No_Use_Of_Pragma
- (N : Node_Id;
- Warning : Boolean);
+ (N : Node_Id;
+ Warn : Boolean);
-- N is the node id for the identifier in a pragma Restrictions for
-- No_Use_Of_Pragma. Caller has verified that this is a valid pragma id.
@@ -529,6 +524,10 @@ package Restrict is
-- Tests if tasking operations are allowed by the current restrictions
-- settings. For tasking to be allowed Max_Tasks must be non-zero.
+ function Global_No_Tasking return Boolean;
+ -- Returns True if the restriction No_Tasking is set in the run-time
+ -- package System or in a configuration pragmas file.
+
----------------------------------------------
-- Handling of Boolean Compilation Switches --
----------------------------------------------
diff --git a/gcc/ada/rident.ads b/gcc/ada/rident.ads
index 6612ce5..36ffb68 100644
--- a/gcc/ada/rident.ads
+++ b/gcc/ada/rident.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/rtfinal.c b/gcc/ada/rtfinal.c
index 9122d09..92f3e89 100644
--- a/gcc/ada/rtfinal.c
+++ b/gcc/ada/rtfinal.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2014-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2014-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/rtinit.c b/gcc/ada/rtinit.c
index 5c9c5ec..1bb3cb0 100644
--- a/gcc/ada/rtinit.c
+++ b/gcc/ada/rtinit.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2014-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2014-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb
index 65cc8bc..7689375 100644
--- a/gcc/ada/rtsfind.adb
+++ b/gcc/ada/rtsfind.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -540,83 +540,172 @@ package body Rtsfind is
-- Get_Unit_Name --
-------------------
+ -- The following subtypes include all the proper descendants of each unit
+ -- that has such descendants. For example, Ada_Calendar_Descendant includes
+ -- all the descendents of Ada.Calendar (except Ada.Calendar itself). These
+ -- are used by Get_Unit_Name to know where to change "_" to ".", and by
+ -- Is_Text_IO_Special_Package to detect the special generic pseudo-children
+ -- of [[Wide_]Wide_]Text_IO.
+
+ subtype Ada_Descendant is RTU_Id
+ range Ada_Calendar .. Ada_Wide_Wide_Text_IO_Modular_IO;
+
+ subtype Ada_Calendar_Descendant is Ada_Descendant
+ range Ada_Calendar_Delays .. Ada_Calendar_Delays;
+
+ subtype Ada_Dispatching_Descendant is Ada_Descendant
+ range Ada_Dispatching_EDF .. Ada_Dispatching_EDF;
+
+ subtype Ada_Interrupts_Descendant is Ada_Descendant range
+ Ada_Interrupts_Names .. Ada_Interrupts_Names;
+
+ subtype Ada_Numerics_Descendant is Ada_Descendant
+ range Ada_Numerics_Generic_Elementary_Functions ..
+ Ada_Numerics_Generic_Elementary_Functions;
+
+ subtype Ada_Real_Time_Descendant is Ada_Descendant
+ range Ada_Real_Time_Delays .. Ada_Real_Time_Timing_Events;
+
+ subtype Ada_Streams_Descendant is Ada_Descendant
+ range Ada_Streams_Stream_IO .. Ada_Streams_Stream_IO;
+
+ subtype Ada_Strings_Descendant is Ada_Descendant
+ range Ada_Strings_Superbounded .. Ada_Strings_Text_Output_Buffers;
+
+ subtype Ada_Strings_Text_Output_Descendant is Ada_Strings_Descendant
+ range Ada_Strings_Text_Output_Utils .. Ada_Strings_Text_Output_Buffers;
+
+ subtype Ada_Text_IO_Descendant is Ada_Descendant
+ range Ada_Text_IO_Decimal_IO .. Ada_Text_IO_Modular_IO;
+
+ subtype Ada_Wide_Text_IO_Descendant is Ada_Descendant
+ range Ada_Wide_Text_IO_Decimal_IO .. Ada_Wide_Text_IO_Modular_IO;
+
+ subtype Ada_Wide_Wide_Text_IO_Descendant is Ada_Descendant
+ range Ada_Wide_Wide_Text_IO_Decimal_IO ..
+ Ada_Wide_Wide_Text_IO_Modular_IO;
+
+ subtype CUDA_Descendant is RTU_Id
+ range CUDA_Driver_Types .. CUDA_Vector_Types;
+
+ subtype Interfaces_Descendant is RTU_Id
+ range Interfaces_Packed_Decimal .. Interfaces_Packed_Decimal;
+
+ subtype System_Descendant is RTU_Id
+ range System_Address_Image .. System_Tasking_Stages;
+
+ subtype System_Dim_Descendant is System_Descendant
+ range System_Dim_Float_IO .. System_Dim_Integer_IO;
+
+ subtype System_Multiprocessors_Descendant is System_Descendant
+ range System_Multiprocessors_Dispatching_Domains ..
+ System_Multiprocessors_Dispatching_Domains;
+
+ subtype System_Storage_Pools_Descendant is System_Descendant
+ range System_Storage_Pools_Subpools .. System_Storage_Pools_Subpools;
+
+ subtype System_Strings_Descendant is System_Descendant
+ range System_Strings_Stream_Ops .. System_Strings_Stream_Ops;
+
+ subtype System_Tasking_Descendant is System_Descendant
+ range System_Tasking_Async_Delays .. System_Tasking_Stages;
+
+ subtype System_Tasking_Protected_Objects_Descendant is
+ System_Tasking_Descendant
+ range System_Tasking_Protected_Objects_Entries ..
+ System_Tasking_Protected_Objects_Single_Entry;
+
+ subtype System_Tasking_Restricted_Descendant is System_Tasking_Descendant
+ range System_Tasking_Restricted_Stages ..
+ System_Tasking_Restricted_Stages;
+
+ subtype System_Tasking_Async_Delays_Descendant is System_Tasking_Descendant
+ range System_Tasking_Async_Delays_Enqueue_Calendar ..
+ System_Tasking_Async_Delays_Enqueue_RT;
+
function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type is
Uname_Chars : constant String := RTU_Id'Image (U_Id);
-
begin
Name_Len := Uname_Chars'Length;
Name_Buffer (1 .. Name_Len) := Uname_Chars;
Set_Casing (All_Lower_Case);
- if U_Id in Ada_Child then
+ if U_Id in Ada_Descendant then
Name_Buffer (4) := '.';
- if U_Id in Ada_Calendar_Child then
+ if U_Id in Ada_Calendar_Descendant then
Name_Buffer (13) := '.';
- elsif U_Id in Ada_Dispatching_Child then
+ elsif U_Id in Ada_Dispatching_Descendant then
Name_Buffer (16) := '.';
- elsif U_Id in Ada_Interrupts_Child then
+ elsif U_Id in Ada_Interrupts_Descendant then
Name_Buffer (15) := '.';
- elsif U_Id in Ada_Numerics_Child then
+ elsif U_Id in Ada_Numerics_Descendant then
Name_Buffer (13) := '.';
- elsif U_Id in Ada_Real_Time_Child then
+ elsif U_Id in Ada_Real_Time_Descendant then
Name_Buffer (14) := '.';
- elsif U_Id in Ada_Streams_Child then
+ elsif U_Id in Ada_Streams_Descendant then
Name_Buffer (12) := '.';
- elsif U_Id in Ada_Strings_Child then
+ elsif U_Id in Ada_Strings_Descendant then
Name_Buffer (12) := '.';
- elsif U_Id in Ada_Text_IO_Child then
+ if U_Id in Ada_Strings_Text_Output_Descendant then
+ Name_Buffer (24) := '.';
+ end if;
+
+ elsif U_Id in Ada_Text_IO_Descendant then
Name_Buffer (12) := '.';
- elsif U_Id in Ada_Wide_Text_IO_Child then
+ elsif U_Id in Ada_Wide_Text_IO_Descendant then
Name_Buffer (17) := '.';
- elsif U_Id in Ada_Wide_Wide_Text_IO_Child then
+ elsif U_Id in Ada_Wide_Wide_Text_IO_Descendant then
Name_Buffer (22) := '.';
end if;
- elsif U_Id in Interfaces_Child then
+ elsif U_Id in CUDA_Descendant then
+ Name_Buffer (5) := '.';
+
+ elsif U_Id in Interfaces_Descendant then
Name_Buffer (11) := '.';
- elsif U_Id in System_Child then
+ elsif U_Id in System_Descendant then
Name_Buffer (7) := '.';
- if U_Id in System_Dim_Child then
+ if U_Id in System_Dim_Descendant then
Name_Buffer (11) := '.';
end if;
- if U_Id in System_Multiprocessors_Child then
+ if U_Id in System_Multiprocessors_Descendant then
Name_Buffer (23) := '.';
end if;
- if U_Id in System_Storage_Pools_Child then
+ if U_Id in System_Storage_Pools_Descendant then
Name_Buffer (21) := '.';
end if;
- if U_Id in System_Strings_Child then
+ if U_Id in System_Strings_Descendant then
Name_Buffer (15) := '.';
end if;
- if U_Id in System_Tasking_Child then
+ if U_Id in System_Tasking_Descendant then
Name_Buffer (15) := '.';
end if;
- if U_Id in System_Tasking_Restricted_Child then
+ if U_Id in System_Tasking_Restricted_Descendant then
Name_Buffer (26) := '.';
end if;
- if U_Id in System_Tasking_Protected_Objects_Child then
+ if U_Id in System_Tasking_Protected_Objects_Descendant then
Name_Buffer (33) := '.';
end if;
- if U_Id in System_Tasking_Async_Delays_Child then
+ if U_Id in System_Tasking_Async_Delays_Descendant then
Name_Buffer (28) := '.';
end if;
end if;
@@ -755,6 +844,37 @@ package body Rtsfind is
return Present (E) and then E = Ent;
end Is_RTU;
+ --------------------------------
+ -- Is_Text_IO_Special_Package --
+ --------------------------------
+
+ function Is_Text_IO_Special_Package (E : Entity_Id) return Boolean is
+ begin
+ pragma Assert (Is_Package_Or_Generic_Package (E));
+
+ -- ??? detection with a scope climbing might be more efficient
+
+ for U in Ada_Text_IO_Descendant loop
+ if Is_RTU (E, U) then
+ return True;
+ end if;
+ end loop;
+
+ for U in Ada_Wide_Text_IO_Descendant loop
+ if Is_RTU (E, U) then
+ return True;
+ end if;
+ end loop;
+
+ for U in Ada_Wide_Wide_Text_IO_Descendant loop
+ if Is_RTU (E, U) then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end Is_Text_IO_Special_Package;
+
-----------------------------
-- Is_Text_IO_Special_Unit --
-----------------------------
@@ -784,9 +904,9 @@ package body Rtsfind is
return
Nkind (Prf) = N_Identifier
and then
- Nam_In (Chars (Prf), Name_Text_IO,
- Name_Wide_Text_IO,
- Name_Wide_Wide_Text_IO)
+ Chars (Prf) in Name_Text_IO
+ | Name_Wide_Text_IO
+ | Name_Wide_Wide_Text_IO
and then Nkind (Sel) = N_Identifier
and then Chars (Sel) in Text_IO_Package_Name;
end Is_Text_IO_Special_Unit;
@@ -931,6 +1051,8 @@ package body Rtsfind is
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
+ Saved_ISMP : constant Boolean :=
+ Ignore_SPARK_Mode_Pragmas_In_Instance;
Saved_SM : constant SPARK_Mode_Type := SPARK_Mode;
Saved_SMP : constant Node_Id := SPARK_Mode_Pragma;
-- Save Ghost and SPARK mode-related data to restore on exit
@@ -946,6 +1068,7 @@ package body Rtsfind is
-- Provide a clean environment for the unit
+ Ignore_SPARK_Mode_Pragmas_In_Instance := False;
Install_Ghost_Region (None, Empty);
Install_SPARK_Mode (None, Empty);
@@ -1044,6 +1167,7 @@ package body Rtsfind is
Set_Is_Potentially_Use_Visible (U.Entity, True);
end if;
+ Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP;
Restore_Ghost_Region (Saved_GM, Saved_IGR);
Restore_SPARK_Mode (Saved_SM, Saved_SMP);
end Load_RTU;
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index 07b8069..ff9eb0a 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -46,10 +46,10 @@ package Rtsfind is
-- in the package entity table. The units must be either library level
-- package declarations, or library level subprogram declarations. Generic
-- units, library level instantiations and subprogram bodies acting as
- -- specs may not be referenced (all these cases could be added at the
+ -- specs must not be referenced. (All these cases could be added at the
-- expense of additional complexity in the body of Rtsfind, but it doesn't
-- seem worthwhile, since the implementation controls the set of units that
- -- are referenced, and this restriction is easily met.
+ -- are referenced, and this restriction is easily met.)
-- IMPORTANT NOTE: the specs of packages and procedures with'ed using
-- this mechanism must not contain use clauses. This is because these
@@ -59,6 +59,9 @@ package Rtsfind is
-- the compilation except in the presence of use clauses, which might
-- result in unexpected ambiguities.
+ -- NOTE: If RTU_Id is modified, the subtypes of RTU_Id in the package body
+ -- might need to be modified. See Get_Unit_Name.
+
type RTU_Id is (
-- Runtime packages, for list of accessible entities in each package,
@@ -122,6 +125,12 @@ package Rtsfind is
Ada_Strings_Wide_Superbounded,
Ada_Strings_Wide_Wide_Superbounded,
Ada_Strings_Unbounded,
+ Ada_Strings_Text_Output,
+
+ -- Children of Ada.Strings.Text_Output
+
+ Ada_Strings_Text_Output_Utils,
+ Ada_Strings_Text_Output_Buffers,
-- Children of Ada.Text_IO (for Check_Text_IO_Special_Unit)
@@ -150,6 +159,15 @@ package Rtsfind is
Ada_Wide_Wide_Text_IO_Integer_IO,
Ada_Wide_Wide_Text_IO_Modular_IO,
+ -- CUDA
+
+ CUDA,
+
+ -- Children of CUDA
+
+ CUDA_Driver_Types,
+ CUDA_Vector_Types,
+
-- Interfaces
Interfaces,
@@ -165,6 +183,7 @@ package Rtsfind is
-- Children of System
System_Address_Image,
+ System_Address_To_Access_Conversions,
System_Arith_64,
System_AST_Handling,
System_Assertions,
@@ -303,6 +322,8 @@ package Rtsfind is
System_Pool_Empty,
System_Pool_Local,
System_Pool_Size,
+ System_Put_Images,
+ System_Put_Task_Images,
System_Relative_Delays,
System_RPC,
System_Scalar_Values,
@@ -373,93 +394,6 @@ package Rtsfind is
System_Tasking_Rendezvous,
System_Tasking_Stages);
- subtype Ada_Child is RTU_Id
- range Ada_Calendar .. Ada_Wide_Wide_Text_IO_Modular_IO;
- -- Range of values for children or grand-children of Ada
-
- subtype Ada_Calendar_Child is Ada_Child
- range Ada_Calendar_Delays .. Ada_Calendar_Delays;
- -- Range of values for children of Ada.Calendar
-
- subtype Ada_Dispatching_Child is RTU_Id
- range Ada_Dispatching_EDF .. Ada_Dispatching_EDF;
- -- Range of values for children of Ada.Dispatching
-
- subtype Ada_Interrupts_Child is Ada_Child range
- Ada_Interrupts_Names .. Ada_Interrupts_Names;
- -- Range of values for children of Ada.Interrupts
-
- subtype Ada_Numerics_Child is Ada_Child
- range Ada_Numerics_Generic_Elementary_Functions ..
- Ada_Numerics_Generic_Elementary_Functions;
- -- Range of values for children of Ada.Numerics
-
- subtype Ada_Real_Time_Child is Ada_Child
- range Ada_Real_Time_Delays .. Ada_Real_Time_Timing_Events;
- -- Range of values for children of Ada.Real_Time
-
- subtype Ada_Streams_Child is Ada_Child
- range Ada_Streams_Stream_IO .. Ada_Streams_Stream_IO;
- -- Range of values for children of Ada.Streams
-
- subtype Ada_Strings_Child is Ada_Child
- range Ada_Strings_Superbounded .. Ada_Strings_Unbounded;
- -- Range of values for children of Ada.Strings
-
- subtype Ada_Text_IO_Child is Ada_Child
- range Ada_Text_IO_Decimal_IO .. Ada_Text_IO_Modular_IO;
- -- Range of values for children of Ada.Text_IO
-
- subtype Ada_Wide_Text_IO_Child is Ada_Child
- range Ada_Wide_Text_IO_Decimal_IO .. Ada_Wide_Text_IO_Modular_IO;
- -- Range of values for children of Ada.Text_IO
-
- subtype Ada_Wide_Wide_Text_IO_Child is Ada_Child
- range Ada_Wide_Wide_Text_IO_Decimal_IO ..
- Ada_Wide_Wide_Text_IO_Modular_IO;
-
- subtype Interfaces_Child is RTU_Id
- range Interfaces_Packed_Decimal .. Interfaces_Packed_Decimal;
- -- Range of values for children of Interfaces
-
- subtype System_Child is RTU_Id
- range System_Address_Image .. System_Tasking_Stages;
- -- Range of values for children or grandchildren of System
-
- subtype System_Dim_Child is RTU_Id
- range System_Dim_Float_IO .. System_Dim_Integer_IO;
- -- Range of values for children of System.Dim
-
- subtype System_Multiprocessors_Child is RTU_Id
- range System_Multiprocessors_Dispatching_Domains ..
- System_Multiprocessors_Dispatching_Domains;
- -- Range of values for children of System.Multiprocessors
-
- subtype System_Storage_Pools_Child is RTU_Id
- range System_Storage_Pools_Subpools .. System_Storage_Pools_Subpools;
-
- subtype System_Strings_Child is RTU_Id
- range System_Strings_Stream_Ops .. System_Strings_Stream_Ops;
-
- subtype System_Tasking_Child is System_Child
- range System_Tasking_Async_Delays .. System_Tasking_Stages;
- -- Range of values for children of System.Tasking
-
- subtype System_Tasking_Protected_Objects_Child is System_Tasking_Child
- range System_Tasking_Protected_Objects_Entries ..
- System_Tasking_Protected_Objects_Single_Entry;
- -- Range of values for children of System.Tasking.Protected_Objects
-
- subtype System_Tasking_Restricted_Child is System_Tasking_Child
- range System_Tasking_Restricted_Stages ..
- System_Tasking_Restricted_Stages;
- -- Range of values for children of System.Tasking.Restricted
-
- subtype System_Tasking_Async_Delays_Child is System_Tasking_Child
- range System_Tasking_Async_Delays_Enqueue_Calendar ..
- System_Tasking_Async_Delays_Enqueue_RT;
- -- Range of values for children of System.Tasking.Async_Delays
-
--------------------------
-- Runtime Entity Table --
--------------------------
@@ -503,6 +437,8 @@ package Rtsfind is
RO_CA_Delay_Until, -- Ada.Calendar.Delays
RO_CA_To_Duration, -- Ada.Calendar.Delays
+ RE_Yield, -- Ada_Dispatching
+
RE_Set_Deadline, -- Ada.Dispatching.EDF
RE_Code_Loc, -- Ada.Exceptions
@@ -563,6 +499,16 @@ package Rtsfind is
RE_Unbounded_String, -- Ada.Strings.Unbounded
+ RE_Sink, -- Ada.Strings.Text_Output
+
+ RE_Put_UTF_8, -- Ada.Strings.Text_Output.Utils
+ RE_Put_Wide_Wide_String, -- Ada.Strings.Text_Output.Utils
+
+ RE_Buffer, -- Ada.Strings.Text_Output.Buffers
+ RE_New_Buffer, -- Ada.Strings.Text_Output.Buffers
+ RE_Destroy, -- Ada.Strings.Text_Output.Buffers
+ RE_Get, -- Ada.Strings.Text_Output.Buffers
+
RE_Wait_For_Release, -- Ada.Synchronous_Barriers
RE_Suspend_Until_True, -- Ada.Synchronous_Task_Control
@@ -575,6 +521,7 @@ package Rtsfind is
RE_Check_Interface_Conversion, -- Ada.Tags
RE_Check_TSD, -- Ada.Tags
RE_Cstring_Ptr, -- Ada.Tags
+ RE_CW_Membership, -- Ada.Tags
RE_Descendant_Tag, -- Ada.Tags
RE_Dispatch_Table, -- Ada.Tags
RE_Dispatch_Table_Wrapper, -- Ada.Tags
@@ -676,6 +623,10 @@ package Rtsfind is
RO_WW_Decimal_IO, -- Ada.Wide_Wide_Text_IO
RO_WW_Fixed_IO, -- Ada.Wide_Wide_Text_IO
+ RE_Stream_T, -- CUDA.Driver_Types
+
+ RE_Dim3, -- CUDA.Vector_Types
+
RE_Integer_8, -- Interfaces
RE_Integer_16, -- Interfaces
RE_Integer_32, -- Interfaces
@@ -1244,6 +1195,29 @@ package Rtsfind is
RE_Stack_Bounded_Pool, -- System.Pool_Size
+ RE_Put_Image_Integer, -- System.Put_Images
+ RE_Put_Image_Long_Long_Integer, -- System.Put_Images
+ RE_Put_Image_Unsigned, -- System.Put_Images
+ RE_Put_Image_Long_Long_Unsigned, -- System.Put_Images
+ RE_Put_Image_Thin_Pointer, -- System.Put_Images
+ RE_Put_Image_Fat_Pointer, -- System.Put_Images
+ RE_Put_Image_Access_Subp, -- System.Put_Images
+ RE_Put_Image_Access_Prot_Subp, -- System.Put_Images
+ RE_Put_Image_String, -- System.Put_Images
+ RE_Put_Image_Wide_String, -- System.Put_Images
+ RE_Put_Image_Wide_Wide_String, -- System.Put_Images
+ RE_Array_Before, -- System.Put_Images
+ RE_Array_Between, -- System.Put_Images
+ RE_Array_After, -- System.Put_Images
+ RE_Simple_Array_Between, -- System.Put_Images
+ RE_Record_Before, -- System.Put_Images
+ RE_Record_Between, -- System.Put_Images
+ RE_Record_After, -- System.Put_Images
+ RE_Put_Image_Unknown, -- System.Put_Images
+
+ RE_Put_Image_Protected, -- System.Put_Task_Images
+ RE_Put_Image_Task, -- System.Put_Task_Images
+
RE_Do_Apc, -- System.RPC
RE_Do_Rpc, -- System.RPC
RE_Params_Stream_Type, -- System.RPC
@@ -1427,6 +1401,7 @@ package Rtsfind is
RE_I_C, -- System.Stream_Attributes
RE_I_F, -- System.Stream_Attributes
RE_I_I, -- System.Stream_Attributes
+ RE_I_I24, -- System.Stream_Attributes
RE_I_LF, -- System.Stream_Attributes
RE_I_LI, -- System.Stream_Attributes
RE_I_LLF, -- System.Stream_Attributes
@@ -1439,6 +1414,7 @@ package Rtsfind is
RE_I_SSU, -- System.Stream_Attributes
RE_I_SU, -- System.Stream_Attributes
RE_I_U, -- System.Stream_Attributes
+ RE_I_U24, -- System.Stream_Attributes
RE_I_WC, -- System.Stream_Attributes
RE_I_WWC, -- System.Stream_Attributes
@@ -1448,6 +1424,7 @@ package Rtsfind is
RE_W_C, -- System.Stream_Attributes
RE_W_F, -- System.Stream_Attributes
RE_W_I, -- System.Stream_Attributes
+ RE_W_I24, -- System.Stream_Attributes
RE_W_LF, -- System.Stream_Attributes
RE_W_LI, -- System.Stream_Attributes
RE_W_LLF, -- System.Stream_Attributes
@@ -1460,6 +1437,7 @@ package Rtsfind is
RE_W_SSU, -- System.Stream_Attributes
RE_W_SU, -- System.Stream_Attributes
RE_W_U, -- System.Stream_Attributes
+ RE_W_U24, -- System.Stream_Attributes
RE_W_WC, -- System.Stream_Attributes
RE_W_WWC, -- System.Stream_Attributes
@@ -1575,6 +1553,9 @@ package Rtsfind is
RE_Packed_Bytes1, -- System.Unsigned_Types
RE_Packed_Bytes2, -- System.Unsigned_Types
RE_Packed_Bytes4, -- System.Unsigned_Types
+ RE_Rev_Packed_Bytes1, -- System.Unsigned_Types
+ RE_Rev_Packed_Bytes2, -- System.Unsigned_Types
+ RE_Rev_Packed_Bytes4, -- System.Unsigned_Types
RE_Short_Unsigned, -- System.Unsigned_Types
RE_Short_Short_Unsigned, -- System.Unsigned_Types
RE_Unsigned, -- System.Unsigned_Types
@@ -1747,6 +1728,8 @@ package Rtsfind is
RO_CA_Delay_Until => Ada_Calendar_Delays,
RO_CA_To_Duration => Ada_Calendar_Delays,
+ RE_Yield => Ada_Dispatching,
+
RE_Set_Deadline => Ada_Dispatching_EDF,
RE_Code_Loc => Ada_Exceptions,
@@ -1807,6 +1790,16 @@ package Rtsfind is
RE_Unbounded_String => Ada_Strings_Unbounded,
+ RE_Sink => Ada_Strings_Text_Output,
+
+ RE_Put_UTF_8 => Ada_Strings_Text_Output_Utils,
+ RE_Put_Wide_Wide_String => Ada_Strings_Text_Output_Utils,
+
+ RE_Buffer => Ada_Strings_Text_Output_Buffers,
+ RE_New_Buffer => Ada_Strings_Text_Output_Buffers,
+ RE_Destroy => Ada_Strings_Text_Output_Buffers,
+ RE_Get => Ada_Strings_Text_Output_Buffers,
+
RE_Wait_For_Release => Ada_Synchronous_Barriers,
RE_Suspend_Until_True => Ada_Synchronous_Task_Control,
@@ -1819,6 +1812,7 @@ package Rtsfind is
RE_Check_Interface_Conversion => Ada_Tags,
RE_Check_TSD => Ada_Tags,
RE_Cstring_Ptr => Ada_Tags,
+ RE_CW_Membership => Ada_Tags,
RE_Descendant_Tag => Ada_Tags,
RE_Dispatch_Table => Ada_Tags,
RE_Dispatch_Table_Wrapper => Ada_Tags,
@@ -1920,6 +1914,10 @@ package Rtsfind is
RO_WW_Decimal_IO => Ada_Wide_Wide_Text_IO,
RO_WW_Fixed_IO => Ada_Wide_Wide_Text_IO,
+ RE_Stream_T => CUDA_Driver_Types,
+
+ RE_Dim3 => CUDA_Vector_Types,
+
RE_Integer_8 => Interfaces,
RE_Integer_16 => Interfaces,
RE_Integer_32 => Interfaces,
@@ -2612,6 +2610,29 @@ package Rtsfind is
RE_Stack_Bounded_Pool => System_Pool_Size,
+ RE_Put_Image_Integer => System_Put_Images,
+ RE_Put_Image_Long_Long_Integer => System_Put_Images,
+ RE_Put_Image_Unsigned => System_Put_Images,
+ RE_Put_Image_Long_Long_Unsigned => System_Put_Images,
+ RE_Put_Image_Thin_Pointer => System_Put_Images,
+ RE_Put_Image_Fat_Pointer => System_Put_Images,
+ RE_Put_Image_Access_Subp => System_Put_Images,
+ RE_Put_Image_Access_Prot_Subp => System_Put_Images,
+ RE_Put_Image_String => System_Put_Images,
+ RE_Put_Image_Wide_String => System_Put_Images,
+ RE_Put_Image_Wide_Wide_String => System_Put_Images,
+ RE_Array_Before => System_Put_Images,
+ RE_Array_Between => System_Put_Images,
+ RE_Array_After => System_Put_Images,
+ RE_Simple_Array_Between => System_Put_Images,
+ RE_Record_Before => System_Put_Images,
+ RE_Record_Between => System_Put_Images,
+ RE_Record_After => System_Put_Images,
+ RE_Put_Image_Unknown => System_Put_Images,
+
+ RE_Put_Image_Protected => System_Put_Task_Images,
+ RE_Put_Image_Task => System_Put_Task_Images,
+
RO_RD_Delay_For => System_Relative_Delays,
RE_Do_Apc => System_RPC,
@@ -2675,6 +2696,7 @@ package Rtsfind is
RE_I_C => System_Stream_Attributes,
RE_I_F => System_Stream_Attributes,
RE_I_I => System_Stream_Attributes,
+ RE_I_I24 => System_Stream_Attributes,
RE_I_LF => System_Stream_Attributes,
RE_I_LI => System_Stream_Attributes,
RE_I_LLF => System_Stream_Attributes,
@@ -2687,6 +2709,7 @@ package Rtsfind is
RE_I_SSU => System_Stream_Attributes,
RE_I_SU => System_Stream_Attributes,
RE_I_U => System_Stream_Attributes,
+ RE_I_U24 => System_Stream_Attributes,
RE_I_WC => System_Stream_Attributes,
RE_I_WWC => System_Stream_Attributes,
@@ -2696,6 +2719,7 @@ package Rtsfind is
RE_W_C => System_Stream_Attributes,
RE_W_F => System_Stream_Attributes,
RE_W_I => System_Stream_Attributes,
+ RE_W_I24 => System_Stream_Attributes,
RE_W_LF => System_Stream_Attributes,
RE_W_LI => System_Stream_Attributes,
RE_W_LLF => System_Stream_Attributes,
@@ -2708,6 +2732,7 @@ package Rtsfind is
RE_W_SSU => System_Stream_Attributes,
RE_W_SU => System_Stream_Attributes,
RE_W_U => System_Stream_Attributes,
+ RE_W_U24 => System_Stream_Attributes,
RE_W_WC => System_Stream_Attributes,
RE_W_WWC => System_Stream_Attributes,
@@ -2823,6 +2848,9 @@ package Rtsfind is
RE_Packed_Bytes1 => System_Unsigned_Types,
RE_Packed_Bytes2 => System_Unsigned_Types,
RE_Packed_Bytes4 => System_Unsigned_Types,
+ RE_Rev_Packed_Bytes1 => System_Unsigned_Types,
+ RE_Rev_Packed_Bytes2 => System_Unsigned_Types,
+ RE_Rev_Packed_Bytes4 => System_Unsigned_Types,
RE_Short_Unsigned => System_Unsigned_Types,
RE_Short_Short_Unsigned => System_Unsigned_Types,
RE_Unsigned => System_Unsigned_Types,
@@ -3125,6 +3153,13 @@ package Rtsfind is
-- Wide_Wide_Text_IO.xxx, where xxx is one of the subpackages of Text_IO
-- that is specially handled as described for Check_Text_IO_Special_Unit.
+ function Is_Text_IO_Special_Package (E : Entity_Id) return Boolean;
+ -- Return True iff E is one of the special generic Text_IO packages, which
+ -- Ada RM defines to be nested in Ada.Text_IO, but GNAT defines as its
+ -- private children. This is similar to Is_Text_IO_Special_Unit, but is
+ -- meant to be used on a fully resolved AST, especially in the backends.
+ -- This is used by SPARK.
+
function RTE (E : RE_Id) return Entity_Id;
-- Given the entity defined in the above tables, as identified by the
-- corresponding value in the RE_Id enumeration type, returns the Id of the
diff --git a/gcc/ada/runtime.h b/gcc/ada/runtime.h
index df42730..fa0c810 100644
--- a/gcc/ada/runtime.h
+++ b/gcc/ada/runtime.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2019-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c
index 2a1be80..14a58aa 100644
--- a/gcc/ada/s-oscons-tmplt.c
+++ b/gcc/ada/s-oscons-tmplt.c
@@ -7,7 +7,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sa_messages.adb b/gcc/ada/sa_messages.adb
index 6443d82..fefc4f0 100644
--- a/gcc/ada/sa_messages.adb
+++ b/gcc/ada/sa_messages.adb
@@ -1,7 +1,7 @@
------------------------------------------------------------------------------
-- C O D E P E E R / S P A R K --
-- --
--- Copyright (C) 2015-2019, AdaCore --
+-- Copyright (C) 2015-2020, AdaCore --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sa_messages.ads b/gcc/ada/sa_messages.ads
index 67f2008..11da9fc 100644
--- a/gcc/ada/sa_messages.ads
+++ b/gcc/ada/sa_messages.ads
@@ -1,7 +1,7 @@
------------------------------------------------------------------------------
-- C O D E P E E R / S P A R K --
-- --
--- Copyright (C) 2015-2019, AdaCore --
+-- Copyright (C) 2015-2020, AdaCore --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/scans.adb b/gcc/ada/scans.adb
index d039ceb..12cf27a 100644
--- a/gcc/ada/scans.adb
+++ b/gcc/ada/scans.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads
index 530da54..746d337 100644
--- a/gcc/ada/scans.ads
+++ b/gcc/ada/scans.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -87,7 +87,7 @@ package Scans is
-- exception-name". This degrades error recovery slightly, and perhaps
-- we could do better, but not worth the effort.
- -- Ada2020 introduces square brackets as delimiters for array and
+ -- Ada 2020 introduces square brackets as delimiters for array and
-- container aggregates.
Tok_Raise, -- RAISE
@@ -226,9 +226,6 @@ package Scans is
-- the characters '#', '$', '?', '@', '`', '\', '^', '~', or '_'. The
-- character value itself is stored in Scans.Special_Character.
- Tok_SPARK_Hide,
- -- HIDE directive in SPARK
-
No_Token);
-- No_Token is used for initializing Token values to indicate that
-- no value has been set yet.
diff --git a/gcc/ada/scil_ll.adb b/gcc/ada/scil_ll.adb
index 841206d..98ca30d 100644
--- a/gcc/ada/scil_ll.adb
+++ b/gcc/ada/scil_ll.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -120,10 +120,9 @@ package body SCIL_LL is
null;
when N_SCIL_Membership_Test =>
- pragma Assert (Nkind_In (N, N_Identifier,
- N_And_Then,
- N_Or_Else,
- N_Expression_With_Actions));
+ pragma Assert
+ (Nkind (N) in N_Identifier | N_And_Then | N_Or_Else |
+ N_Expression_With_Actions);
null;
when others =>
diff --git a/gcc/ada/scil_ll.ads b/gcc/ada/scil_ll.ads
index 6246af7..8942cc8 100644
--- a/gcc/ada/scil_ll.ads
+++ b/gcc/ada/scil_ll.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb
index 5cadb9a..408e31f 100644
--- a/gcc/ada/scn.adb
+++ b/gcc/ada/scn.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -36,158 +36,11 @@ with Uintp; use Uintp;
package body Scn is
- use ASCII;
-
Used_As_Identifier : array (Token_Type) of Boolean;
-- Flags set True if a given keyword is used as an identifier (used to
-- make sure that we only post an error message for incorrect use of a
-- keyword as an identifier once for a given keyword).
- function Determine_License return License_Type;
- -- Scan header of file and check that it has an appropriate GNAT-style
- -- header with a proper license statement. Returns GPL, Unrestricted,
- -- or Modified_GPL depending on header. If none of these, returns Unknown.
-
- -----------------------
- -- Determine_License --
- -----------------------
-
- function Determine_License return License_Type is
- GPL_Found : Boolean := False;
- Result : License_Type;
-
- function Contains (S : String) return Boolean;
- -- See if current comment contains successive non-blank characters
- -- matching the contents of S. If so leave Scan_Ptr unchanged and
- -- return True, otherwise leave Scan_Ptr unchanged and return False.
-
- procedure Skip_EOL;
- -- Skip to line terminator character
-
- --------------
- -- Contains --
- --------------
-
- function Contains (S : String) return Boolean is
- CP : Natural;
- SP : Source_Ptr;
- SS : Source_Ptr;
-
- begin
- -- Loop to check characters. This loop is terminated by end of
- -- line, and also we need to check for the EOF case, to take
- -- care of files containing only comments.
-
- SP := Scan_Ptr;
- while Source (SP) /= CR and then
- Source (SP) /= LF and then
- Source (SP) /= EOF
- loop
- if Source (SP) = S (S'First) then
- SS := SP;
- CP := S'First;
-
- loop
- SS := SS + 1;
- CP := CP + 1;
-
- if CP > S'Last then
- return True;
- end if;
-
- while Source (SS) = ' ' loop
- SS := SS + 1;
- end loop;
-
- exit when Source (SS) /= S (CP);
- end loop;
- end if;
-
- SP := SP + 1;
- end loop;
-
- return False;
- end Contains;
-
- --------------
- -- Skip_EOL --
- --------------
-
- procedure Skip_EOL is
- begin
- while Source (Scan_Ptr) /= CR
- and then Source (Scan_Ptr) /= LF
- and then Source (Scan_Ptr) /= EOF
- loop
- Scan_Ptr := Scan_Ptr + 1;
- end loop;
- end Skip_EOL;
-
- -- Start of processing for Determine_License
-
- begin
- loop
- if Source (Scan_Ptr) /= '-'
- or else Source (Scan_Ptr + 1) /= '-'
- then
- if GPL_Found then
- Result := GPL;
- exit;
- else
- Result := Unknown;
- exit;
- end if;
-
- elsif Contains ("Asaspecialexception") then
- if GPL_Found then
- Result := Modified_GPL;
- exit;
- end if;
-
- elsif Contains ("GNUGeneralPublicLicense") then
- GPL_Found := True;
-
- elsif
- Contains
- ("ThisspecificationisadaptedfromtheAdaSemanticInterface")
- or else
- Contains
- ("ThisspecificationisderivedfromtheAdaReferenceManual")
- then
- Result := Unrestricted;
- exit;
- end if;
-
- Skip_EOL;
-
- Scanner.Check_End_Of_Line;
-
- if Source (Scan_Ptr) /= EOF then
-
- -- We have to take into account a degenerate case when the source
- -- file contains only comments and no Ada code.
-
- declare
- Physical : Boolean;
-
- begin
- Skip_Line_Terminators (Scan_Ptr, Physical);
-
- -- If we are at start of physical line, update scan pointers
- -- to reflect the start of the new line.
-
- if Physical then
- Current_Line_Start := Scan_Ptr;
- Start_Column := Scanner.Set_Start_Column;
- First_Non_Blank_Location := Scan_Ptr;
- end if;
- end;
- end if;
- end loop;
-
- return Result;
- end Determine_License;
-
----------------------------
-- Determine_Token_Casing --
----------------------------
@@ -203,10 +56,7 @@ package body Scn is
procedure Initialize_Scanner
(Unit : Unit_Number_Type;
- Index : Source_File_Index)
- is
- GNAT_Hedr : constant Text_Buffer (1 .. 78) := (others => '-');
-
+ Index : Source_File_Index) is
begin
Scanner.Initialize_Scanner (Index);
Set_Unit (Index, Unit);
@@ -218,14 +68,6 @@ package body Scn is
Set_Comes_From_Source_Default (True);
- -- Check license if GNAT type header possibly present
-
- if Source_Last (Index) - Scan_Ptr > 80
- and then Source (Scan_Ptr .. Scan_Ptr + 77) = GNAT_Hedr
- then
- Set_License (Current_Source_File, Determine_License);
- end if;
-
Check_For_BOM;
-- Because of the License stuff above, Scng.Initialize_Scanner cannot
diff --git a/gcc/ada/scn.ads b/gcc/ada/scn.ads
index 239c705..5e20019 100644
--- a/gcc/ada/scn.ads
+++ b/gcc/ada/scn.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb
index d4c1916..2bac3a8 100644
--- a/gcc/ada/scng.adb
+++ b/gcc/ada/scng.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -28,8 +28,6 @@ with Csets; use Csets;
with Hostparm; use Hostparm;
with Namet; use Namet;
with Opt; use Opt;
-with Restrict; use Restrict;
-with Rident; use Rident;
with Scans; use Scans;
with Sinput; use Sinput;
with Snames; use Snames;
@@ -70,19 +68,6 @@ package body Scng is
-- the token used is Tok_Identifier. This allows detection of additional
-- spaces added in sources when using the builder switch -m.
- procedure Accumulate_Token_Checksum_GNAT_6_3;
- -- Used in place of Accumulate_Token_Checksum for GNAT versions 5.04 to
- -- 6.3, when Tok_Some was not included in Token_Type and the actual
- -- Token_Type was used for keywords. This procedure is never used in the
- -- compiler or gnatmake, only in gprbuild.
-
- procedure Accumulate_Token_Checksum_GNAT_5_03;
- -- Used in place of Accumulate_Token_Checksum for GNAT version 5.03, when
- -- Tok_Interface, Tok_Some, Tok_Synchronized and Tok_Overriding were not
- -- included in Token_Type and the actual Token_Type was used for keywords.
- -- This procedure is never used in the compiler or gnatmake, only in
- -- gprbuild.
-
procedure Accumulate_Checksum (C : Character);
pragma Inline (Accumulate_Checksum);
-- This routine accumulates the checksum given character C. During the
@@ -138,307 +123,6 @@ package body Scng is
Character'Val (Token_Type'Pos (Token)));
end Accumulate_Token_Checksum;
- ----------------------------------------
- -- Accumulate_Token_Checksum_GNAT_6_3 --
- ----------------------------------------
-
- procedure Accumulate_Token_Checksum_GNAT_6_3 is
- begin
- -- Individual values of Token_Type are used, instead of subranges, so
- -- that additions or suppressions of enumerated values in type
- -- Token_Type are detected by the compiler.
-
- case Token is
- when Tok_Abs
- | Tok_Abstract
- | Tok_Access
- | Tok_Aliased
- | Tok_All
- | Tok_Ampersand
- | Tok_And
- | Tok_Apostrophe
- | Tok_Array
- | Tok_Asterisk
- | Tok_At
- | Tok_At_Sign
- | Tok_Body
- | Tok_Box
- | Tok_Char_Literal
- | Tok_Colon
- | Tok_Colon_Equal
- | Tok_Comma
- | Tok_Constant
- | Tok_Delta
- | Tok_Digits
- | Tok_Do
- | Tok_Dot
- | Tok_Double_Asterisk
- | Tok_Equal
- | Tok_Greater
- | Tok_Greater_Equal
- | Tok_Greater_Greater
- | Tok_Identifier
- | Tok_In
- | Tok_Integer_Literal
- | Tok_Interface
- | Tok_Is
- | Tok_Left_Bracket
- | Tok_Left_Paren
- | Tok_Less
- | Tok_Less_Equal
- | Tok_Limited
- | Tok_Minus
- | Tok_Mod
- | Tok_New
- | Tok_Not
- | Tok_Not_Equal
- | Tok_Null
- | Tok_Of
- | Tok_Operator_Symbol
- | Tok_Or
- | Tok_Others
- | Tok_Out
- | Tok_Plus
- | Tok_Range
- | Tok_Real_Literal
- | Tok_Record
- | Tok_Rem
- | Tok_Renames
- | Tok_Reverse
- | Tok_Right_Bracket
- | Tok_Right_Paren
- | Tok_Slash
- | Tok_String_Literal
- | Tok_Xor
- =>
- System.CRC32.Update
- (System.CRC32.CRC32 (Checksum),
- Character'Val (Token_Type'Pos (Token)));
-
- when Tok_Some =>
- System.CRC32.Update
- (System.CRC32.CRC32 (Checksum),
- Character'Val (Token_Type'Pos (Tok_Identifier)));
-
- when No_Token
- | Tok_Abort
- | Tok_Accept
- | Tok_Arrow
- | Tok_Begin
- | Tok_Case
- | Tok_Comment
- | Tok_Declare
- | Tok_Delay
- | Tok_Dot_Dot
- | Tok_Else
- | Tok_Elsif
- | Tok_End
- | Tok_End_Of_Line
- | Tok_Entry
- | Tok_EOF
- | Tok_Exception
- | Tok_Exit
- | Tok_Extends
- | Tok_External
- | Tok_External_As_List
- | Tok_For
- | Tok_Function
- | Tok_Generic
- | Tok_Goto
- | Tok_If
- | Tok_Less_Less
- | Tok_Loop
- | Tok_Overriding
- | Tok_Package
- | Tok_Pragma
- | Tok_Private
- | Tok_Procedure
- | Tok_Project
- | Tok_Protected
- | Tok_Raise
- | Tok_Requeue
- | Tok_Return
- | Tok_Select
- | Tok_Semicolon
- | Tok_Separate
- | Tok_SPARK_Hide
- | Tok_Special
- | Tok_Subtype
- | Tok_Synchronized
- | Tok_Tagged
- | Tok_Task
- | Tok_Terminate
- | Tok_Then
- | Tok_Type
- | Tok_Until
- | Tok_Use
- | Tok_Vertical_Bar
- | Tok_When
- | Tok_While
- | Tok_With
- =>
- System.CRC32.Update
- (System.CRC32.CRC32 (Checksum),
- Character'Val (Token_Type'Pos (Token_Type'Pred (Token))));
- end case;
- end Accumulate_Token_Checksum_GNAT_6_3;
-
- -----------------------------------------
- -- Accumulate_Token_Checksum_GNAT_5_03 --
- -----------------------------------------
-
- procedure Accumulate_Token_Checksum_GNAT_5_03 is
- begin
- -- Individual values of Token_Type are used, instead of subranges, so
- -- that additions or suppressions of enumerated values in type
- -- Token_Type are detected by the compiler.
-
- case Token is
- when Tok_Abs
- | Tok_Abstract
- | Tok_Access
- | Tok_Aliased
- | Tok_All
- | Tok_Ampersand
- | Tok_And
- | Tok_Apostrophe
- | Tok_Array
- | Tok_Asterisk
- | Tok_At
- | Tok_At_Sign
- | Tok_Body
- | Tok_Box
- | Tok_Char_Literal
- | Tok_Colon
- | Tok_Colon_Equal
- | Tok_Comma
- | Tok_Constant
- | Tok_Delta
- | Tok_Digits
- | Tok_Do
- | Tok_Dot
- | Tok_Double_Asterisk
- | Tok_Equal
- | Tok_Greater
- | Tok_Greater_Equal
- | Tok_Greater_Greater
- | Tok_Identifier
- | Tok_In
- | Tok_Integer_Literal
- | Tok_Is
- | Tok_Left_Bracket
- | Tok_Left_Paren
- | Tok_Less
- | Tok_Less_Equal
- | Tok_Minus
- | Tok_Mod
- | Tok_New
- | Tok_Not
- | Tok_Not_Equal
- | Tok_Null
- | Tok_Operator_Symbol
- | Tok_Or
- | Tok_Others
- | Tok_Plus
- | Tok_Range
- | Tok_Real_Literal
- | Tok_Rem
- | Tok_Right_Bracket
- | Tok_Right_Paren
- | Tok_Slash
- | Tok_String_Literal
- | Tok_Xor
- =>
- System.CRC32.Update
- (System.CRC32.CRC32 (Checksum),
- Character'Val (Token_Type'Pos (Token)));
-
- when Tok_Interface
- | Tok_Overriding
- | Tok_Some
- | Tok_Synchronized
- =>
- System.CRC32.Update
- (System.CRC32.CRC32 (Checksum),
- Character'Val (Token_Type'Pos (Tok_Identifier)));
-
- when Tok_Limited
- | Tok_Of
- | Tok_Out
- | Tok_Record
- | Tok_Renames
- | Tok_Reverse
- =>
- System.CRC32.Update
- (System.CRC32.CRC32 (Checksum),
- Character'Val (Token_Type'Pos (Token) - 1));
-
- when Tok_Abort
- | Tok_Accept
- | Tok_Begin
- | Tok_Case
- | Tok_Declare
- | Tok_Delay
- | Tok_Else
- | Tok_Elsif
- | Tok_End
- | Tok_Entry
- | Tok_Exception
- | Tok_Exit
- | Tok_For
- | Tok_Goto
- | Tok_If
- | Tok_Less_Less
- | Tok_Loop
- | Tok_Pragma
- | Tok_Protected
- | Tok_Raise
- | Tok_Requeue
- | Tok_Return
- | Tok_Select
- | Tok_Subtype
- | Tok_Tagged
- | Tok_Task
- | Tok_Terminate
- | Tok_Then
- | Tok_Type
- | Tok_Until
- | Tok_When
- | Tok_While
- =>
- System.CRC32.Update
- (System.CRC32.CRC32 (Checksum),
- Character'Val (Token_Type'Pos (Token) - 2));
-
- when No_Token
- | Tok_Arrow
- | Tok_Comment
- | Tok_Dot_Dot
- | Tok_End_Of_Line
- | Tok_EOF
- | Tok_Extends
- | Tok_External
- | Tok_External_As_List
- | Tok_Function
- | Tok_Generic
- | Tok_Package
- | Tok_Private
- | Tok_Procedure
- | Tok_Project
- | Tok_Semicolon
- | Tok_Separate
- | Tok_SPARK_Hide
- | Tok_Special
- | Tok_Use
- | Tok_Vertical_Bar
- | Tok_With
- =>
- System.CRC32.Update
- (System.CRC32.CRC32 (Checksum),
- Character'Val (Token_Type'Pos (Token) - 4));
- end case;
- end Accumulate_Token_Checksum_GNAT_5_03;
-
-----------------------
-- Check_End_Of_Line --
-----------------------
@@ -1058,11 +742,7 @@ package body Scng is
end if;
end if;
- if Checksum_Accumulate_Token_Checksum then
- Accumulate_Token_Checksum;
- end if;
-
- return;
+ Accumulate_Token_Checksum;
end Nlit;
----------
@@ -1617,7 +1297,7 @@ package body Scng is
when '@' =>
if Ada_Version < Ada_2020 then
- Error_Msg ("target_name is an Ada 2020 feature", Scan_Ptr);
+ Error_Msg ("target_name is an Ada 202x feature", Scan_Ptr);
Scan_Ptr := Scan_Ptr + 1;
else
@@ -1701,7 +1381,7 @@ package body Scng is
if Source (Scan_Ptr + 1) = '"' then
goto Scan_Wide_Character;
- elsif Ada_Version = Ada_2020 then
+ elsif Ada_Version >= Ada_2020 then
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Left_Bracket;
return;
@@ -1980,47 +1660,6 @@ package body Scng is
Token := Tok_Comment;
return;
end if;
-
- -- If the SPARK restriction is set for this unit, then generate
- -- a token Tok_SPARK_Hide for a SPARK HIDE directive.
-
- if Restriction_Check_Required (SPARK_05)
- and then Source (Start_Of_Comment) = '#'
- then
- declare
- Scan_SPARK_Ptr : Source_Ptr;
-
- begin
- Scan_SPARK_Ptr := Start_Of_Comment + 1;
-
- -- Scan out blanks
-
- while Source (Scan_SPARK_Ptr) = ' '
- or else Source (Scan_SPARK_Ptr) = HT
- loop
- Scan_SPARK_Ptr := Scan_SPARK_Ptr + 1;
- end loop;
-
- -- Recognize HIDE directive. SPARK input cannot be
- -- encoded as wide characters, so only deal with
- -- lower/upper case.
-
- if (Source (Scan_SPARK_Ptr) = 'h'
- or else Source (Scan_SPARK_Ptr) = 'H')
- and then (Source (Scan_SPARK_Ptr + 1) = 'i'
- or else Source (Scan_SPARK_Ptr + 1) = 'I')
- and then (Source (Scan_SPARK_Ptr + 2) = 'd'
- or else Source (Scan_SPARK_Ptr + 2) = 'D')
- and then (Source (Scan_SPARK_Ptr + 3) = 'e'
- or else Source (Scan_SPARK_Ptr + 3) = 'E')
- and then (Source (Scan_SPARK_Ptr + 4) = ' '
- or else Source (Scan_SPARK_Ptr + 4) = HT)
- then
- Token := Tok_SPARK_Hide;
- return;
- end if;
- end;
- end if;
end if;
end Minus_Case;
@@ -2181,8 +1820,8 @@ package body Scng is
return;
- -- Right bracket or right brace, treated as right paren
- -- but proper aggregate delimiter in Ada_2020
+ -- Right bracket or right brace, treated as right paren but proper
+ -- aggregate delimiter in Ada 2020.
when ']' | '}' =>
if Ada_Version >= Ada_2020 then
@@ -2846,10 +2485,17 @@ package body Scng is
("wide character not allowed in identifier", Wptr);
end if;
+ -- AI12-0004: An identifier shall only contain characters
+ -- that may be present in Normalization Form KC.
+
+ if not Is_UTF_32_NFKC (UTF_32 (Code)) then
+ Error_Msg
+ ("invalid wide character in identifier", Wptr);
+
-- If OK letter, store it folding to upper case. Note
-- that we include the folded letter in the checksum.
- if Is_UTF_32_Letter (Cat) then
+ elsif Is_UTF_32_Letter (Cat) then
Code :=
Char_Code (UTF_32_To_Upper_Case (UTF_32 (Code)));
Accumulate_Checksum (Code);
@@ -2926,20 +2572,13 @@ package body Scng is
-- Here is where we check if it was a keyword
if Is_Keyword_Name (Token_Name) then
- if Opt.Checksum_GNAT_6_3 then
- Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
+ Accumulate_Token_Checksum;
+ Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
- if Checksum_Accumulate_Token_Checksum then
- if Checksum_GNAT_5_03 then
- Accumulate_Token_Checksum_GNAT_5_03;
- else
- Accumulate_Token_Checksum_GNAT_6_3;
- end if;
- end if;
+ -- See Exp_Put_Image for documentation of Tagged_Seen
- else
- Accumulate_Token_Checksum;
- Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
+ if Token = Tok_Tagged then
+ Tagged_Seen := True;
end if;
-- Keyword style checks
@@ -2997,12 +2636,8 @@ package body Scng is
-- It is an identifier after all
else
- if Checksum_Accumulate_Token_Checksum then
- Accumulate_Token_Checksum;
- end if;
-
+ Accumulate_Token_Checksum;
Post_Scan;
- return;
end if;
end Scan;
diff --git a/gcc/ada/scng.ads b/gcc/ada/scng.ads
index 9856399..d907d75 100644
--- a/gcc/ada/scng.ads
+++ b/gcc/ada/scng.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/scos.adb b/gcc/ada/scos.adb
index b36d5f9..c529fd6 100644
--- a/gcc/ada/scos.adb
+++ b/gcc/ada/scos.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads
index 9f56297..e23f3b5 100644
--- a/gcc/ada/scos.ads
+++ b/gcc/ada/scos.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -162,6 +162,8 @@ package SCOs is
-- R extended RETURN statement
-- S SELECT statement
-- W WHILE loop statement (from WHILE to end of condition)
+ -- X body of a degenerate subprogram (null procedure or
+ -- expression function)
-- Note: for I and W, condition above is in the RM syntax sense (this
-- condition is a decision in SCO terminology).
diff --git a/gcc/ada/scos.h b/gcc/ada/scos.h
index 53f9f38..2235ef7 100644
--- a/gcc/ada/scos.h
+++ b/gcc/ada/scos.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2014-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2014-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/sdefault.ads b/gcc/ada/sdefault.ads
index 91a1701..80a2bae 100644
--- a/gcc/ada/sdefault.ads
+++ b/gcc/ada/sdefault.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/seh_init.c b/gcc/ada/seh_init.c
index 2926605..27e6379 100644
--- a/gcc/ada/seh_init.c
+++ b/gcc/ada/seh_init.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2005-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2005-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb
index 2967a18..4429b6b 100644
--- a/gcc/ada/sem.adb
+++ b/gcc/ada/sem.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -670,6 +670,9 @@ package body Sem is
when N_Iterated_Component_Association =>
Diagnose_Iterated_Component_Association (N);
+ when N_Iterated_Element_Association =>
+ null; -- May require a more precise error if misplaced.
+
-- For the remaining node types, we generate compiler abort, because
-- these nodes are always analyzed within the Sem_Chn routines and
-- there should never be a case of making a call to the main Analyze
@@ -796,7 +799,7 @@ package body Sem is
-- and because the reference may become overloaded in the instance.
elsif GNATprove_Mode
- and then Nkind_In (N, N_Expanded_Name, N_Identifier)
+ and then Nkind (N) in N_Expanded_Name | N_Identifier
and then not Is_Overloaded (N)
and then not Inside_A_Generic
then
@@ -819,7 +822,7 @@ package body Sem is
Scope_Suppress.Suppress := Svs;
end;
- elsif Suppress = Overflow_Check then
+ else
declare
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
@@ -1412,6 +1415,7 @@ package body Sem is
S_GNAT_Mode : constant Boolean := GNAT_Mode;
S_Global_Dis_Names : constant Boolean := Global_Discard_Names;
S_In_Assertion_Expr : constant Nat := In_Assertion_Expr;
+ S_In_Declare_Expr : constant Nat := In_Declare_Expr;
S_In_Default_Expr : constant Boolean := In_Default_Expr;
S_In_Spec_Expr : constant Boolean := In_Spec_Expression;
S_Inside_A_Generic : constant Boolean := Inside_A_Generic;
@@ -1523,6 +1527,7 @@ package body Sem is
Full_Analysis := True;
Inside_A_Generic := False;
In_Assertion_Expr := 0;
+ In_Declare_Expr := 0;
In_Default_Expr := False;
In_Spec_Expression := False;
Set_Comes_From_Source_Default (False);
@@ -1607,6 +1612,7 @@ package body Sem is
Global_Discard_Names := S_Global_Dis_Names;
GNAT_Mode := S_GNAT_Mode;
In_Assertion_Expr := S_In_Assertion_Expr;
+ In_Declare_Expr := S_In_Declare_Expr;
In_Default_Expr := S_In_Default_Expr;
In_Spec_Expression := S_In_Spec_Expr;
Inside_A_Generic := S_Inside_A_Generic;
@@ -1673,6 +1679,7 @@ package body Sem is
pragma Pack (Unit_Number_Set);
Main_CU : constant Node_Id := Cunit (Main_Unit);
+ Spec_CU : Node_Id := Empty;
Seen, Done : Unit_Number_Set := (others => False);
-- Seen (X) is True after we have seen unit X in the walk. This is used
@@ -1732,7 +1739,7 @@ package body Sem is
begin
-- Problem does not arise with main subprograms
- if not Nkind_In (MCU, N_Package_Body, N_Package_Declaration) then
+ if Nkind (MCU) not in N_Package_Body | N_Package_Declaration then
return False;
end if;
@@ -1841,13 +1848,18 @@ package body Sem is
procedure Assert_Done (Withed_Unit : Node_Id) is
begin
- if not Done (Get_Cunit_Unit_Number (Withed_Unit)) then
- if not Nkind_In
- (Unit (Withed_Unit),
- N_Generic_Package_Declaration,
- N_Package_Body,
- N_Package_Renaming_Declaration,
- N_Subprogram_Body)
+ if Withed_Unit /= Main_CU
+ and then not Done (Get_Cunit_Unit_Number (Withed_Unit))
+ then
+ -- N_Null_Statement will happen in case of a ghost unit
+ -- which gets rewritten.
+
+ if Nkind (Unit (Withed_Unit)) not in
+ N_Generic_Package_Declaration |
+ N_Package_Body |
+ N_Package_Renaming_Declaration |
+ N_Subprogram_Body |
+ N_Null_Statement
then
Write_Unit_Name
(Unit_Name (Get_Cunit_Unit_Number (Withed_Unit)));
@@ -1947,7 +1959,7 @@ package body Sem is
-- Process the unit if it is a spec or the main unit, if it
-- has no previous spec or we have done all other units.
- if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body)
+ if Nkind (Item) not in N_Package_Body | N_Subprogram_Body
or else Acts_As_Spec (CU)
then
if CU = Main_CU and then not Do_Main then
@@ -2146,27 +2158,43 @@ package body Sem is
null;
when others =>
- Par := Scope (Defining_Entity (Unit (CU)));
-
- if Is_Child_Unit (Defining_Entity (Unit (CU))) then
- while Present (Par)
- and then Par /= Standard_Standard
- and then Par /= Cunit_Entity (Main_Unit)
- loop
- Par := Scope (Par);
- end loop;
- end if;
- if Par /= Cunit_Entity (Main_Unit) then
- Do_Unit_And_Dependents (CU, N);
- end if;
+ -- Skip spec of main unit for now, we want to process it
+ -- after all other specs.
+ if Nkind (Unit (CU)) = N_Package_Declaration
+ and then Library_Unit (CU) = Main_CU
+ and then CU /= Main_CU
+ then
+ Spec_CU := CU;
+ else
+ Par := Scope (Defining_Entity (Unit (CU)));
+
+ if Is_Child_Unit (Defining_Entity (Unit (CU))) then
+ while Present (Par)
+ and then Par /= Standard_Standard
+ and then Par /= Cunit_Entity (Main_Unit)
+ loop
+ Par := Scope (Par);
+ end loop;
+ end if;
+
+ if Par /= Cunit_Entity (Main_Unit) then
+ Do_Unit_And_Dependents (CU, N);
+ end if;
+ end if;
end case;
end;
Next_Elmt (Cur);
end loop;
+ -- Now process main package spec if skipped
+
+ if Present (Spec_CU) then
+ Do_Unit_And_Dependents (Spec_CU, Unit (Spec_CU));
+ end if;
+
-- Now process package bodies on which main depends, followed by bodies
-- of parents, if present, and finally main itself.
@@ -2358,7 +2386,7 @@ package body Sem is
Action (Lib_Unit);
end if;
- Context_Item := Next (Context_Item);
+ Next (Context_Item);
end loop;
end Walk_Withs_Immediate;
diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads
index 0c3e6c2..f320b32 100644
--- a/gcc/ada/sem.ads
+++ b/gcc/ada/sem.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,7 +32,7 @@
-- Analysis implements the bulk of semantic analysis such as
-- name analysis and type resolution for declarations,
--- instructions and expressions. The main routine
+-- instructions and expressions. The main routine
-- driving this process is procedure Analyze given below.
-- This analysis phase is really a bottom up pass that is
-- achieved during the recursive traversal performed by the
@@ -51,7 +51,7 @@
-- recursive calls to itself to resolve operands.
-- Expansion if we are not generating code this phase is a no-op.
--- otherwise this phase expands, i.e. transforms, original
+-- Otherwise this phase expands, i.e. transforms, original
-- declaration, expressions or instructions into simpler
-- structures that can be handled by the back-end. This
-- phase is also in charge of generating code which is
@@ -72,7 +72,7 @@
-- up. For instructions and declarations, before the call to the Analyze
-- routine completes we perform expansion since at that point we have all
-- semantic information needed. For expression nodes, after the call to
--- Analysis terminates we invoke the Resolve routine to transmit top-down
+-- Analyze terminates we invoke the Resolve routine to transmit top-down
-- the type that was gathered by Analyze which will resolve possible
-- ambiguities in the expression. Just before the call to Resolve
-- terminates, the expression can be expanded since all the semantic
@@ -138,7 +138,7 @@
-- this is the one case where this model falls down. Here is how we patch
-- it up without causing too much distortion to our basic model.
--- A switch (In_Spec_Expression) is set to show that we are in the initial
+-- A flag (In_Spec_Expression) is set to show that we are in the initial
-- occurrence of a default expression. The analyzer is then called on this
-- expression with the switch set true. Analysis and resolution proceed almost
-- as usual, except that Freeze_Expression will not freeze non-static
@@ -178,7 +178,7 @@
-- needs to be called 100 times.)
-- The reason this mechanism does not work is that the expanded code for the
--- children is typically inserted above the parent and thus when the father
+-- children is typically inserted above the parent and thus when the parent
-- gets expanded no re-evaluation takes place. For instance in the case of
-- aggregates if "new Thing (Function_Call)" is expanded before the aggregate
-- the expanded code will be placed outside of the aggregate and when
@@ -245,13 +245,20 @@ package Sem is
In_Assertion_Expr : Nat := 0;
-- This is set non-zero if we are within the expression of an assertion
- -- pragma or aspect. It is a counter which is incremented at the start of
- -- expanding such an expression, and decremented on completion of expanding
- -- that expression. Probably a boolean would be good enough, since we think
- -- that such expressions cannot nest, but that might not be true in the
- -- future (e.g. if let expressions are added to Ada) so we prepare for that
- -- future possibility by making it a counter. As with In_Spec_Expression,
- -- it must be recursively saved and restored for a Semantics call.
+ -- pragma or aspect. It is incremented at the start of expanding such an
+ -- expression, and decremented on completion of expanding that
+ -- expression. This needs to be a counter, rather than a Boolean, because
+ -- assertions can contain declare_expressions, which can contain
+ -- assertions. As with In_Spec_Expression, it must be recursively saved and
+ -- restored for a Semantics call.
+
+ In_Declare_Expr : Nat := 0;
+ -- This is set non-zero if we are within a declare_expression. It is
+ -- incremented at the start of expanding such an expression, and
+ -- decremented on completion of expanding that expression. This needs to be
+ -- a counter, rather than a Boolean, because declare_expressions can
+ -- nest. As with In_Spec_Expression, it must be recursively saved and
+ -- restored for a Semantics call.
In_Compile_Time_Warning_Or_Error : Boolean := False;
-- Switch to indicate that we are validating a pragma Compile_Time_Warning
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index e41fcdb..f77230c 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -85,9 +85,8 @@ package body Sem_Aggr is
-- The node of the choice
end record;
- type Case_Table_Type is array (Nat range <>) of Case_Bounds;
- -- Table type used by Check_Case_Choices procedure. Entry zero is not
- -- used (reserved for the sort). Real entries start at one.
+ type Case_Table_Type is array (Pos range <>) of Case_Bounds;
+ -- Table type used by Check_Case_Choices procedure
-----------------------
-- Local Subprograms --
@@ -117,15 +116,6 @@ package body Sem_Aggr is
-- Expression is also OK in an instance or inlining context, because we
-- have already preanalyzed and it is known to be type correct.
- procedure Check_Qualified_Aggregate (Level : Nat; Expr : Node_Id);
- -- Given aggregate Expr, check that sub-aggregates of Expr that are nested
- -- at Level are qualified. If Level = 0, this applies to Expr directly.
- -- Only issue errors in formal verification mode.
-
- function Is_Top_Level_Aggregate (Expr : Node_Id) return Boolean;
- -- Return True of Expr is an aggregate not contained directly in another
- -- aggregate.
-
------------------------------------------------------
-- Subprograms used for RECORD AGGREGATE Processing --
------------------------------------------------------
@@ -147,9 +137,10 @@ package body Sem_Aggr is
--
-- Once this new Component_Association_List is built and all the semantic
-- checks performed, the original aggregate subtree is replaced with the
- -- new named record aggregate just built. Note that subtree substitution is
- -- performed with Rewrite so as to be able to retrieve the original
- -- aggregate.
+ -- new named record aggregate just built. This new record aggregate has no
+ -- positional associations, so its Expressions field is set to No_List.
+ -- Note that subtree substitution is performed with Rewrite so as to be
+ -- able to retrieve the original aggregate.
--
-- The aggregate subtree manipulation performed by Resolve_Record_Aggregate
-- yields the aggregate format expected by Gigi. Typically, this kind of
@@ -234,12 +225,6 @@ package body Sem_Aggr is
-- misspelling of one of the components of the Assoc_List. This is called
-- by Resolve_Aggr_Expr after producing an invalid component error message.
- procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id);
- -- An optimization: determine whether a discriminated subtype has a static
- -- constraint, and contains array components whose length is also static,
- -- either because they are constrained by the discriminant, or because the
- -- original component bounds are static.
-
-----------------------------------------------------
-- Subprograms used for ARRAY AGGREGATE Processing --
-----------------------------------------------------
@@ -730,125 +715,30 @@ package body Sem_Aggr is
end if;
end Check_Expr_OK_In_Limited_Aggregate;
- -------------------------------
- -- Check_Qualified_Aggregate --
- -------------------------------
-
- procedure Check_Qualified_Aggregate (Level : Nat; Expr : Node_Id) is
- Comp_Expr : Node_Id;
- Comp_Assn : Node_Id;
-
- begin
- if Level = 0 then
- if Nkind (Parent (Expr)) /= N_Qualified_Expression then
- Check_SPARK_05_Restriction ("aggregate should be qualified", Expr);
- end if;
-
- else
- Comp_Expr := First (Expressions (Expr));
- while Present (Comp_Expr) loop
- if Nkind (Comp_Expr) = N_Aggregate then
- Check_Qualified_Aggregate (Level - 1, Comp_Expr);
- end if;
-
- Comp_Expr := Next (Comp_Expr);
- end loop;
-
- Comp_Assn := First (Component_Associations (Expr));
- while Present (Comp_Assn) loop
- Comp_Expr := Expression (Comp_Assn);
-
- if Nkind (Comp_Expr) = N_Aggregate then
- Check_Qualified_Aggregate (Level - 1, Comp_Expr);
- end if;
-
- Comp_Assn := Next (Comp_Assn);
- end loop;
- end if;
- end Check_Qualified_Aggregate;
-
- ----------------------------------------
- -- Check_Static_Discriminated_Subtype --
- ----------------------------------------
-
- procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id) is
- Disc : constant Entity_Id := First_Discriminant (T);
- Comp : Entity_Id;
- Ind : Entity_Id;
-
- begin
- if Has_Record_Rep_Clause (T) then
- return;
-
- elsif Present (Next_Discriminant (Disc)) then
- return;
-
- elsif Nkind (V) /= N_Integer_Literal then
- return;
- end if;
-
- Comp := First_Component (T);
- while Present (Comp) loop
- if Is_Scalar_Type (Etype (Comp)) then
- null;
-
- elsif Is_Private_Type (Etype (Comp))
- and then Present (Full_View (Etype (Comp)))
- and then Is_Scalar_Type (Full_View (Etype (Comp)))
- then
- null;
-
- elsif Is_Array_Type (Etype (Comp)) then
- if Is_Bit_Packed_Array (Etype (Comp)) then
- return;
- end if;
-
- Ind := First_Index (Etype (Comp));
- while Present (Ind) loop
- if Nkind (Ind) /= N_Range
- or else Nkind (Low_Bound (Ind)) /= N_Integer_Literal
- or else Nkind (High_Bound (Ind)) /= N_Integer_Literal
- then
- return;
- end if;
-
- Next_Index (Ind);
- end loop;
-
- else
- return;
- end if;
-
- Next_Component (Comp);
- end loop;
-
- -- On exit, all components have statically known sizes
-
- Set_Size_Known_At_Compile_Time (T);
- end Check_Static_Discriminated_Subtype;
-
-------------------------
-- Is_Others_Aggregate --
-------------------------
function Is_Others_Aggregate (Aggr : Node_Id) return Boolean is
+ Assoc : constant List_Id := Component_Associations (Aggr);
+
begin
return No (Expressions (Aggr))
- and then
- Nkind (First (Choice_List (First (Component_Associations (Aggr))))) =
- N_Others_Choice;
+ and then Nkind (First (Choice_List (First (Assoc)))) = N_Others_Choice;
end Is_Others_Aggregate;
- ----------------------------
- -- Is_Top_Level_Aggregate --
- ----------------------------
+ -------------------------
+ -- Is_Single_Aggregate --
+ -------------------------
+
+ function Is_Single_Aggregate (Aggr : Node_Id) return Boolean is
+ Assoc : constant List_Id := Component_Associations (Aggr);
- function Is_Top_Level_Aggregate (Expr : Node_Id) return Boolean is
begin
- return Nkind (Parent (Expr)) /= N_Aggregate
- and then (Nkind (Parent (Expr)) /= N_Component_Association
- or else Nkind (Parent (Parent (Expr))) /= N_Aggregate);
- end Is_Top_Level_Aggregate;
+ return No (Expressions (Aggr))
+ and then No (Next (First (Assoc)))
+ and then No (Next (First (Choice_List (First (Assoc)))));
+ end Is_Single_Aggregate;
--------------------------------
-- Make_String_Into_Aggregate --
@@ -934,41 +824,6 @@ package body Sem_Aggr is
end;
end if;
- -- An unqualified aggregate is restricted in SPARK to:
-
- -- An aggregate item inside an aggregate for a multi-dimensional array
-
- -- An expression being assigned to an unconstrained array, but only if
- -- the aggregate specifies a value for OTHERS only.
-
- if Nkind (Parent (N)) = N_Qualified_Expression then
- if Is_Array_Type (Typ) then
- Check_Qualified_Aggregate (Number_Dimensions (Typ), N);
- else
- Check_Qualified_Aggregate (1, N);
- end if;
- else
- if Is_Array_Type (Typ)
- and then Nkind (Parent (N)) = N_Assignment_Statement
- and then not Is_Constrained (Etype (Name (Parent (N))))
- then
- if not Is_Others_Aggregate (N) then
- Check_SPARK_05_Restriction
- ("array aggregate should have only OTHERS", N);
- end if;
-
- elsif Is_Top_Level_Aggregate (N) then
- Check_SPARK_05_Restriction ("aggregate should be qualified", N);
-
- -- The legality of this unqualified aggregate is checked by calling
- -- Check_Qualified_Aggregate from one of its enclosing aggregate,
- -- unless one of these already causes an error to be issued.
-
- else
- null;
- end if;
- end if;
-
-- Check for aggregates not allowed in configurable run-time mode.
-- We allow all cases of aggregates that do not come from source, since
-- these are all assumed to be small (e.g. bounds of a string literal).
@@ -1105,23 +960,24 @@ package body Sem_Aggr is
if Nkind (Parent (N)) = N_Assignment_Statement
or else Inside_Init_Proc
or else (Is_Constrained (Typ)
- and then Nkind_In (Parent (N),
- N_Parameter_Association,
- N_Function_Call,
- N_Procedure_Call_Statement,
- N_Generic_Association,
- N_Formal_Object_Declaration,
- N_Simple_Return_Statement,
- N_Object_Declaration,
- N_Component_Declaration,
- N_Parameter_Specification,
- N_Qualified_Expression,
- N_Reference,
- N_Aggregate,
- N_Extension_Aggregate,
- N_Component_Association,
- N_Case_Expression_Alternative,
- N_If_Expression))
+ and then Nkind (Parent (N)) in
+ N_Parameter_Association
+ | N_Function_Call
+ | N_Procedure_Call_Statement
+ | N_Generic_Association
+ | N_Formal_Object_Declaration
+ | N_Simple_Return_Statement
+ | N_Object_Declaration
+ | N_Component_Declaration
+ | N_Parameter_Specification
+ | N_Qualified_Expression
+ | N_Reference
+ | N_Aggregate
+ | N_Extension_Aggregate
+ | N_Component_Association
+ | N_Case_Expression_Alternative
+ | N_If_Expression
+ | N_Expression_With_Actions)
then
Aggr_Resolved :=
Resolve_Array_Aggregate
@@ -1568,7 +1424,7 @@ package body Sem_Aggr is
if Is_Character_Type (Component_Typ)
and then No (Next_Index (Nxt_Ind))
- and then Nkind_In (Expr, N_String_Literal, N_Operator_Symbol)
+ and then Nkind (Expr) in N_String_Literal | N_Operator_Symbol
then
-- A string literal used in a multidimensional array
-- aggregate in place of the final one-dimensional
@@ -1643,7 +1499,7 @@ package body Sem_Aggr is
-- If an aggregate component has a type with predicates, an explicit
-- predicate check must be applied, as for an assignment statement,
- -- because the aggegate might not be expanded into individual
+ -- because the aggregate might not be expanded into individual
-- component assignments. If the expression covers several components
-- the analysis and the predicate check take place later.
@@ -1689,6 +1545,18 @@ package body Sem_Aggr is
Id : Entity_Id;
begin
+ -- An element iterator specification cannot appear in
+ -- an array aggregate because it does not provide index
+ -- values for the association. This must be a semantic
+ -- check because the parser cannot tell whether this is
+ -- an array aggregate or a container aggregate.
+
+ if Present (Iterator_Specification (N)) then
+ Error_Msg_N ("container element Iterator cannot appear "
+ & "in an array aggregate", N);
+ return;
+ end if;
+
Choice := First (Discrete_Choices (N));
while Present (Choice) loop
@@ -1830,8 +1698,8 @@ package body Sem_Aggr is
if Ada_Version = Ada_83
and then Assoc /= First (Component_Associations (N))
- and then Nkind_In (Parent (N), N_Assignment_Statement,
- N_Object_Declaration)
+ and then Nkind (Parent (N)) in
+ N_Assignment_Statement | N_Object_Declaration
then
Error_Msg_N
("(Ada 83) illegal context for OTHERS choice", N);
@@ -1863,14 +1731,10 @@ package body Sem_Aggr is
-- If the subtype has a static predicate, replace the
-- original choice with the list of individual values
- -- covered by the predicate. Do not perform this
- -- transformation if we need to preserve the source
- -- for ASIS use.
+ -- covered by the predicate.
-- This should be deferred to expansion time ???
- if Present (Static_Discrete_Predicate (E))
- and then not ASIS_Mode
- then
+ if Present (Static_Discrete_Predicate (E)) then
Delete_Choice := True;
New_Cs := New_List;
@@ -1975,9 +1839,8 @@ package body Sem_Aggr is
-- if a choice in an aggregate is a subtype indication these
-- denote the lowest and highest values of the subtype
- Table : Case_Table_Type (0 .. Case_Table_Size);
- -- Used to sort all the different choice values. Entry zero is
- -- reserved for sorting purposes.
+ Table : Case_Table_Type (1 .. Case_Table_Size);
+ -- Used to sort all the different choice values
Single_Choice : Boolean;
-- Set to true every time there is a single discrete choice in a
@@ -2059,16 +1922,6 @@ package body Sem_Aggr is
-- bounds of the array aggregate are within range.
Set_Do_Range_Check (Choice, False);
-
- -- In SPARK, the choice must be static
-
- if not (Is_OK_Static_Expression (Choice)
- or else (Nkind (Choice) = N_Range
- and then Is_OK_Static_Range (Choice)))
- then
- Check_SPARK_05_Restriction
- ("choice should be static", Choice);
- end if;
end if;
-- If we could not resolve the discrete choice stop here
@@ -2357,22 +2210,7 @@ package body Sem_Aggr is
if Lo_Dup > Hi_Dup then
null;
- -- Otherwise place proper message. Because
- -- of the missing expansion of subtypes with
- -- predicates in ASIS mode, do not report
- -- spurious overlap errors.
-
- elsif ASIS_Mode
- and then
- ((Is_Type (Entity (Table (J).Choice))
- and then Has_Predicates
- (Entity (Table (J).Choice)))
- or else
- (Is_Type (Entity (Table (K).Choice))
- and then Has_Predicates
- (Entity (Table (K).Choice))))
- then
- null;
+ -- Otherwise place proper message
else
-- We place message on later choice, with a
@@ -2801,6 +2639,260 @@ package body Sem_Aggr is
return Success;
end Resolve_Array_Aggregate;
+ ---------------------------------
+ -- Resolve_Container_Aggregate --
+ ---------------------------------
+
+ procedure Resolve_Container_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ procedure Resolve_Iterated_Component_Association
+ (Comp : Node_Id;
+ Key_Type : Entity_Id;
+ Elmt_Type : Entity_Id);
+ -- Resolve choices and expression in an iterated component association.
+ -- This is similar but not identical to the handling of this construct
+ -- in an array aggregate.
+ -- For a named container, the type of each choice must be compatible
+ -- with the key type. For a positional container, the choice must be
+ -- a subtype indication or an iterator specification that determines
+ -- an element type.
+
+ Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate);
+
+ Empty_Subp : Node_Id := Empty;
+ Add_Named_Subp : Node_Id := Empty;
+ Add_Unnamed_Subp : Node_Id := Empty;
+ New_Indexed_Subp : Node_Id := Empty;
+ Assign_Indexed_Subp : Node_Id := Empty;
+
+ --------------------------------------------
+ -- Resolve_Iterated_Component_Association --
+ --------------------------------------------
+
+ procedure Resolve_Iterated_Component_Association
+ (Comp : Node_Id;
+ Key_Type : Entity_Id;
+ Elmt_Type : Entity_Id)
+ is
+ Choice : Node_Id;
+ Ent : Entity_Id;
+ Expr : Node_Id;
+ Id : Entity_Id;
+ Iter : Node_Id;
+ Typ : Entity_Id := Empty;
+
+ begin
+ if Present (Iterator_Specification (Comp)) then
+ Iter := Copy_Separate_Tree (Iterator_Specification (Comp));
+ Analyze (Iter);
+ Typ := Etype (Defining_Identifier (Iter));
+
+ else
+ Choice := First (Discrete_Choices (Comp));
+
+ while Present (Choice) loop
+ Analyze (Choice);
+
+ -- Choice can be a subtype name, a range, or an expression
+
+ if Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ and then Base_Type (Entity (Choice)) = Base_Type (Key_Type)
+ then
+ null;
+
+ elsif Present (Key_Type) then
+ Analyze_And_Resolve (Choice, Key_Type);
+
+ else
+ Typ := Etype (Choice); -- assume unique for now
+ end if;
+
+ Next (Choice);
+ end loop;
+ end if;
+
+ -- Create a scope in which to introduce an index, which is usually
+ -- visible in the expression for the component, and needed for its
+ -- analysis.
+
+ Ent := New_Internal_Entity (E_Loop, Current_Scope, Sloc (Comp), 'L');
+ Set_Etype (Ent, Standard_Void_Type);
+ Set_Parent (Ent, Parent (Comp));
+ Push_Scope (Ent);
+ Id :=
+ Make_Defining_Identifier (Sloc (Comp),
+ Chars => Chars (Defining_Identifier (Comp)));
+
+ -- Insert and decorate the loop variable in the current scope.
+ -- The expression has to be analyzed once the loop variable is
+ -- directly visible. Mark the variable as referenced to prevent
+ -- spurious warnings, given that subsequent uses of its name in the
+ -- expression will reference the internal (synonym) loop variable.
+
+ Enter_Name (Id);
+
+ if No (Key_Type) then
+ pragma Assert (Present (Typ));
+ Set_Etype (Id, Typ);
+ else
+ Set_Etype (Id, Key_Type);
+ end if;
+
+ Set_Ekind (Id, E_Variable);
+ Set_Scope (Id, Ent);
+ Set_Referenced (Id);
+
+ -- Analyze a copy of the expression, to verify legality. We use
+ -- a copy because the expression will be analyzed anew when the
+ -- enclosing aggregate is expanded, and the construct is rewritten
+ -- as a loop with a new index variable.
+
+ Expr := New_Copy_Tree (Expression (Comp));
+ Preanalyze_And_Resolve (Expr, Elmt_Type);
+ End_Scope;
+ end Resolve_Iterated_Component_Association;
+
+ begin
+ pragma Assert (Nkind (Asp) = N_Aggregate);
+
+ Set_Etype (N, Typ);
+ Parse_Aspect_Aggregate (Asp,
+ Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp,
+ New_Indexed_Subp, Assign_Indexed_Subp);
+
+ if Present (Add_Unnamed_Subp)
+ and then No (New_Indexed_Subp)
+ then
+ declare
+ Elmt_Type : constant Entity_Id :=
+ Etype (Next_Formal
+ (First_Formal (Entity (Add_Unnamed_Subp))));
+ Comp : Node_Id;
+
+ begin
+ if Present (Expressions (N)) then
+ -- positional aggregate
+
+ Comp := First (Expressions (N));
+ while Present (Comp) loop
+ Analyze_And_Resolve (Comp, Elmt_Type);
+ Next (Comp);
+ end loop;
+ end if;
+
+ -- Empty aggregate, to be replaced by Empty during
+ -- expansion, or iterated component association.
+
+ if Present (Component_Associations (N)) then
+ declare
+ Comp : Node_Id := First (Component_Associations (N));
+ begin
+ while Present (Comp) loop
+ if Nkind (Comp) /=
+ N_Iterated_Component_Association
+ then
+ Error_Msg_N ("illegal component association "
+ & "for unnamed container aggregate", Comp);
+ return;
+ else
+ Resolve_Iterated_Component_Association
+ (Comp, Empty, Elmt_Type);
+ end if;
+
+ Next (Comp);
+ end loop;
+ end;
+ end if;
+ end;
+
+ elsif Present (Add_Named_Subp) then
+ declare
+ -- Retrieves types of container, key, and element from the
+ -- specified insertion procedure.
+
+ Container : constant Entity_Id :=
+ First_Formal (Entity (Add_Named_Subp));
+ Key_Type : constant Entity_Id := Etype (Next_Formal (Container));
+ Elmt_Type : constant Entity_Id :=
+ Etype (Next_Formal (Next_Formal (Container)));
+ Comp : Node_Id;
+ Choice : Node_Id;
+
+ begin
+ Comp := First (Component_Associations (N));
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Component_Association then
+ Choice := First (Choices (Comp));
+
+ while Present (Choice) loop
+ Analyze_And_Resolve (Choice, Key_Type);
+ if not Is_Static_Expression (Choice) then
+ Error_Msg_N ("Choice must be static", Choice);
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ Analyze_And_Resolve (Expression (Comp), Elmt_Type);
+
+ elsif Nkind (Comp) = N_Iterated_Component_Association then
+ Resolve_Iterated_Component_Association
+ (Comp, Key_Type, Elmt_Type);
+ end if;
+
+ Next (Comp);
+ end loop;
+ end;
+
+ else
+ -- Indexed Aggregate. Both positional and indexed component
+ -- can be present. Choices must be static values or ranges
+ -- with static bounds.
+
+ declare
+ Container : constant Entity_Id :=
+ First_Formal (Entity (Assign_Indexed_Subp));
+ Index_Type : constant Entity_Id := Etype (Next_Formal (Container));
+ Comp_Type : constant Entity_Id :=
+ Etype (Next_Formal (Next_Formal (Container)));
+ Comp : Node_Id;
+ Choice : Node_Id;
+
+ begin
+ if Present (Expressions (N)) then
+ Comp := First (Expressions (N));
+ while Present (Comp) loop
+ Analyze_And_Resolve (Comp, Comp_Type);
+ Next (Comp);
+ end loop;
+ end if;
+
+ if Present (Component_Associations (N)) then
+ Comp := First (Expressions (N));
+
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Component_Association then
+ Choice := First (Choices (Comp));
+
+ while Present (Choice) loop
+ Analyze_And_Resolve (Choice, Index_Type);
+ Next (Choice);
+ end loop;
+
+ Analyze_And_Resolve (Expression (Comp), Comp_Type);
+
+ elsif Nkind (Comp) = N_Iterated_Component_Association then
+ Resolve_Iterated_Component_Association
+ (Comp, Index_Type, Comp_Type);
+ end if;
+
+ Next (Comp);
+ end loop;
+ end if;
+ end;
+ end if;
+ end Resolve_Container_Aggregate;
+
-----------------------------
-- Resolve_Delta_Aggregate --
-----------------------------
@@ -2811,7 +2903,7 @@ package body Sem_Aggr is
begin
if Ada_Version < Ada_2020 then
Error_Msg_N ("delta_aggregate is an Ada 202x feature", N);
- Error_Msg_N ("\compile with -gnatX", N);
+ Error_Msg_N ("\compile with -gnat2020", N);
end if;
if not Is_Composite_Type (Typ) then
@@ -2834,15 +2926,13 @@ package body Sem_Aggr is
-----------------------------------
procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id) is
- Deltas : constant List_Id := Component_Associations (N);
+ Deltas : constant List_Id := Component_Associations (N);
+ Index_Type : constant Entity_Id := Etype (First_Index (Typ));
- Assoc : Node_Id;
- Choice : Node_Id;
- Index_Type : Entity_Id;
+ Assoc : Node_Id;
+ Choice : Node_Id;
begin
- Index_Type := Etype (First_Index (Typ));
-
Assoc := First (Deltas);
while Present (Assoc) loop
if Nkind (Assoc) = N_Iterated_Component_Association then
@@ -2936,9 +3026,9 @@ package body Sem_Aggr is
-- part, verify that it is within the same variant as that of previous
-- specified variant components of the delta.
- function Get_Component_Type (Nam : Node_Id) return Entity_Id;
- -- Locate component with a given name and return its type. If none found
- -- report error.
+ function Get_Component (Nam : Node_Id) return Entity_Id;
+ -- Locate component with a given name and return it. If none found then
+ -- report error and return Empty.
function Nested_In (V1 : Node_Id; V2 : Node_Id) return Boolean;
-- Determine whether variant V1 is within variant V2
@@ -3002,11 +3092,11 @@ package body Sem_Aggr is
end if;
end Check_Variant;
- ------------------------
- -- Get_Component_Type --
- ------------------------
+ -------------------
+ -- Get_Component --
+ -------------------
- function Get_Component_Type (Nam : Node_Id) return Entity_Id is
+ function Get_Component (Nam : Node_Id) return Entity_Id is
Comp : Entity_Id;
begin
@@ -3017,15 +3107,15 @@ package body Sem_Aggr is
Error_Msg_N ("delta cannot apply to discriminant", Nam);
end if;
- return Etype (Comp);
+ return Comp;
end if;
- Comp := Next_Entity (Comp);
+ Next_Entity (Comp);
end loop;
Error_Msg_NE ("type& has no component with this name", Nam, Typ);
- return Any_Type;
- end Get_Component_Type;
+ return Empty;
+ end Get_Component;
---------------
-- Nested_In --
@@ -3072,6 +3162,7 @@ package body Sem_Aggr is
Assoc : Node_Id;
Choice : Node_Id;
+ Comp : Entity_Id;
Comp_Type : Entity_Id := Empty; -- init to avoid warning
-- Start of processing for Resolve_Delta_Record_Aggregate
@@ -3083,10 +3174,21 @@ package body Sem_Aggr is
while Present (Assoc) loop
Choice := First (Choice_List (Assoc));
while Present (Choice) loop
- Comp_Type := Get_Component_Type (Choice);
+ Comp := Get_Component (Choice);
- if Comp_Type /= Any_Type then
+ if Present (Comp) then
Check_Variant (Choice);
+
+ Comp_Type := Etype (Comp);
+
+ -- Decorate the component reference by setting its entity and
+ -- type, as otherwise backends like GNATprove would have to
+ -- rediscover this information by themselves.
+
+ Set_Entity (Choice, Comp);
+ Set_Etype (Choice, Comp_Type);
+ else
+ Comp_Type := Any_Type;
end if;
Next (Choice);
@@ -3151,9 +3253,9 @@ package body Sem_Aggr is
-- The ancestor must be a call or an aggregate, but a call may
-- have been expanded into a temporary, so check original node.
- elsif Nkind_In (Anc, N_Aggregate,
- N_Extension_Aggregate,
- N_Function_Call)
+ elsif Nkind (Anc) in N_Aggregate
+ | N_Extension_Aggregate
+ | N_Function_Call
then
return True;
@@ -3259,15 +3361,12 @@ package body Sem_Aggr is
Analyze (A);
Check_Parameterless_Call (A);
- -- In SPARK, the ancestor part cannot be a type mark
-
if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
- Check_SPARK_05_Restriction ("ancestor part cannot be a type mark", A);
-- AI05-0115: if the ancestor part is a subtype mark, the ancestor
-- must not have unknown discriminants.
- if Has_Unknown_Discriminants (Root_Type (Typ)) then
+ if Has_Unknown_Discriminants (Entity (A)) then
Error_Msg_NE
("aggregate not available for type& whose ancestor "
& "has unknown discriminants", N, Typ);
@@ -3459,7 +3558,7 @@ package body Sem_Aggr is
Box_Node : Node_Id := Empty;
Is_Box_Present : Boolean := False;
- Others_Box : Integer := 0;
+ Others_Box : Natural := 0;
-- Ada 2005 (AI-287): Variables used in case of default initialization
-- to provide a functionality similar to Others_Etype. Box_Present
-- indicates that the component takes its default initialization;
@@ -3512,7 +3611,7 @@ package body Sem_Aggr is
-- of the ancestor.
function Get_Value
- (Compon : Node_Id;
+ (Compon : Entity_Id;
From : List_Id;
Consider_Others_Choice : Boolean := False) return Node_Id;
-- Given a record component stored in parameter Compon, this function
@@ -3569,6 +3668,8 @@ package body Sem_Aggr is
-- If this is a box association the expression is missing, so use the
-- Sloc of the aggregate itself for the new association.
+ pragma Assert (Present (Expr) xor Is_Box_Present);
+
if Present (Expr) then
Loc := Sloc (Expr);
else
@@ -3788,7 +3889,7 @@ package body Sem_Aggr is
---------------
function Get_Value
- (Compon : Node_Id;
+ (Compon : Entity_Id;
From : List_Id;
Consider_Others_Choice : Boolean := False) return Node_Id
is
@@ -3868,22 +3969,9 @@ package body Sem_Aggr is
-- access types, even in compile_only mode.
if not Inside_A_Generic then
-
- -- In ASIS mode, preanalyze the expression in an
- -- others association before making copies for
- -- separate resolution and accessibility checks.
- -- This ensures that the type of the expression is
- -- available to ASIS in all cases, in particular if
- -- the expression is itself an aggregate.
-
- if ASIS_Mode then
- Preanalyze_And_Resolve (Expression (Assoc), Typ);
- end if;
-
return
New_Copy_Tree_And_Copy_Dimensions
(Expression (Assoc));
-
else
return Expression (Assoc);
end if;
@@ -3993,8 +4081,6 @@ package body Sem_Aggr is
is
Loc : constant Source_Ptr := Sloc (N);
- Needs_Box : Boolean := False;
-
procedure Process_Component (Comp : Entity_Id);
-- Add one component with a box association to the inner aggregate,
-- and recurse if component is itself composite.
@@ -4009,7 +4095,7 @@ package body Sem_Aggr is
begin
if Is_Record_Type (T) and then Has_Discriminants (T) then
- New_Aggr := Make_Aggregate (Loc, New_List, New_List);
+ New_Aggr := Make_Aggregate (Loc, No_List, New_List);
Set_Etype (New_Aggr, T);
Add_Association
@@ -4020,8 +4106,12 @@ package body Sem_Aggr is
Add_Discriminant_Values (New_Aggr, Assoc_List);
Propagate_Discriminants (New_Aggr, Assoc_List);
+ Build_Constrained_Itype
+ (New_Aggr, T, Component_Associations (New_Aggr));
else
- Needs_Box := True;
+ Add_Association
+ (Comp, Empty, Component_Associations (Aggr),
+ Is_Box_Present => True);
end if;
end Process_Component;
@@ -4072,14 +4162,6 @@ package body Sem_Aggr is
Next_Component (Comp);
end loop;
end if;
-
- if Needs_Box then
- Append_To (Component_Associations (Aggr),
- Make_Component_Association (Loc,
- Choices => New_List (Make_Others_Choice (Loc)),
- Expression => Empty,
- Box_Present => True));
- end if;
end Propagate_Discriminants;
-----------------------
@@ -4103,7 +4185,7 @@ package body Sem_Aggr is
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is
begin
return
- (Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate)
+ (Nkind (Expr) in N_Aggregate | N_Extension_Aggregate
and then Present (Etype (Expr))
and then Is_Record_Type (Etype (Expr))
and then Expansion_Delayed (Expr))
@@ -4226,7 +4308,7 @@ package body Sem_Aggr is
-- If an aggregate component has a type with predicates, an explicit
-- predicate check must be applied, as for an assignment statement,
- -- because the aggegate might not be expanded into individual
+ -- because the aggregate might not be expanded into individual
-- component assignments.
if Has_Predicates (Expr_Type)
@@ -4350,12 +4432,6 @@ package body Sem_Aggr is
if Present (Component_Associations (N))
and then Present (First (Component_Associations (N)))
then
- if Present (Expressions (N)) then
- Check_SPARK_05_Restriction
- ("named association cannot follow positional one",
- First (Choices (First (Component_Associations (N)))));
- end if;
-
declare
Assoc : Node_Id;
@@ -4367,21 +4443,9 @@ package body Sem_Aggr is
("iterated component association can only appear in an "
& "array aggregate", N);
raise Unrecoverable_Error;
-
- else
- if List_Length (Choices (Assoc)) > 1 then
- Check_SPARK_05_Restriction
- ("component association in record aggregate must "
- & "contain a single choice", Assoc);
- end if;
-
- if Nkind (First (Choices (Assoc))) = N_Others_Choice then
- Check_SPARK_05_Restriction
- ("record aggregate cannot contain OTHERS", Assoc);
- end if;
end if;
- Assoc := Next (Assoc);
+ Next (Assoc);
end loop;
end;
end if;
@@ -4502,6 +4566,10 @@ package body Sem_Aggr is
-- AI05-0115: if the ancestor part is a subtype mark, the ancestor
-- must not have unknown discriminants.
+ -- ??? We are not checking any subtype mark here and this code is not
+ -- exercised by any test, so it's likely wrong (in particular
+ -- we should not use Root_Type here but the subtype mark, if any),
+ -- and possibly not needed.
if Is_Derived_Type (Typ)
and then Has_Unknown_Discriminants (Root_Type (Typ))
@@ -4583,75 +4651,11 @@ package body Sem_Aggr is
-- STEP 4: Set the Etype of the record aggregate
- -- ??? This code is pretty much a copy of Sem_Ch3.Build_Subtype. That
- -- routine should really be exported in sem_util or some such and used
- -- in sem_ch3 and here rather than have a copy of the code which is a
- -- maintenance nightmare.
-
- -- ??? Performance WARNING. The current implementation creates a new
- -- itype for all aggregates whose base type is discriminated. This means
- -- that for record aggregates nested inside an array aggregate we will
- -- create a new itype for each record aggregate if the array component
- -- type has discriminants. For large aggregates this may be a problem.
- -- What should be done in this case is to reuse itypes as much as
- -- possible.
-
if Has_Discriminants (Typ)
or else (Has_Unknown_Discriminants (Typ)
and then Present (Underlying_Record_View (Typ)))
then
- Build_Constrained_Itype : declare
- Constrs : constant List_Id := New_List;
- Loc : constant Source_Ptr := Sloc (N);
- Def_Id : Entity_Id;
- Indic : Node_Id;
- New_Assoc : Node_Id;
- Subtyp_Decl : Node_Id;
-
- begin
- New_Assoc := First (New_Assoc_List);
- while Present (New_Assoc) loop
- Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc)));
- Next (New_Assoc);
- end loop;
-
- if Has_Unknown_Discriminants (Typ)
- and then Present (Underlying_Record_View (Typ))
- then
- Indic :=
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Underlying_Record_View (Typ), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => Constrs));
- else
- Indic :=
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Base_Type (Typ), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => Constrs));
- end if;
-
- Def_Id := Create_Itype (Ekind (Typ), N);
-
- Subtyp_Decl :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Subtype_Indication => Indic);
- Set_Parent (Subtyp_Decl, Parent (N));
-
- -- Itypes must be analyzed with checks off (see itypes.ads)
-
- Analyze (Subtyp_Decl, Suppress => All_Checks);
-
- Set_Etype (N, Def_Id);
- Check_Static_Discriminated_Subtype
- (Def_Id, Expression (First (New_Assoc_List)));
- end Build_Constrained_Itype;
-
+ Build_Constrained_Itype (N, Typ, New_Assoc_List);
else
Set_Etype (N, Typ);
end if;
@@ -5062,7 +5066,7 @@ package body Sem_Aggr is
Expr : Node_Id;
begin
- Expr := Make_Aggregate (Loc, New_List, New_List);
+ Expr := Make_Aggregate (Loc, No_List, New_List);
Set_Etype (Expr, Ctyp);
-- If the enclosing type has discriminants, they have
@@ -5082,6 +5086,9 @@ package body Sem_Aggr is
Propagate_Discriminants
(Expr, Component_Associations (Expr));
+ Build_Constrained_Itype
+ (Expr, Ctyp, Component_Associations (Expr));
+
else
declare
Comp : Entity_Id;
diff --git a/gcc/ada/sem_aggr.ads b/gcc/ada/sem_aggr.ads
index 1d4f348..b0b4e14 100644
--- a/gcc/ada/sem_aggr.ads
+++ b/gcc/ada/sem_aggr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,10 +33,14 @@ package Sem_Aggr is
procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Container_Aggregate (N : Node_Id; Typ : Entity_Id);
function Is_Others_Aggregate (Aggr : Node_Id) return Boolean;
-- Returns True is aggregate Aggr consists of a single OTHERS choice
+ function Is_Single_Aggregate (Aggr : Node_Id) return Boolean;
+ -- Returns True is aggregate Aggr consists of a single choice
+
-- WARNING: There is a matching C declaration of this subprogram in fe.h
end Sem_Aggr;
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 190d281..e3c027d 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -164,6 +164,15 @@ package body Sem_Attr is
Attribute_Max_Alignment_For_Allocation => True,
others => False);
+ -- The following array is the list of attributes defined in the Ada 2020
+ -- RM which are not defined in Ada 2012. These are recognized in Ada
+ -- 95/2005/2012 modes, but are considered to be implementation defined.
+
+ Attribute_20 : constant Attribute_Class_Array := Attribute_Class_Array'(
+ Attribute_Enum_Rep |
+ Attribute_Enum_Val => True,
+ others => False);
+
-- The following array contains all attributes that imply a modification
-- of their prefixes or result in an access value. Such prefixes can be
-- considered as lvalues.
@@ -211,15 +220,6 @@ package body Sem_Attr is
-- Standard_True, depending on the value of the parameter B. The
-- result is marked as a static expression.
- function Statically_Denotes_Object (N : Node_Id) return Boolean;
- -- Predicate used to check the legality of the prefix to 'Loop_Entry and
- -- 'Old, when the prefix is not an entity name. Current RM specfies that
- -- the prefix must be a direct or expanded name, but it has been proposed
- -- that the prefix be allowed to be a selected component that does not
- -- depend on a discriminant, or an indexed component with static indices.
- -- Current code for this predicate implements this more permissive
- -- implementation.
-
-----------------------
-- Analyze_Attribute --
-----------------------
@@ -350,9 +350,6 @@ package body Sem_Attr is
-- Verify that prefix of attribute N is a float type and that
-- two attribute expressions are present
- procedure Check_SPARK_05_Restriction_On_Attribute;
- -- Issue an error in formal mode because attribute N is allowed
-
procedure Check_Integer_Type;
-- Verify that prefix of attribute N is an integer type
@@ -391,6 +388,9 @@ package body Sem_Attr is
-- corresponding possible defined attribute function (e.g. for the
-- Read attribute, Nam will be TSS_Stream_Read).
+ procedure Check_Put_Image_Attribute;
+ -- Validity checking for Put_Image attribute
+
procedure Check_System_Prefix;
-- Verify that prefix of attribute N is package System
@@ -525,7 +525,7 @@ package body Sem_Attr is
-- Object or label reference
- elsif Is_Object (Ent) or else Ekind (Ent) = E_Label then
+ elsif Is_Object_Reference (P) or else Ekind (Ent) = E_Label then
Set_Address_Taken (Ent);
-- Deal with No_Implicit_Aliasing restriction
@@ -650,7 +650,8 @@ package body Sem_Attr is
-- tracked value. If the scope is a loop or block, indicate that
-- value tracking is disabled for the enclosing subprogram.
- function Get_Kind (E : Entity_Id) return Entity_Kind;
+ function Get_Convention (E : Entity_Id) return Convention_Id;
+ function Get_Kind (E : Entity_Id) return Entity_Kind;
-- Distinguish between access to regular/protected subprograms
------------------------
@@ -666,13 +667,33 @@ package body Sem_Attr is
end if;
end Check_Local_Access;
+ --------------------
+ -- Get_Convention --
+ --------------------
+
+ function Get_Convention (E : Entity_Id) return Convention_Id is
+ begin
+ -- Restrict handling by_protected_procedure access subprograms
+ -- to source entities; required to avoid building access to
+ -- subprogram types with convention protected when building
+ -- dispatch tables.
+
+ if Comes_From_Source (P)
+ and then Is_By_Protected_Procedure (E)
+ then
+ return Convention_Protected;
+ else
+ return Convention (E);
+ end if;
+ end Get_Convention;
+
--------------
-- Get_Kind --
--------------
function Get_Kind (E : Entity_Id) return Entity_Kind is
begin
- if Convention (E) = Convention_Protected then
+ if Get_Convention (E) = Convention_Protected then
return E_Access_Protected_Subprogram_Type;
else
return E_Access_Subprogram_Type;
@@ -717,7 +738,7 @@ package body Sem_Attr is
Acc_Type := Create_Itype (Get_Kind (Entity (P)), N);
Set_Is_Public (Acc_Type, False);
Set_Etype (Acc_Type, Acc_Type);
- Set_Convention (Acc_Type, Convention (Entity (P)));
+ Set_Convention (Acc_Type, Get_Convention (Entity (P)));
Set_Directly_Designated_Type (Acc_Type, Entity (P));
Set_Etype (N, Acc_Type);
Freeze_Before (N, Acc_Type);
@@ -732,7 +753,7 @@ package body Sem_Attr is
Acc_Type := Create_Itype (Get_Kind (It.Nam), N);
Set_Is_Public (Acc_Type, False);
Set_Etype (Acc_Type, Acc_Type);
- Set_Convention (Acc_Type, Convention (It.Nam));
+ Set_Convention (Acc_Type, Get_Convention (It.Nam));
Set_Directly_Designated_Type (Acc_Type, It.Nam);
Add_One_Interp (N, Acc_Type, Acc_Type);
Freeze_Before (N, Acc_Type);
@@ -765,7 +786,7 @@ package body Sem_Attr is
(Nkind (Par) = N_Component_Association
or else Nkind (Par) in N_Subexpr)
loop
- if Nkind_In (Par, N_Aggregate, N_Extension_Aggregate) then
+ if Nkind (Par) in N_Aggregate | N_Extension_Aggregate then
if Etype (Par) = Typ then
Set_Has_Self_Reference (Par);
@@ -801,7 +822,14 @@ package body Sem_Attr is
-- Start of processing for Analyze_Access_Attribute
begin
- Check_SPARK_05_Restriction_On_Attribute;
+ -- Access and Unchecked_Access are illegal in declare_expressions,
+ -- according to the RM. We also make the GNAT-specific
+ -- Unrestricted_Access attribute illegal.
+
+ if In_Declare_Expr > 0 then
+ Error_Attr ("% attribute cannot occur in a declare_expression", N);
+ end if;
+
Check_E0;
if Nkind (P) = N_Character_Literal then
@@ -960,9 +988,10 @@ package body Sem_Attr is
if not In_Spec_Expression
and then not Has_Completion (Scop)
- and then not
- Nkind_In (Parent (N), N_Discriminant_Association,
- N_Index_Or_Discriminant_Constraint)
+ and then
+ Nkind (Parent (N)) not in
+ N_Discriminant_Association |
+ N_Index_Or_Discriminant_Constraint
then
Error_Msg_N
("current instance attribute must appear alone", N);
@@ -1085,8 +1114,7 @@ package body Sem_Attr is
Kill_Current_Values (Ent);
exit;
- elsif Nkind_In (PP, N_Selected_Component,
- N_Indexed_Component)
+ elsif Nkind (PP) in N_Selected_Component | N_Indexed_Component
then
PP := Prefix (PP);
@@ -1140,10 +1168,10 @@ package body Sem_Attr is
begin
-- The "Name" argument of pragma Check denotes a postcondition
- if Nam_In (Nam, Name_Post,
- Name_Post_Class,
- Name_Postcondition,
- Name_Refined_Post)
+ if Nam in Name_Post
+ | Name_Post_Class
+ | Name_Postcondition
+ | Name_Refined_Post
then
null;
@@ -1289,7 +1317,7 @@ package body Sem_Attr is
Prag := N;
while Present (Prag) loop
- if Nkind_In (Prag, N_Aspect_Specification, N_Pragma) then
+ if Nkind (Prag) in N_Aspect_Specification | N_Pragma then
exit;
-- Prevent the search from going too far
@@ -1304,7 +1332,7 @@ package body Sem_Attr is
-- The attribute is allowed to appear only in postcondition-like
-- aspects or pragmas.
- if Nkind_In (Prag, N_Aspect_Specification, N_Pragma) then
+ if Nkind (Prag) in N_Aspect_Specification | N_Pragma then
if Nkind (Prag) = N_Aspect_Specification then
Prag_Nam := Chars (Identifier (Prag));
else
@@ -1320,15 +1348,23 @@ package body Sem_Attr is
-- Attribute 'Result is allowed to appear in aspect or pragma
-- [Refined_]Depends (SPARK RM 6.1.5(11)).
- elsif Nam_In (Prag_Nam, Name_Depends, Name_Refined_Depends)
+ elsif Prag_Nam in Name_Depends | Name_Refined_Depends
+ and then Aname = Name_Result
+ then
+ null;
+
+ -- Attribute 'Result is allowed to appear in aspect
+ -- Relaxed_Initialization (SPARK RM 6.10).
+
+ elsif Prag_Nam = Name_Relaxed_Initialization
and then Aname = Name_Result
then
null;
- elsif Nam_In (Prag_Nam, Name_Post,
- Name_Post_Class,
- Name_Postcondition,
- Name_Refined_Post)
+ elsif Prag_Nam in Name_Post
+ | Name_Post_Class
+ | Name_Postcondition
+ | Name_Refined_Post
then
null;
@@ -1372,14 +1408,14 @@ package body Sem_Attr is
then
null;
- elsif not Nkind_In (Subp_Decl, N_Abstract_Subprogram_Declaration,
- N_Entry_Declaration,
- N_Expression_Function,
- N_Generic_Subprogram_Declaration,
- N_Subprogram_Body,
- N_Subprogram_Body_Stub,
- N_Subprogram_Declaration,
- N_Subprogram_Renaming_Declaration)
+ elsif Nkind (Subp_Decl) not in N_Abstract_Subprogram_Declaration
+ | N_Entry_Declaration
+ | N_Expression_Function
+ | N_Generic_Subprogram_Declaration
+ | N_Subprogram_Body
+ | N_Subprogram_Body_Stub
+ | N_Subprogram_Declaration
+ | N_Subprogram_Renaming_Declaration
then
return;
end if;
@@ -1415,58 +1451,58 @@ package body Sem_Attr is
-----------------------------
procedure Analyze_Image_Attribute (Str_Typ : Entity_Id) is
- begin
- Check_SPARK_05_Restriction_On_Attribute;
+ procedure Check_Image_Type (Image_Type : Entity_Id);
+ -- Check that Image_Type is legal as the type of a prefix of 'Image.
+ -- Legality depends on the Ada language version.
+
+ procedure Check_Image_Type (Image_Type : Entity_Id) is
+ begin
+ if Ada_Version < Ada_2020
+ and then not Is_Scalar_Type (Image_Type)
+ then
+ Error_Msg_Ada_2020_Feature ("|nonscalar ''Image", Sloc (P));
+ Error_Attr;
+ end if;
+ end Check_Image_Type;
+
+ -- Start of processing for Analyze_Image_Attribute
- -- AI12-00124: The ARG has adopted the GNAT semantics of 'Img for
+ begin
+ -- AI12-0124: The ARG has adopted the GNAT semantics of 'Img for
-- scalar types, so that the prefix can be an object, a named value,
- -- or a type, and there is no need for an argument in this case.
+ -- or a type. If the prefix is an object, there is no argument.
- if Attr_Id = Attribute_Img
- or else (Ada_Version > Ada_2005 and then Is_Object_Image (P))
- then
+ if Is_Object_Image (P) then
Check_E0;
Set_Etype (N, Str_Typ);
+ Check_Image_Type (Etype (P));
- if Attr_Id = Attribute_Img and then not Is_Object_Image (P) then
- Error_Attr_P
- ("prefix of % attribute must be a scalar object name");
+ if Attr_Id /= Attribute_Img and then Ada_Version < Ada_2012 then
+ Error_Msg_Ada_2012_Feature ("|Object''Image", Sloc (P));
end if;
else
Check_E1;
Set_Etype (N, Str_Typ);
- -- Check that the prefix type is scalar - much in the same way as
- -- Check_Scalar_Type but with custom error messages to denote the
- -- variants of 'Image attributes.
+ -- ???It's not clear why 'Img should behave any differently than
+ -- 'Image.
- if Is_Entity_Name (P)
- and then Is_Type (Entity (P))
- and then Ekind (Entity (P)) = E_Incomplete_Type
+ if Attr_Id = Attribute_Img then
+ Error_Attr_P
+ ("prefix of % attribute must be a scalar object name");
+ end if;
+
+ pragma Assert (Is_Entity_Name (P) and then Is_Type (Entity (P)));
+
+ if Ekind (Entity (P)) = E_Incomplete_Type
and then Present (Full_View (Entity (P)))
then
P_Type := Full_View (Entity (P));
+ P_Base_Type := Base_Type (P_Type);
Set_Entity (P, P_Type);
end if;
- if not Is_Entity_Name (P)
- or else not Is_Type (Entity (P))
- or else not Is_Scalar_Type (P_Type)
- then
- if Ada_Version > Ada_2005 then
- Error_Attr_P
- ("prefix of % attribute must be a scalar type or a scalar "
- & "object name");
- else
- Error_Attr_P ("prefix of % attribute must be a scalar type");
- end if;
-
- elsif Is_Protected_Self_Reference (P) then
- Error_Attr_P
- ("prefix of % attribute denotes current instance "
- & "(RM 9.4(21/2))");
- end if;
-
+ Check_Image_Type (P_Type);
Resolve (E1, P_Base_Type);
Validate_Non_Static_Attribute_Function_Call;
end if;
@@ -1864,9 +1900,9 @@ package body Sem_Attr is
-- the prefix of another attribute. Error is posted on parent.
if Nkind (Parent (N)) = N_Attribute_Reference
- and then Nam_In (Attribute_Name (Parent (N)), Name_Address,
- Name_Code_Address,
- Name_Access)
+ and then Attribute_Name (Parent (N)) in Name_Address
+ | Name_Code_Address
+ | Name_Access
then
Error_Msg_Name_1 := Attribute_Name (Parent (N));
Error_Msg_N ("illegal prefix for % attribute", Parent (N));
@@ -2300,16 +2336,6 @@ package body Sem_Attr is
end if;
end Check_Scalar_Type;
- ------------------------------------------
- -- Check_SPARK_05_Restriction_On_Attribute --
- ------------------------------------------
-
- procedure Check_SPARK_05_Restriction_On_Attribute is
- begin
- Error_Msg_Name_1 := Aname;
- Check_SPARK_05_Restriction ("attribute % is not allowed", P);
- end Check_SPARK_05_Restriction_On_Attribute;
-
---------------------------
-- Check_Standard_Prefix --
---------------------------
@@ -2323,6 +2349,48 @@ package body Sem_Attr is
end if;
end Check_Standard_Prefix;
+ -------------------------------
+ -- Check_Put_Image_Attribute --
+ -------------------------------
+
+ procedure Check_Put_Image_Attribute is
+ begin
+ -- Put_Image is a procedure, and can only appear at the position of a
+ -- procedure call. If it's a list member and it's parent is a
+ -- procedure call or aggregate, then this is appearing as an actual
+ -- parameter or component association, which is wrong.
+
+ if Is_List_Member (N)
+ and then Nkind (Parent (N)) not in
+ N_Procedure_Call_Statement | N_Aggregate
+ then
+ null;
+ else
+ Error_Attr
+ ("invalid context for attribute%, which is a procedure", N);
+ end if;
+
+ Check_Type;
+ Analyze_And_Resolve (E1);
+
+ -- Check that the first argument is
+ -- Ada.Strings.Text_Output.Sink'Class.
+
+ -- Note: the double call to Root_Type here is needed because the
+ -- root type of a class-wide type is the corresponding type (e.g.
+ -- X for X'Class, and we really want to go to the root.)
+
+ if Root_Type (Root_Type (Etype (E1))) /= RTE (RE_Sink) then
+ Error_Attr
+ ("expected Ada.Strings.Text_Output.Sink''Class", E1);
+ end if;
+
+ -- Check that the second argument is of the right type
+
+ Analyze (E2);
+ Resolve (E2, P_Type);
+ end Check_Put_Image_Attribute;
+
----------------------------
-- Check_Stream_Attribute --
----------------------------
@@ -2350,8 +2418,8 @@ package body Sem_Attr is
null;
elsif Is_List_Member (N)
- and then not Nkind_In (Parent (N), N_Procedure_Call_Statement,
- N_Aggregate)
+ and then Nkind (Parent (N)) not in
+ N_Procedure_Call_Statement | N_Aggregate
then
null;
@@ -2589,7 +2657,7 @@ package body Sem_Attr is
if Nkind (Nod) = N_Identifier then
return;
- elsif Nkind_In (Nod, N_Selected_Component, N_Expanded_Name) then
+ elsif Nkind (Nod) in N_Selected_Component | N_Expanded_Name then
Check_Unit_Name (Prefix (Nod));
if Nkind (Selector_Name (Nod)) = N_Identifier then
@@ -2752,7 +2820,7 @@ package body Sem_Attr is
when 'E' =>
Error_Attr_P
("prefix of attribute % that is potentially "
- & "unevaluated must denote an entity");
+ & "unevaluated must statically name an entity");
when 'W' =>
Error_Msg_Name_1 := Aname;
@@ -2821,12 +2889,14 @@ package body Sem_Attr is
end if;
-- Deal with Ada 2005 attributes that are implementation attributes
- -- because they appear in a version of Ada before Ada 2005, and
- -- similarly for Ada 2012 attributes appearing in an earlier version.
+ -- because they appear in a version of Ada before Ada 2005, ditto for
+ -- Ada 2012 and Ada 2020 attributes appearing in an earlier version.
if (Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005)
or else
(Attribute_12 (Attr_Id) and then Ada_Version < Ada_2012)
+ or else
+ (Attribute_20 (Attr_Id) and then Ada_Version < Ada_2020)
then
Check_Restriction (No_Implementation_Attributes, N);
end if;
@@ -2957,7 +3027,7 @@ package body Sem_Attr is
-- parameterless call. Entry attributes are handled specially below.
if Is_Entity_Name (P)
- and then not Nam_In (Aname, Name_Count, Name_Caller)
+ and then Aname not in Name_Count | Name_Caller
then
Check_Parameterless_Call (P);
end if;
@@ -2968,7 +3038,7 @@ package body Sem_Attr is
-- primitive entry wrappers, the attributes Count, and Caller
-- require a context check
- if Nam_In (Aname, Name_Count, Name_Caller) then
+ if Aname in Name_Count | Name_Caller then
declare
Count : Natural := 0;
I : Interp_Index;
@@ -2999,21 +3069,6 @@ package body Sem_Attr is
end if;
end if;
- -- In SPARK, attributes of private types are only allowed if the full
- -- type declaration is visible.
-
- -- Note: the check for Present (Entity (P)) defends against some error
- -- conditions where the Entity field is not set.
-
- if Is_Entity_Name (P) and then Present (Entity (P))
- and then Is_Type (Entity (P))
- and then Is_Private_Type (P_Type)
- and then not In_Open_Scopes (Scope (P_Type))
- and then not In_Spec_Expression
- then
- Check_SPARK_05_Restriction ("invisible attribute of type", N);
- end if;
-
-- Remaining processing depends on attribute
case Attr_Id is
@@ -3182,12 +3237,6 @@ package body Sem_Attr is
("?r?redundant attribute, & is its own base type", N, Typ);
end if;
- if Nkind (Parent (N)) /= N_Attribute_Reference then
- Error_Msg_Name_1 := Aname;
- Check_SPARK_05_Restriction
- ("attribute% is only allowed as prefix of another attribute", P);
- end if;
-
Set_Etype (N, Base_Type (Entity (P)));
Set_Entity (N, Base_Type (Entity (P)));
Rewrite (N, New_Occurrence_Of (Entity (N), Loc));
@@ -3287,7 +3336,7 @@ package body Sem_Attr is
begin
Check_E0;
- if Nkind_In (P, N_Identifier, N_Expanded_Name) then
+ if Nkind (P) in N_Identifier | N_Expanded_Name then
Ent := Entity (P);
if not Is_Entry (Ent) then
@@ -3357,7 +3406,7 @@ package body Sem_Attr is
Check_E0;
if Nkind (P) = N_Attribute_Reference
- and then Nam_In (Attribute_Name (P), Name_Elab_Body, Name_Elab_Spec)
+ and then Attribute_Name (P) in Name_Elab_Body | Name_Elab_Spec
then
null;
@@ -3453,11 +3502,25 @@ package body Sem_Attr is
return;
end if;
- -- Normal (non-obsolescent case) of application to object of
+ -- Normal (non-obsolescent case) of application to object or value of
-- a discriminated type.
else
- Check_Object_Reference (P);
+ -- AI12-0068: In a type or subtype aspect, a prefix denoting the
+ -- current instance of the (sub)type is defined to be a value,
+ -- not an object, so the Constrained attribute is always True
+ -- (see RM 8.6(18/5) and RM 3.7.2(3/5)). We issue a warning about
+ -- this unintuitive result, to help avoid confusion.
+
+ if Is_Current_Instance_Reference_In_Type_Aspect (P) then
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_N
+ ("current instance attribute % in subtype aspect always " &
+ "true??", N);
+
+ else
+ Check_Object_Reference (P);
+ end if;
-- If N does not come from source, then we allow the
-- the attribute prefix to be of a private type whose
@@ -3493,7 +3556,7 @@ package body Sem_Attr is
return;
-- Also allow an object of a generic type if extensions allowed
- -- and allow this for any type at all. (this may be obsolete ???)
+ -- and allow this for any type at all.
elsif (Is_Generic_Type (P_Type)
or else Is_Generic_Actual_Type (P_Type))
@@ -3530,7 +3593,7 @@ package body Sem_Attr is
begin
Check_E0;
- if Nkind_In (P, N_Identifier, N_Expanded_Name) then
+ if Nkind (P) in N_Identifier | N_Expanded_Name then
Ent := Entity (P);
if Ekind (Ent) /= E_Entry then
@@ -3596,10 +3659,10 @@ package body Sem_Attr is
exit;
elsif Ekind (Scope (Ent)) in Task_Kind
- and then not Ekind_In (S, E_Block,
- E_Entry,
- E_Entry_Family,
- E_Loop)
+ and then Ekind (S) not in E_Block
+ | E_Entry
+ | E_Entry_Family
+ | E_Loop
then
Error_Attr ("Attribute % cannot appear in inner unit", N);
@@ -4127,6 +4190,28 @@ package body Sem_Attr is
when Attribute_Img =>
Analyze_Image_Attribute (Standard_String);
+ -----------------
+ -- Initialized --
+ -----------------
+
+ when Attribute_Initialized =>
+ Check_E0;
+
+ if Comes_From_Source (N) then
+
+ -- This attribute be prefixed with references to objects or
+ -- values (such as a current instance value given within a type
+ -- or subtype aspect).
+
+ if not Is_Object_Reference (P)
+ and then not Is_Current_Instance_Reference_In_Type_Aspect (P)
+ then
+ Error_Attr_P ("prefix of % attribute must be object");
+ end if;
+ end if;
+
+ Set_Etype (N, Standard_Boolean);
+
-----------
-- Input --
-----------
@@ -4448,12 +4533,13 @@ package body Sem_Attr is
-- that the pragma appears in an appropriate loop location.
if Nkind (Original_Node (Stmt)) = N_Pragma
- and then Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)),
- Name_Loop_Invariant,
- Name_Loop_Variant,
- Name_Assert,
- Name_Assert_And_Cut,
- Name_Assume)
+ and then
+ Pragma_Name_Unmapped (Original_Node (Stmt))
+ in Name_Loop_Invariant
+ | Name_Loop_Variant
+ | Name_Assert
+ | Name_Assert_And_Cut
+ | Name_Assume
then
Encl_Prag := Original_Node (Stmt);
@@ -4516,7 +4602,7 @@ package body Sem_Attr is
if Ekind (Scop) = E_Loop and then Scop = Loop_Id then
exit;
- elsif Ekind_In (Scop, E_Block, E_Loop, E_Return_Statement) then
+ elsif Ekind (Scop) in E_Block | E_Loop | E_Return_Statement then
null;
else
Error_Attr
@@ -4531,13 +4617,13 @@ package body Sem_Attr is
Check_References_In_Prefix (Loop_Id);
- -- The prefix must denote a static entity if the pragma does not
+ -- The prefix must statically name an object if the pragma does not
-- apply to the innermost enclosing loop statement, or if it appears
- -- within a potentially unevaluated epxression.
+ -- within a potentially unevaluated expression.
if Is_Entity_Name (P)
or else Nkind (Parent (P)) = N_Object_Renaming_Declaration
- or else Statically_Denotes_Object (P)
+ or else Statically_Names_Object (P)
then
null;
@@ -4910,8 +4996,7 @@ package body Sem_Attr is
-- another attribute 'Old.
if Nkind (Nod) = N_Attribute_Reference
- and then Nam_In (Attribute_Name (Nod), Name_Old,
- Name_Result)
+ and then Attribute_Name (Nod) in Name_Old | Name_Result
then
Error_Msg_Name_1 := Attribute_Name (Nod);
Error_Msg_Name_2 := Name_Old;
@@ -5037,7 +5122,7 @@ package body Sem_Attr is
-- is potentially unevaluated (6.1.1 (27/3)).
if Is_Potentially_Unevaluated (N)
- and then not Statically_Denotes_Object (P)
+ and then not Statically_Names_Object (P)
then
Uneval_Old_Msg;
@@ -5056,7 +5141,7 @@ package body Sem_Attr is
then
Pref_Id := Entity (Name (P));
- if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
+ if Ekind (Spec_Id) in E_Function | E_Generic_Function
and then Pref_Id = Spec_Id
then
Error_Msg_Warn := SPARK_Mode /= On;
@@ -5156,6 +5241,7 @@ package body Sem_Attr is
when Attribute_Passed_By_Reference =>
Check_E0;
Check_Type;
+ Check_Not_Incomplete_Type;
Set_Etype (N, Standard_Boolean);
------------------
@@ -5173,14 +5259,6 @@ package body Sem_Attr is
when Attribute_Pos =>
Check_Discrete_Type;
Check_E1;
-
- if Is_Boolean_Type (P_Type) then
- Error_Msg_Name_1 := Aname;
- Error_Msg_Name_2 := Chars (P_Type);
- Check_SPARK_05_Restriction
- ("attribute% is not allowed for type%", P);
- end if;
-
Resolve (E1, P_Base_Type);
Set_Etype (N, Universal_Integer);
@@ -5199,14 +5277,6 @@ package body Sem_Attr is
when Attribute_Pred =>
Check_Scalar_Type;
Check_E1;
-
- if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then
- Error_Msg_Name_1 := Aname;
- Error_Msg_Name_2 := Chars (P_Type);
- Check_SPARK_05_Restriction
- ("attribute% is not allowed for type%", P);
- end if;
-
Resolve (E1, P_Base_Type);
Set_Etype (N, P_Base_Type);
@@ -5281,6 +5351,16 @@ package body Sem_Attr is
Validate_Non_Static_Attribute_Function_Call;
+ ---------------
+ -- Put_Image --
+ ---------------
+
+ when Attribute_Put_Image =>
+ Check_E2;
+ Check_Put_Image_Attribute;
+ Set_Etype (N, Standard_Void_Type);
+ Resolve (N, Standard_Void_Type);
+
-----------
-- Range --
-----------
@@ -5347,7 +5427,7 @@ package body Sem_Attr is
elsif Nkind (Subp_Spec) = N_Function_Specification
and then Present (Generic_Parent (Subp_Spec))
- and then Ekind_In (Pref_Id, E_Generic_Function, E_Function)
+ and then Ekind (Pref_Id) in E_Generic_Function | E_Function
then
if Generic_Parent (Subp_Spec) = Pref_Id then
return True;
@@ -5448,8 +5528,16 @@ package body Sem_Attr is
if Is_Entity_Name (P) then
Pref_Id := Entity (P);
- if Ekind_In (Pref_Id, E_Function, E_Generic_Function)
- and then Ekind (Spec_Id) = Ekind (Pref_Id)
+ -- Either both the prefix and the annotated spec must be
+ -- generic functions, or they both must be nongeneric
+ -- functions, or the prefix must be generic and the spec
+ -- must be nongeneric (i.e. it must denote an instance).
+
+ if (Ekind (Pref_Id) in E_Function | E_Generic_Function
+ and then Ekind (Pref_Id) = Ekind (Spec_Id))
+ or else
+ (Ekind (Pref_Id) = E_Generic_Function
+ and then Ekind (Spec_Id) = E_Function)
then
if Denote_Same_Function (Pref_Id, Spec_Id) then
@@ -5505,6 +5593,11 @@ package body Sem_Attr is
when Attribute_Reduce =>
Check_E2;
+ if not Extensions_Allowed then
+ Error_Attr
+ ("% attribute only supported under -gnatX", P);
+ end if;
+
declare
Stream : constant Node_Id := Prefix (N);
Typ : Entity_Id;
@@ -5513,10 +5606,10 @@ package body Sem_Attr is
-- Prefix is a name, as for other attributes.
-- If the object is a function we asume that it is not
- -- overloaded. AI12-242 does not suggest an name resulution
- -- rule for that case, but can suppose that the expected
- -- type of the reduction is the expected type of the
- -- component of the prefix.
+ -- overloaded. AI12-242 does not suggest a name resolution
+ -- rule for that case, but we can suppose that the expected
+ -- type of the reduction is the expected type of the component
+ -- of the prefix.
Analyze_And_Resolve (Stream);
Typ := Etype (Stream);
@@ -5985,7 +6078,7 @@ package body Sem_Attr is
-- Validate_Remote_Access_To_Class_Wide_Type for attribute
-- Storage_Pool since this attribute is not defined for such
- -- types (RM E.2.3(22)).
+ -- types (RM E.2.2(17)).
Validate_Remote_Access_To_Class_Wide_Type (N);
@@ -6019,9 +6112,9 @@ package body Sem_Attr is
Check_Type;
Set_Etype (N, Universal_Integer);
- -- Validate_Remote_Access_To_Class_Wide_Type for attribute
- -- Storage_Size since this attribute is not defined for
- -- such types (RM E.2.3(22)).
+ -- Validate_Remote_Access_To_Class_Wide_Type for attribute
+ -- Storage_Size since this attribute is not defined for
+ -- such types (RM E.2.2(17)).
Validate_Remote_Access_To_Class_Wide_Type (N);
@@ -6103,14 +6196,6 @@ package body Sem_Attr is
when Attribute_Succ =>
Check_Scalar_Type;
Check_E1;
-
- if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then
- Error_Msg_Name_1 := Aname;
- Error_Msg_Name_2 := Chars (P_Type);
- Check_SPARK_05_Restriction
- ("attribute% is not allowed for type%", P);
- end if;
-
Resolve (E1, P_Base_Type);
Set_Etype (N, P_Base_Type);
@@ -6229,9 +6314,9 @@ package body Sem_Attr is
if Is_OK_Static_Expression (E1) then
Val := Expr_Value (E1);
- if Val < -(2 ** UI_From_Int (Standard'Address_Size - 1))
+ if Val < -(Uint_2 ** (System_Address_Size - 1))
or else
- Val > 2 ** UI_From_Int (Standard'Address_Size) - 1
+ Val > Uint_2 ** System_Address_Size - 1
then
Error_Attr ("address value out of range for % attribute", E1);
end if;
@@ -6248,7 +6333,7 @@ package body Sem_Attr is
elsif Val < 0 then
Set_Etype (E1, Universal_Integer);
- -- Otherwise set type to Unsigned_64 to accommodate max values
+ -- Otherwise set type to Unsigned_64 to accommodate large values
else
Set_Etype (E1, Standard_Unsigned_64);
@@ -6418,7 +6503,7 @@ package body Sem_Attr is
end if;
end if;
- Rep := Next_Rep_Item (Rep);
+ Next_Rep_Item (Rep);
end loop;
end if;
end Compute_Type_Key;
@@ -6525,7 +6610,7 @@ package body Sem_Attr is
Negative := False;
end if;
- if not Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) then
+ if Nkind (Expr) not in N_Integer_Literal | N_Real_Literal then
Error_Attr
("named number for % attribute must be simple literal", N);
end if;
@@ -6703,30 +6788,10 @@ package body Sem_Attr is
Analyze_And_Resolve (Low, Etype (Index_Typ));
Analyze_And_Resolve (High, Etype (Index_Typ));
- -- Add a range check to ensure that the bounds of the
- -- range are within the index type when this cannot be
- -- determined statically.
-
- if not Is_OK_Static_Expression (Low) then
- Set_Do_Range_Check (Low);
- end if;
-
- if not Is_OK_Static_Expression (High) then
- Set_Do_Range_Check (High);
- end if;
-
-- Otherwise the index denotes a single element
else
Analyze_And_Resolve (Index, Etype (Index_Typ));
-
- -- Add a range check to ensure that the index is within
- -- the index type when it is not possible to determine
- -- this statically.
-
- if not Is_OK_Static_Expression (Index) then
- Set_Do_Range_Check (Index);
- end if;
end if;
Next (Index);
@@ -6760,7 +6825,7 @@ package body Sem_Attr is
exit;
end if;
- Comp_Or_Discr := Next_Entity (Comp_Or_Discr);
+ Next_Entity (Comp_Or_Discr);
end loop;
-- Diagnose an illegal reference
@@ -6791,7 +6856,7 @@ package body Sem_Attr is
-- Verify the consistency of types when the current component is
-- part of a miltiple component update.
- -- Comp_1, ..., Comp_N => <value>
+ -- Comp_1 | ... | Comp_N => <value>
if Present (Etype (Comp)) then
Base_Typ := Base_Type (Etype (Comp));
@@ -6832,6 +6897,11 @@ package body Sem_Attr is
elsif Nkind (E1) /= N_Aggregate then
Error_Attr ("attribute % requires component association list", N);
+
+ elsif Present (Expressions (E1)) then
+ Error_Attr ("attribute % requires named component associations",
+ First (Expressions (E1)));
+
end if;
-- Inspect the update aggregate, looking at all the associations and
@@ -6910,13 +6980,6 @@ package body Sem_Attr is
Check_E1;
Check_Discrete_Type;
- if Is_Boolean_Type (P_Type) then
- Error_Msg_Name_1 := Aname;
- Error_Msg_Name_2 := Chars (P_Type);
- Check_SPARK_05_Restriction
- ("attribute% is not allowed for type%", P);
- end if;
-
-- Note, we need a range check in general, but we wait for the
-- Resolve call to do this, since we want to let Eval_Attribute
-- have a chance to find an static illegality first.
@@ -6978,6 +7041,10 @@ package body Sem_Attr is
-- types due to a code generation issue. Is_Visible_Component
-- does not allow for a component of a private tagged type to
-- be successfully retrieved.
+ -- ??? This attribute should simply ignore type privacy
+ -- (see Validated_View). It should examine components of the
+ -- tagged type extensions (if any) and recursively examine
+ -- 'Valid_Scalars of the parent's type (if any).
-- Do not use Error_Attr_P because this bypasses any subsequent
-- processing and leaves the attribute with type Any_Type. This
@@ -7018,7 +7085,6 @@ package body Sem_Attr is
-----------
when Attribute_Value =>
- Check_SPARK_05_Restriction_On_Attribute;
Check_E1;
Check_Scalar_Type;
@@ -7109,7 +7175,6 @@ package body Sem_Attr is
----------------
when Attribute_Wide_Value =>
- Check_SPARK_05_Restriction_On_Attribute;
Check_E1;
Check_Scalar_Type;
@@ -7163,7 +7228,6 @@ package body Sem_Attr is
----------------
when Attribute_Wide_Width =>
- Check_SPARK_05_Restriction_On_Attribute;
Check_E0;
Check_Scalar_Type;
Set_Etype (N, Universal_Integer);
@@ -7173,7 +7237,6 @@ package body Sem_Attr is
-----------
when Attribute_Width =>
- Check_SPARK_05_Restriction_On_Attribute;
Check_E0;
Check_Scalar_Type;
Set_Etype (N, Universal_Integer);
@@ -7202,22 +7265,17 @@ package body Sem_Attr is
-- See SPARK RM 9(18) for the relevant rule.
if GNATprove_Mode then
- declare
- Unused : Entity_Id;
-
- begin
- case Attr_Id is
- when Attribute_Callable
- | Attribute_Caller
- | Attribute_Count
- | Attribute_Terminated
- =>
- Unused := RTE (RE_Tasking_State);
+ case Attr_Id is
+ when Attribute_Callable
+ | Attribute_Caller
+ | Attribute_Count
+ | Attribute_Terminated
+ =>
+ SPARK_Implicit_Load (RE_Tasking_State);
- when others =>
- null;
- end case;
- end;
+ when others =>
+ null;
+ end case;
end if;
-- All errors raise Bad_Attribute, so that we get out before any further
@@ -7241,13 +7299,19 @@ package body Sem_Attr is
procedure Eval_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Aname : constant Name_Id := Attribute_Name (N);
- Id : constant Attribute_Id := Get_Attribute_Id (Aname);
- P : constant Node_Id := Prefix (N);
C_Type : constant Entity_Id := Etype (N);
-- The type imposed by the context
+ Aname : Name_Id;
+ -- Attribute_Name (N) after verification of validity of N
+
+ Id : Attribute_Id;
+ -- Get_Attribute_Id (Aname) after Aname is set
+
+ P : Node_Id;
+ -- Prefix (N) after verification of validity of N
+
E1 : Node_Id;
-- First expression, or Empty if none
@@ -7325,10 +7389,6 @@ package body Sem_Attr is
-- Static is reset to False if the type or index type is not statically
-- constrained.
- function Statically_Denotes_Entity (N : Node_Id) return Boolean;
- -- Verify that the prefix of a potentially static array attribute
- -- satisfies the conditions of 4.9 (14).
-
-----------------------------------
-- Check_Concurrent_Discriminant --
-----------------------------------
@@ -7605,28 +7665,20 @@ package body Sem_Attr is
end if;
end Set_Bounds;
- -------------------------------
- -- Statically_Denotes_Entity --
- -------------------------------
-
- function Statically_Denotes_Entity (N : Node_Id) return Boolean is
- E : Entity_Id;
+ -- Start of processing for Eval_Attribute
- begin
- if not Is_Entity_Name (N) then
- return False;
- else
- E := Entity (N);
- end if;
+ begin
+ -- Return immediately if e.g. N has been rewritten or is malformed due
+ -- to previous errors.
- return
- Nkind (Parent (E)) /= N_Object_Renaming_Declaration
- or else Statically_Denotes_Entity (Renamed_Object (E));
- end Statically_Denotes_Entity;
+ if Nkind (N) /= N_Attribute_Reference then
+ return;
+ end if;
- -- Start of processing for Eval_Attribute
+ Aname := Attribute_Name (N);
+ Id := Get_Attribute_Id (Aname);
+ P := Prefix (N);
- begin
-- The To_Address attribute can be static, but it cannot be evaluated at
-- compile time, so just return.
@@ -7659,9 +7711,7 @@ package body Sem_Attr is
-- We skip evaluation if the expander is not active. This is not just
-- an optimization. It is of key importance that we not rewrite the
-- attribute in a generic template, since we want to pick up the
- -- setting of the check in the instance, Testing Expander_Active
- -- might seem an easy way of doing this, but we need to account for
- -- ASIS needs, so check explicitly for a generic context.
+ -- setting of the check in the instance.
if not Inside_A_Generic then
declare
@@ -7715,18 +7765,35 @@ package body Sem_Attr is
return;
end if;
- -- Special processing for cases where the prefix is an object. For this
- -- purpose, a string literal counts as an object (attributes of string
- -- literals can only appear in generated code).
+ -- Special processing for cases where the prefix is an object or value,
+ -- including string literals (attributes of string literals can only
+ -- appear in generated code) and current instance prefixes in type or
+ -- subtype aspects.
- if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then
+ if Is_Object_Reference (P)
+ or else Is_Current_Instance_Reference_In_Type_Aspect (P)
+ or else Nkind (P) = N_String_Literal
+ or else (Is_Entity_Name (P)
+ and then Ekind (Entity (P)) = E_Enumeration_Literal)
+ then
+ -- For Alignment, give alignment of object if available, otherwise we
+ -- cannot fold Alignment.
+
+ if Id = Attribute_Alignment then
+ if Is_Entity_Name (P) and then Known_Alignment (Entity (P)) then
+ Compile_Time_Known_Attribute (N, Alignment (Entity (P)));
+ else
+ Check_Expressions;
+ end if;
+
+ return;
-- For Component_Size, the prefix is an array object, and we apply
-- the attribute to the type of the object. This is allowed for both
-- unconstrained and constrained arrays, since the bounds have no
-- influence on the value of this attribute.
- if Id = Attribute_Component_Size then
+ elsif Id = Attribute_Component_Size then
P_Entity := Etype (P);
-- For Enum_Rep, evaluation depends on the nature of the prefix and
@@ -7742,8 +7809,7 @@ package body Sem_Attr is
begin
-- P'Enum_Rep case
- if Ekind_In (Entity (P), E_Constant,
- E_Enumeration_Literal)
+ if Ekind (Entity (P)) in E_Constant | E_Enumeration_Literal
then
Enum_Expr := P;
@@ -7771,6 +7837,8 @@ package body Sem_Attr is
(Ekind (Entity (Enum_Expr)) = E_Constant
and then Nkind (Parent (Entity (Enum_Expr))) =
N_Object_Declaration
+ and then Present
+ (Expression (Parent (Entity (P))))
and then Compile_Time_Known_Value
(Expression (Parent (Entity (P))))))
then
@@ -7788,13 +7856,126 @@ package body Sem_Attr is
return;
end if;
- -- For First and Last, the prefix is an array object, and we apply
- -- the attribute to the type of the array, but we need a constrained
- -- type for this, so we use the actual subtype if available.
+ -- For Bit_Position, give Component_Bit_Offset of object if available
+ -- otherwise we cannot fold Bit_Position. Note that the attribute can
+ -- be applied to a naked record component in generated code, in which
+ -- case the prefix is an identifier that references the component or
+ -- discriminant entity.
+
+ elsif Id = Attribute_Bit_Position then
+ declare
+ CE : Entity_Id;
+
+ begin
+ if Is_Entity_Name (P) then
+ CE := Entity (P);
+ else
+ CE := Entity (Selector_Name (P));
+ end if;
+
+ if Known_Static_Component_Bit_Offset (CE) then
+ Compile_Time_Known_Attribute
+ (N, Component_Bit_Offset (Entity (P)));
+ else
+ Check_Expressions;
+ end if;
+
+ return;
+ end;
+
+ -- For Position, in Ada 2005 (or later) if we have the non-default
+ -- bit order, we return the original value as given in the component
+ -- clause (RM 2005 13.5.2(3/2)). Otherwise (Ada 83/95, or later with
+ -- default bit order) return the value if it is known statically.
+
+ elsif Id = Attribute_Position then
+ declare
+ CE : constant Entity_Id := Entity (Selector_Name (P));
+
+ begin
+ if Present (Component_Clause (CE))
+ and then Ada_Version >= Ada_2005
+ and then Reverse_Bit_Order (Scope (CE))
+ then
+ Compile_Time_Known_Attribute
+ (N, Expr_Value (Position (Component_Clause (CE))));
+
+ elsif Known_Static_Component_Bit_Offset (CE) then
+ Compile_Time_Known_Attribute
+ (N, Component_Bit_Offset (CE) / System_Storage_Unit);
+
+ else
+ Check_Expressions;
+ end if;
+
+ return;
+ end;
+
+ -- For First_Bit, in Ada 2005 (or later) if we have the non-default
+ -- bit order, we return the original value as given in the component
+ -- clause (RM 2005 13.5.2(3/2)). Otherwise (Ada 83/95, or later with
+ -- default bit order) return the value if it is known statically.
+
+ elsif Id = Attribute_First_Bit then
+ declare
+ CE : constant Entity_Id := Entity (Selector_Name (P));
+
+ begin
+ if Present (Component_Clause (CE))
+ and then Ada_Version >= Ada_2005
+ and then Reverse_Bit_Order (Scope (CE))
+ then
+ Compile_Time_Known_Attribute
+ (N, Expr_Value (First_Bit (Component_Clause (CE))));
+
+ elsif Known_Static_Component_Bit_Offset (CE) then
+ Compile_Time_Known_Attribute
+ (N, Component_Bit_Offset (CE) mod System_Storage_Unit);
+
+ else
+ Check_Expressions;
+ end if;
+
+ return;
+ end;
+
+ -- For Last_Bit, in Ada 2005 (or later) if we have the non-default
+ -- bit order, we return the original value as given in the component
+ -- clause (RM 2005 13.5.2(3/2)). Otherwise (Ada 83/95, or later with
+ -- default bit order) return the value if it is known statically.
+
+ elsif Id = Attribute_Last_Bit then
+ declare
+ CE : constant Entity_Id := Entity (Selector_Name (P));
+
+ begin
+ if Present (Component_Clause (CE))
+ and then Ada_Version >= Ada_2005
+ and then Reverse_Bit_Order (Scope (CE))
+ then
+ Compile_Time_Known_Attribute
+ (N, Expr_Value (Last_Bit (Component_Clause (CE))));
+
+ elsif Known_Static_Component_Bit_Offset (CE)
+ and then Known_Static_Esize (CE)
+ then
+ Compile_Time_Known_Attribute
+ (N, (Component_Bit_Offset (CE) mod System_Storage_Unit)
+ + Esize (CE) - 1);
+ else
+ Check_Expressions;
+ end if;
+
+ return;
+ end;
+
+ -- For First, Last and Length, the prefix is an array object, and we
+ -- apply the attribute to its type, but we need a constrained type
+ -- for this, so we use the actual subtype if available.
- elsif Id = Attribute_First or else
- Id = Attribute_Last or else
- Id = Attribute_Length
+ elsif Id = Attribute_First
+ or else Id = Attribute_Last
+ or else Id = Attribute_Length
then
declare
AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P);
@@ -7816,30 +7997,14 @@ package body Sem_Attr is
elsif Id = Attribute_Size then
if Is_Entity_Name (P)
- and then Known_Esize (Entity (P))
+ and then Known_Static_Esize (Entity (P))
then
Compile_Time_Known_Attribute (N, Esize (Entity (P)));
- return;
-
else
Check_Expressions;
- return;
end if;
- -- For Alignment, give size of object if available, otherwise we
- -- cannot fold Alignment.
-
- elsif Id = Attribute_Alignment then
- if Is_Entity_Name (P)
- and then Known_Alignment (Entity (P))
- then
- Fold_Uint (N, Alignment (Entity (P)), Static);
- return;
-
- else
- Check_Expressions;
- return;
- end if;
+ return;
-- For Lock_Free, we apply the attribute to the type of the object.
-- This is allowed since we have already verified that the type is a
@@ -7929,7 +8094,7 @@ package body Sem_Attr is
-- First foldable possibility is a scalar or array type (RM 4.9(7))
-- that is not generic (generic types are eliminated by RM 4.9(25)).
- -- Note we allow non-static non-generic types at this stage as further
+ -- Note we allow nonstatic nongeneric types at this stage as further
-- described below.
if Is_Type (P_Entity)
@@ -7940,7 +8105,7 @@ package body Sem_Attr is
-- Second foldable possibility is an array object (RM 4.9(8))
- elsif Ekind_In (P_Entity, E_Variable, E_Constant)
+ elsif Ekind (P_Entity) in E_Variable | E_Constant
and then Is_Array_Type (Etype (P_Entity))
and then (not Is_Generic_Type (Etype (P_Entity)))
then
@@ -7965,11 +8130,11 @@ package body Sem_Attr is
-- Definite must be folded if the prefix is not a generic type, that
-- is to say if we are within an instantiation. Same processing applies
- -- to the GNAT attributes Atomic_Always_Lock_Free, Has_Discriminants,
- -- Lock_Free, Type_Class, Has_Tagged_Value, and Unconstrained_Array.
+ -- to selected GNAT attributes.
elsif (Id = Attribute_Atomic_Always_Lock_Free or else
Id = Attribute_Definite or else
+ Id = Attribute_Descriptor_Size or else
Id = Attribute_Has_Access_Values or else
Id = Attribute_Has_Discriminants or else
Id = Attribute_Has_Tagged_Values or else
@@ -7985,14 +8150,24 @@ package body Sem_Attr is
-- for a size from an attribute definition clause). At this stage, this
-- can happen only for types (e.g. record types) for which the size is
-- always non-static. We exclude generic types from consideration (since
- -- they have bogus sizes set within templates).
+ -- they have bogus sizes set within templates). We can also fold
+ -- Max_Size_In_Storage_Elements in the same cases.
- elsif Id = Attribute_Size
+ elsif (Id = Attribute_Size or
+ Id = Attribute_Max_Size_In_Storage_Elements)
and then Is_Type (P_Entity)
and then (not Is_Generic_Type (P_Entity))
and then Known_Static_RM_Size (P_Entity)
then
- Compile_Time_Known_Attribute (N, RM_Size (P_Entity));
+ declare
+ Attr_Value : Uint := RM_Size (P_Entity);
+ begin
+ if Id = Attribute_Max_Size_In_Storage_Elements then
+ Attr_Value := (Attr_Value + System_Storage_Unit - 1)
+ / System_Storage_Unit;
+ end if;
+ Compile_Time_Known_Attribute (N, Attr_Value);
+ end;
return;
-- We can fold 'Alignment applied to a type if the alignment is known
@@ -8080,7 +8255,7 @@ package body Sem_Attr is
-- since we can't do anything with unconstrained arrays. In addition,
-- only the First, Last and Length attributes are possibly static.
- -- Atomic_Always_Lock_Free, Definite, Has_Access_Values,
+ -- Atomic_Always_Lock_Free, Definite, Descriptor_Size, Has_Access_Values
-- Has_Discriminants, Has_Tagged_Values, Lock_Free, Type_Class, and
-- Unconstrained_Array are again exceptions, because they apply as well
-- to unconstrained types.
@@ -8092,6 +8267,7 @@ package body Sem_Attr is
elsif Id = Attribute_Atomic_Always_Lock_Free or else
Id = Attribute_Definite or else
+ Id = Attribute_Descriptor_Size or else
Id = Attribute_Has_Access_Values or else
Id = Attribute_Has_Discriminants or else
Id = Attribute_Has_Tagged_Values or else
@@ -8206,16 +8382,6 @@ package body Sem_Attr is
if not Compile_Time_Known_Value (E)
or else not Is_Scalar_Type (Etype (E))
then
- -- An odd special case, if this is a Pos attribute, this
- -- is where we need to apply a range check since it does
- -- not get done anywhere else.
-
- if Id = Attribute_Pos then
- if Is_Integer_Type (Etype (E)) then
- Apply_Range_Check (E, Etype (N));
- end if;
- end if;
-
Check_Expressions;
return;
@@ -8391,6 +8557,11 @@ package body Sem_Attr is
-- Component_Size --
--------------------
+ -- Fold Component_Size if it is known at compile time, which is always
+ -- true in the packed array case. It is important that the packed array
+ -- case is handled here since the back end would otherwise get confused
+ -- by the equivalent packed array type.
+
when Attribute_Component_Size =>
if Known_Static_Component_Size (P_Type) then
Fold_Uint (N, Component_Size (P_Type), Static);
@@ -8416,8 +8587,8 @@ package body Sem_Attr is
when Attribute_Constrained =>
-- The expander might fold it and set the static flag accordingly,
- -- but with expansion disabled (as in ASIS), it remains as an
- -- attribute reference, and this reference is not static.
+ -- but with expansion disabled, it remains as an attribute reference,
+ -- and this reference is not static.
Set_Is_Static_Expression (N, False);
@@ -8460,8 +8631,12 @@ package body Sem_Attr is
-- Descriptor_Size --
---------------------
+ -- Descriptor_Size is nonnull only for unconstrained array types
+
when Attribute_Descriptor_Size =>
- null;
+ if not Is_Array_Type (P_Type) or else Is_Constrained (P_Type) then
+ Fold_Uint (N, Uint_0, Static);
+ end if;
------------
-- Digits --
@@ -8533,7 +8708,7 @@ package body Sem_Attr is
--------------
when Attribute_Enum_Val => Enum_Val : declare
- Lit : Node_Id;
+ Lit : Entity_Id;
begin
-- We have something like Enum_Type'Enum_Val (23), so search for a
@@ -10253,6 +10428,7 @@ package body Sem_Attr is
| Attribute_First_Bit
| Attribute_Img
| Attribute_Input
+ | Attribute_Initialized
| Attribute_Last_Bit
| Attribute_Library_Level
| Attribute_Maximum_Alignment
@@ -10262,6 +10438,7 @@ package body Sem_Attr is
| Attribute_Pool_Address
| Attribute_Position
| Attribute_Priority
+ | Attribute_Put_Image
| Attribute_Read
| Attribute_Result
| Attribute_Scalar_Storage_Order
@@ -10299,10 +10476,10 @@ package body Sem_Attr is
-- An exception is the GNAT attribute Constrained_Array which is
-- defined to be a static attribute in all cases.
- if Nkind_In (N, N_Integer_Literal,
- N_Real_Literal,
- N_Character_Literal,
- N_String_Literal)
+ if Nkind (N) in N_Integer_Literal
+ | N_Real_Literal
+ | N_Character_Literal
+ | N_String_Literal
or else (Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_Enumeration_Literal)
then
@@ -10373,6 +10550,13 @@ package body Sem_Attr is
-- Returns True if Declared_Entity is declared within the declarative
-- region of Generic_Unit; otherwise returns False.
+ function Prefix_With_Safe_Accessibility_Level return Boolean;
+ -- Return True if the prefix does not have a value conversion of an
+ -- array because a value conversion is like an aggregate with respect
+ -- to determining accessibility level (RM 3.10.2); even if evaluation
+ -- of a value conversion is guaranteed to not create a new object,
+ -- accessibility rules are defined as if it might.
+
---------------------------
-- Accessibility_Message --
---------------------------
@@ -10402,8 +10586,8 @@ package body Sem_Attr is
if Is_Record_Type (Current_Scope)
and then
- Nkind_In (Parent (N), N_Discriminant_Association,
- N_Index_Or_Discriminant_Constraint)
+ Nkind (Parent (N)) in N_Discriminant_Association
+ | N_Index_Or_Discriminant_Constraint
then
Indic := Parent (Parent (N));
while Present (Indic)
@@ -10449,6 +10633,70 @@ package body Sem_Attr is
return False;
end Declared_Within_Generic_Unit;
+ ------------------------------------------
+ -- Prefix_With_Safe_Accessibility_Level --
+ ------------------------------------------
+
+ function Prefix_With_Safe_Accessibility_Level return Boolean is
+ function Safe_Value_Conversions return Boolean;
+ -- Return False if the prefix has a value conversion of an array type
+
+ ----------------------------
+ -- Safe_Value_Conversions --
+ ----------------------------
+
+ function Safe_Value_Conversions return Boolean is
+ PP : Node_Id := P;
+
+ begin
+ loop
+ if Nkind (PP) in N_Selected_Component | N_Indexed_Component then
+ PP := Prefix (PP);
+
+ elsif Comes_From_Source (PP)
+ and then Nkind (PP) in N_Type_Conversion
+ | N_Unchecked_Type_Conversion
+ and then Is_Array_Type (Etype (PP))
+ then
+ return False;
+
+ elsif Comes_From_Source (PP)
+ and then Nkind (PP) = N_Qualified_Expression
+ and then Is_Array_Type (Etype (PP))
+ and then Nkind (Original_Node (Expression (PP))) in
+ N_Aggregate | N_Extension_Aggregate
+ then
+ return False;
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ return True;
+ end Safe_Value_Conversions;
+
+ -- Start of processing for Prefix_With_Safe_Accessibility_Level
+
+ begin
+ -- No check required for unchecked and unrestricted access
+
+ if Attr_Id = Attribute_Unchecked_Access
+ or else Attr_Id = Attribute_Unrestricted_Access
+ then
+ return True;
+
+ -- Check value conversions
+
+ elsif Ekind (Btyp) = E_General_Access_Type
+ and then not Safe_Value_Conversions
+ then
+ return False;
+ end if;
+
+ return True;
+ end Prefix_With_Safe_Accessibility_Level;
+
-- Start of processing for Resolve_Attribute
begin
@@ -10530,19 +10778,6 @@ package body Sem_Attr is
end;
end if;
- -- The following comes from a query concerning improper use of
- -- universal_access in equality tests involving anonymous access
- -- types. Another good reason for 'Ref, but for now disable the
- -- test, which breaks several filed tests???
-
- if Ekind (Typ) = E_Anonymous_Access_Type
- and then Nkind_In (Parent (N), N_Op_Eq, N_Op_Ne)
- and then False
- then
- Error_Msg_N ("need unique type to resolve 'Access", N);
- Error_Msg_N ("\qualify attribute with some access type", N);
- end if;
-
-- Case where prefix is an entity name
if Is_Entity_Name (P) then
@@ -10637,10 +10872,10 @@ package body Sem_Attr is
-- also be accessibility checks on those, this is where the
-- checks can eventually be centralized ???
- if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type,
- E_Access_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type,
- E_Anonymous_Access_Subprogram_Type)
+ if Ekind (Btyp) in E_Access_Protected_Subprogram_Type
+ | E_Access_Subprogram_Type
+ | E_Anonymous_Access_Protected_Subprogram_Type
+ | E_Anonymous_Access_Subprogram_Type
then
-- Deal with convention mismatch
@@ -10678,6 +10913,7 @@ package body Sem_Attr is
if not Is_Itype (Btyp)
and then not Has_Convention_Pragma (Btyp)
+ and then Convention (Entity (P)) /= Convention_Intrinsic
then
Error_Msg_FE
("\probable missing pragma Convention for &",
@@ -10860,7 +11096,29 @@ package body Sem_Attr is
end if;
Resolve (Prefix (P));
- Generate_Reference (Entity (Selector_Name (P)), P);
+
+ if not Is_Overloaded (P) then
+ Generate_Reference (Entity (Selector_Name (P)), P);
+
+ else
+ Get_First_Interp (P, Index, It);
+ while Present (It.Nam) loop
+ if Type_Conformant (Designated_Type (Typ), It.Nam) then
+ Set_Entity (Selector_Name (P), It.Nam);
+
+ -- The prefix is definitely NOT overloaded anymore at
+ -- this point, so we reset the Is_Overloaded flag to
+ -- avoid any confusion when reanalyzing the node.
+
+ Set_Is_Overloaded (P, False);
+ Set_Is_Overloaded (N, False);
+ Generate_Reference (Entity (Selector_Name (P)), P);
+ exit;
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+ end if;
-- Implement check implied by 3.10.2 (18.1/2) : F.all'access is
-- statically illegal if F is an anonymous access to subprogram.
@@ -10970,9 +11228,19 @@ package body Sem_Attr is
or else Nkind (Associated_Node_For_Itype (Btyp)) =
N_Object_Declaration)
+ and then Attr_Id = Attribute_Access
+
+ -- Verify that static checking is OK (namely that we aren't
+ -- in a specific context requiring dynamic checks on
+ -- expicitly aliased parameters), and then check the level.
+
+ -- Otherwise a check will be generated later when the return
+ -- statement gets expanded.
+
+ and then not Is_Special_Aliased_Formal_Access
+ (N, Current_Scope)
and then
Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp)
- and then Attr_Id = Attribute_Access
then
-- In an instance, this is a runtime check, but one we know
-- will fail, so generate an appropriate warning. As usual,
@@ -11123,8 +11391,8 @@ package body Sem_Attr is
end if;
end if;
- if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type)
+ if Ekind (Btyp) in E_Access_Protected_Subprogram_Type
+ | E_Anonymous_Access_Protected_Subprogram_Type
then
if Is_Entity_Name (P)
and then not Is_Protected_Type (Scope (Entity (P)))
@@ -11161,8 +11429,8 @@ package body Sem_Attr is
Check_Internal_Protected_Use (N, Entity (P));
end if;
- elsif Ekind_In (Btyp, E_Access_Subprogram_Type,
- E_Anonymous_Access_Subprogram_Type)
+ elsif Ekind (Btyp) in E_Access_Subprogram_Type
+ | E_Anonymous_Access_Subprogram_Type
and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type
then
Error_Msg_F ("context requires a non-protected subprogram", P);
@@ -11232,6 +11500,7 @@ package body Sem_Attr is
-- will be reported when resolving the call.
if Attr_Id /= Attribute_Unrestricted_Access then
+ Error_Msg_Name_1 := Aname;
Error_Msg_N ("prefix of % attribute must be aliased", P);
-- Check for unrestricted access where expected type is a thin
@@ -11256,6 +11525,15 @@ package body Sem_Attr is
end if;
end if;
+ -- Check that the prefix does not have a value conversion of an
+ -- array type since a value conversion is like an aggregate with
+ -- respect to determining accessibility level (RM 3.10.2).
+
+ if not Prefix_With_Safe_Accessibility_Level then
+ Accessibility_Message;
+ return;
+ end if;
+
-- Mark that address of entity is taken in case of
-- 'Unrestricted_Access or in case of a subprogram.
@@ -11294,7 +11572,7 @@ package body Sem_Attr is
and then Comes_From_Source (Subp_Id)
and then Comes_From_Source (N)
and then In_Open_Scopes (Scop)
- and then Ekind_In (Scop, E_Block, E_Procedure, E_Function)
+ and then Ekind (Scop) in E_Block | E_Procedure | E_Function
and then not Has_Completion (Subp_Id)
and then No (Elaboration_Entity (Subp_Id))
and then Nkind (Subp_Decl) = N_Subprogram_Declaration
@@ -11542,7 +11820,7 @@ package body Sem_Attr is
Fam : constant Entity_Id := Entity (Prefix (P));
begin
Resolve (Indx, Entry_Index_Type (Fam));
- Apply_Range_Check (Indx, Entry_Index_Type (Fam));
+ Apply_Scalar_Range_Check (Indx, Entry_Index_Type (Fam));
end;
end if;
@@ -11821,26 +12099,6 @@ package body Sem_Attr is
Expr := Expression (Assoc);
Resolve (Expr, Component_Type (Typ));
- -- For scalar array components set Do_Range_Check when
- -- needed. Constraint checking on non-scalar components
- -- is done in Aggregate_Constraint_Checks, but only if
- -- full analysis is enabled. These flags are not set in
- -- the front-end in GnatProve mode.
-
- if Is_Scalar_Type (Component_Type (Typ))
- and then not Is_OK_Static_Expression (Expr)
- and then not Range_Checks_Suppressed (Component_Type (Typ))
- then
- if Is_Entity_Name (Expr)
- and then Etype (Expr) = Component_Type (Typ)
- then
- null;
-
- else
- Set_Do_Range_Check (Expr);
- end if;
- end if;
-
-- The choices in the association are static constants,
-- or static aggregates each of whose components belongs
-- to the proper index type. However, they must also
@@ -11863,15 +12121,10 @@ package body Sem_Attr is
if Nkind (C) /= N_Aggregate then
Analyze_And_Resolve (C, Etype (Indx));
- Apply_Constraint_Check (C, Etype (Indx));
- Check_Non_Static_Context (C);
-
else
C_E := First (Expressions (C));
while Present (C_E) loop
Analyze_And_Resolve (C_E, Etype (Indx));
- Apply_Constraint_Check (C_E, Etype (Indx));
- Check_Non_Static_Context (C_E);
Next (C_E);
Next_Index (Indx);
@@ -11898,14 +12151,6 @@ package body Sem_Attr is
and then not Error_Posted (Comp)
then
Resolve (Expr, Etype (Entity (Comp)));
-
- if Is_Scalar_Type (Etype (Entity (Comp)))
- and then not Is_OK_Static_Expression (Expr)
- and then not Range_Checks_Suppressed
- (Etype (Entity (Comp)))
- then
- Set_Do_Range_Check (Expr);
- end if;
end if;
Next (Assoc);
@@ -12052,59 +12297,6 @@ package body Sem_Attr is
end if;
end Set_Boolean_Result;
- -------------------------------
- -- Statically_Denotes_Object --
- -------------------------------
-
- function Statically_Denotes_Object (N : Node_Id) return Boolean is
- Indx : Node_Id;
-
- begin
- if Is_Entity_Name (N) then
- return True;
-
- elsif Nkind (N) = N_Selected_Component
- and then Statically_Denotes_Object (Prefix (N))
- and then Present (Entity (Selector_Name (N)))
- then
- declare
- Sel_Id : constant Entity_Id := Entity (Selector_Name (N));
- Comp_Decl : constant Node_Id := Parent (Sel_Id);
-
- begin
- if Depends_On_Discriminant (Sel_Id) then
- return False;
-
- elsif Nkind (Parent (Parent (Comp_Decl))) = N_Variant then
- return False;
-
- else
- return True;
- end if;
- end;
-
- elsif Nkind (N) = N_Indexed_Component
- and then Statically_Denotes_Object (Prefix (N))
- and then Is_Constrained (Etype (Prefix (N)))
- then
- Indx := First (Expressions (N));
- while Present (Indx) loop
- if not Compile_Time_Known_Value (Indx)
- or else Do_Range_Check (Indx)
- then
- return False;
- end if;
-
- Next (Indx);
- end loop;
-
- return True;
-
- else
- return False;
- end if;
- end Statically_Denotes_Object;
-
--------------------------------
-- Stream_Attribute_Available --
--------------------------------
diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads
index 8e212d6..b118a97 100644
--- a/gcc/ada/sem_attr.ads
+++ b/gcc/ada/sem_attr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -212,36 +212,6 @@ package Sem_Attr is
-- value indicating whether or not the body of the designated library
-- unit has been elaborated yet.
- --------------
- -- Enum_Rep --
- --------------
-
- Attribute_Enum_Rep => True,
- -- For every enumeration subtype S, S'Enum_Rep denotes a function
- -- with the following specification:
- --
- -- function S'Enum_Rep (Arg : S'Base) return universal_integer;
- --
- -- The function returns the representation value for the given
- -- enumeration value. This will be equal to the 'Pos value in the
- -- absence of an enumeration representation clause. This is a static
- -- attribute (i.e. the result is static if the argument is static).
-
- --------------
- -- Enum_Val --
- --------------
-
- Attribute_Enum_Val => True,
- -- For every enumeration subtype S, S'Enum_Val denotes a function with
- -- the following specification:
- --
- -- function S'Enum_Val (Arg : universal_integer) return S'Base;
- --
- -- This function performs the inverse transformation to Enum_Rep. Given
- -- a representation value for the type, it returns the corresponding
- -- enumeration value. Constraint_Error is raised if no value of the
- -- enumeration type corresponds to the given integer value.
-
-----------------------
-- Finalization_Size --
-----------------------
@@ -427,6 +397,13 @@ package Sem_Attr is
-- as Range applied to the array itself. The result is of type universal
-- integer.
+ ------------
+ -- Reduce --
+ ------------
+
+ Attribute_Reduce => True,
+ -- See AI12-0262-1
+
---------
-- Ref --
---------
diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb
index e5bd68a..4a16c12 100644
--- a/gcc/ada/sem_aux.adb
+++ b/gcc/ada/sem_aux.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,6 +32,7 @@
with Atree; use Atree;
with Einfo; use Einfo;
+with Nlists; use Nlists;
with Snames; use Snames;
with Stand; use Stand;
with Uintp; use Uintp;
@@ -234,7 +235,7 @@ package body Sem_Aux is
-- either because the tag must be ahead of them.
if Chars (Ent) = Name_uTag then
- Ent := Next_Entity (Ent);
+ Next_Entity (Ent);
end if;
-- Skip all hidden stored discriminants if any
@@ -243,7 +244,7 @@ package body Sem_Aux is
exit when Ekind (Ent) = E_Discriminant
and then not Is_Completely_Hidden (Ent);
- Ent := Next_Entity (Ent);
+ Next_Entity (Ent);
end loop;
-- Call may be on a private type with unknown discriminants, in which
@@ -297,7 +298,7 @@ package body Sem_Aux is
return True;
end if;
- Ent := Next_Entity (Ent);
+ Next_Entity (Ent);
end loop;
return False;
@@ -313,14 +314,14 @@ package body Sem_Aux is
Ent := First_Entity (Typ);
if Chars (Ent) = Name_uTag then
- Ent := Next_Entity (Ent);
+ Next_Entity (Ent);
end if;
if Has_Completely_Hidden_Discriminant (Ent) then
while Present (Ent) loop
exit when Ekind (Ent) = E_Discriminant
and then Is_Completely_Hidden (Ent);
- Ent := Next_Entity (Ent);
+ Next_Entity (Ent);
end loop;
end if;
@@ -344,8 +345,8 @@ package body Sem_Aux is
-- predefined integer types. If the type is formal, it is also a first
-- subtype, and its base type has no freeze node. On the other hand, a
-- subtype of a generic formal is not its own first subtype. Its base
- -- type, if anonymous, is attached to the formal type decl. from which
- -- the first subtype is obtained.
+ -- type, if anonymous, is attached to the formal type declaration from
+ -- which the first subtype is obtained.
if No (F) then
if B = Base_Type (Standard_Integer) then
@@ -423,7 +424,7 @@ package body Sem_Aux is
return Comp;
end if;
- Comp := Next_Entity (Comp);
+ Next_Entity (Comp);
end loop;
-- No tag component found
@@ -485,19 +486,6 @@ package body Sem_Aux is
return Id;
end Get_Called_Entity;
- -------------------
- -- Get_Low_Bound --
- -------------------
-
- function Get_Low_Bound (E : Entity_Id) return Node_Id is
- begin
- if Ekind (E) = E_String_Literal_Subtype then
- return String_Literal_Low_Bound (E);
- else
- return Type_Low_Bound (E);
- end if;
- end Get_Low_Bound;
-
------------------
-- Get_Rep_Item --
------------------
@@ -723,11 +711,11 @@ package body Sem_Aux is
begin
pragma Assert
- (Nkind_In (N, N_Aspect_Specification,
- N_Attribute_Definition_Clause,
- N_Enumeration_Representation_Clause,
- N_Pragma,
- N_Record_Representation_Clause));
+ (Nkind (N) in N_Aspect_Specification
+ | N_Attribute_Definition_Clause
+ | N_Enumeration_Representation_Clause
+ | N_Pragma
+ | N_Record_Representation_Clause);
Item := First_Rep_Item (E);
while Present (Item) loop
@@ -735,7 +723,7 @@ package body Sem_Aux is
return True;
end if;
- Item := Next_Rep_Item (Item);
+ Next_Rep_Item (Item);
end loop;
return False;
@@ -889,13 +877,9 @@ package body Sem_Aux is
function Is_Body (N : Node_Id) return Boolean is
begin
- return
- Nkind (N) in N_Body_Stub
- or else Nkind_In (N, N_Entry_Body,
- N_Package_Body,
- N_Protected_Body,
- N_Subprogram_Body,
- N_Task_Body);
+ return Nkind (N) in
+ N_Body_Stub | N_Entry_Body | N_Package_Body | N_Protected_Body |
+ N_Subprogram_Body | N_Task_Body;
end Is_Body;
---------------------
@@ -984,7 +968,7 @@ package body Sem_Aux is
return True;
end if;
- C := Next_Component (C);
+ Next_Component (C);
end loop;
end;
@@ -1084,8 +1068,7 @@ package body Sem_Aux is
Kind := Nkind (Original_Node (Parent (E)));
return
- Nkind_In (Kind, N_Formal_Object_Declaration,
- N_Formal_Type_Declaration)
+ Kind in N_Formal_Object_Declaration | N_Formal_Type_Declaration
or else Is_Formal_Subprogram (E)
or else
(Ekind (E) = E_Package
@@ -1216,7 +1199,7 @@ package body Sem_Aux is
return True;
end if;
- C := Next_Component (C);
+ Next_Component (C);
end loop;
end;
@@ -1315,7 +1298,7 @@ package body Sem_Aux is
return True;
end if;
- C := Next_Component (C);
+ Next_Component (C);
end loop;
end;
@@ -1343,6 +1326,15 @@ package body Sem_Aux is
N_Protected_Definition);
end Is_Protected_Operation;
+ -------------------------------
+ -- Is_Record_Or_Limited_Type --
+ -------------------------------
+
+ function Is_Record_Or_Limited_Type (Typ : Entity_Id) return Boolean is
+ begin
+ return Is_Record_Type (Typ) or else Is_Limited_Type (Typ);
+ end Is_Record_Or_Limited_Type;
+
----------------------
-- Nearest_Ancestor --
----------------------
@@ -1379,6 +1371,18 @@ package body Sem_Aux is
end if;
end;
+ -- If this is a concurrent declaration with a nonempty interface list,
+ -- get the first progenitor. Account for case of a record type created
+ -- for a concurrent type (which is the only case that seems to occur
+ -- in practice).
+
+ elsif Nkind (D) = N_Full_Type_Declaration
+ and then (Is_Concurrent_Type (Defining_Identifier (D))
+ or else Is_Concurrent_Record_Type (Defining_Identifier (D)))
+ and then Is_Non_Empty_List (Interface_List (Type_Definition (D)))
+ then
+ return Entity (First (Interface_List (Type_Definition (D))));
+
-- If derived type and private type, get the full view to find who we
-- are derived from.
@@ -1427,7 +1431,7 @@ package body Sem_Aux is
return Comp;
end if;
- Comp := Next_Entity (Comp);
+ Next_Entity (Comp);
end loop;
-- No tag component found
@@ -1456,7 +1460,7 @@ package body Sem_Aux is
while Present (Comp) loop
N := N + 1;
- Comp := Next_Component_Or_Discriminant (Comp);
+ Next_Component_Or_Discriminant (Comp);
end loop;
return N;
@@ -1473,7 +1477,7 @@ package body Sem_Aux is
begin
while Present (Discr) loop
N := N + 1;
- Discr := Next_Discriminant (Discr);
+ Next_Discriminant (Discr);
end loop;
return N;
@@ -1650,24 +1654,6 @@ package body Sem_Aux is
return N;
end Subprogram_Specification;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- Obsolescent_Warnings.Tree_Read;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Obsolescent_Warnings.Tree_Write;
- end Tree_Write;
-
--------------------
-- Ultimate_Alias --
--------------------
diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads
index ee3a2b3..c15c271 100644
--- a/gcc/ada/sem_aux.ads
+++ b/gcc/ada/sem_aux.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,8 +30,7 @@
-- --
------------------------------------------------------------------------------
--- Package containing utility procedures used throughout the compiler,
--- and also by ASIS so dependencies are limited to ASIS included packages.
+-- Package containing utility procedures used throughout the compiler.
-- Historical note. Many of the routines here were originally in Einfo, but
-- Einfo is supposed to be a relatively low level package dealing with the
@@ -71,16 +70,7 @@ package Sem_Aux is
procedure Initialize;
-- Called at the start of compilation of each new main source file to
- -- initialize the allocation of the Obsolescent_Warnings table. Note that
- -- Initialize must not be called if Tree_Read is used.
-
- procedure Tree_Read;
- -- Initializes Obsolescent_Warnings table from current tree file using the
- -- relevant Table.Tree_Read routine.
-
- procedure Tree_Write;
- -- Writes out Obsolescent_Warnings table to current tree file using the
- -- relevant Table.Tree_Write routine.
+ -- initialize the allocation of the Obsolescent_Warnings table.
-----------------
-- Subprograms --
@@ -175,9 +165,6 @@ package Sem_Aux is
-- Obtain the entity of the entry, operator, or subprogram being invoked
-- by call Call.
- function Get_Low_Bound (E : Entity_Id) return Node_Id;
- -- For an index subtype or string literal subtype, returns its low bound
-
function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind;
-- Op must be an entity with an Ekind of E_Operator. This function returns
-- the Nkind value that would be used to construct a unary operator node
@@ -375,6 +362,9 @@ package Sem_Aux is
-- Given a subprogram or entry, determines whether E is a protected entry
-- or subprogram.
+ function Is_Record_Or_Limited_Type (Typ : Entity_Id) return Boolean;
+ -- Return True if Typ requires is a record or limited type.
+
function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id;
-- Given a subtype Typ, this function finds out the nearest ancestor from
-- which constraints and predicates are inherited. There is no simple link
diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb
index 8617ea7..6cda6a9 100644
--- a/gcc/ada/sem_case.adb
+++ b/gcc/ada/sem_case.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -458,8 +458,7 @@ package body Sem_Case is
Choice : Node_Id;
Choice_Hi : Uint;
Choice_Lo : Uint;
- Prev_Choice : Node_Id;
- pragma Warnings (Off, Prev_Choice);
+ Prev_Choice : Node_Id := Empty;
Prev_Hi : Uint;
begin
@@ -485,6 +484,8 @@ package body Sem_Case is
end if;
end loop;
+ pragma Assert (Present (Prev_Choice));
+
if Sloc (Prev_Choice) <= Sloc (Choice) then
Error_Msg_Sloc := Sloc (Prev_Choice);
Dup_Choice (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice);
@@ -997,7 +998,8 @@ package body Sem_Case is
function Lit_Of (Value : Uint) return Node_Id;
-- Returns the Node_Id for the enumeration literal corresponding to the
- -- position given by Value within the enumeration type Choice_Type.
+ -- position given by Value within the enumeration type Choice_Type. The
+ -- returned value has its Is_Static_Expression flag set to true.
------------------
-- Build_Choice --
@@ -1011,10 +1013,11 @@ package body Sem_Case is
-- If there is only one choice value missing between Value1 and
-- Value2, build an integer or enumeration literal to represent it.
- if (Value2 - Value1) = 0 then
+ if Value1 = Value2 then
if Is_Integer_Type (Choice_Type) then
Lit_Node := Make_Integer_Literal (Loc, Value1);
Set_Etype (Lit_Node, Choice_Type);
+ Set_Is_Static_Expression (Lit_Node);
else
Lit_Node := Lit_Of (Value1);
end if;
@@ -1027,8 +1030,10 @@ package body Sem_Case is
if Is_Integer_Type (Choice_Type) then
Lo := Make_Integer_Literal (Loc, Value1);
Set_Etype (Lo, Choice_Type);
+ Set_Is_Static_Expression (Lo);
Hi := Make_Integer_Literal (Loc, Value2);
Set_Etype (Hi, Choice_Type);
+ Set_Is_Static_Expression (Hi);
Lit_Node :=
Make_Range (Loc,
Low_Bound => Lo,
diff --git a/gcc/ada/sem_case.ads b/gcc/ada/sem_case.ads
index 16d3f2e..16fa243 100644
--- a/gcc/ada/sem_case.ads
+++ b/gcc/ada/sem_case.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -49,8 +49,7 @@
-- 4. In the case of static predicates, we need to expand out choices that
-- correspond to the predicate for the back end. This expansion destroys
--- the list of choices, so it should be delayed to expansion time. We do
--- not want to mess up the -gnatct ASIS tree, which needs to be able to
+-- the list of choices, so it should be delayed to expansion time.
-- Step 1 is performed by the generic procedure Analyze_Choices, which is
-- called when the variant record or case statement/expression is first
@@ -66,12 +65,9 @@
-- for predicated subtypes to accurately construct this.
-- Step 4 is performed by the procedure Expand_Static_Predicates_In_Choices.
--- For case statements, this call only happens during expansion, so the tree
--- generated for ASIS does not have this expansion. For the Variant case, the
--- expansion is done in the ASIS -gnatct case, but with a proper Rewrite call
--- on the N_Variant node, so ASIS can retrieve the original. The reason we do
--- the expansion unconditionally for variants is that other processing, for
--- example for aggregates, relies on having a complete list of choices.
+-- For case statements, this call only happens during expansion. The reason
+-- we do the expansion unconditionally for variants is that other processing,
+-- for example for aggregates, relies on having a complete list of choices.
-- Historical note: We used to perform all four of these functions at once in
-- a single procedure called Analyze_Choices. This routine was called at the
diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb
index 833df88..be1e67e 100644
--- a/gcc/ada/sem_cat.adb
+++ b/gcc/ada/sem_cat.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -793,8 +793,8 @@ package body Sem_Cat is
if Ekind (E) in Subprogram_Kind then
Declaration := Unit_Declaration_Node (E);
- if Nkind_In (Declaration, N_Subprogram_Body,
- N_Subprogram_Renaming_Declaration)
+ if Nkind (Declaration) in
+ N_Subprogram_Body | N_Subprogram_Renaming_Declaration
then
Specification := Corresponding_Spec (Declaration);
end if;
@@ -1003,7 +1003,7 @@ package body Sem_Cat is
-- Body of RCI unit does not need validation
if Is_Remote_Call_Interface (E)
- and then Nkind_In (N, N_Package_Body, N_Subprogram_Body)
+ and then Nkind (N) in N_Package_Body | N_Subprogram_Body
then
return;
end if;
@@ -1506,8 +1506,8 @@ package body Sem_Cat is
null;
- elsif Ekind_In (Param_Type, E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
+ elsif Ekind (Param_Type) in E_Anonymous_Access_Type
+ | E_Anonymous_Access_Subprogram_Type
then
-- From RM E.2.2(14), no anonymous access parameter other than
-- controlling ones may be used (because an anonymous access
@@ -1583,9 +1583,9 @@ package body Sem_Cat is
("limited type not allowed in rci unit", Parent (E));
Explain_Limited_Type (E, Parent (E));
- elsif Ekind_In (E, E_Generic_Function,
- E_Generic_Package,
- E_Generic_Procedure)
+ elsif Ekind (E) in E_Generic_Function
+ | E_Generic_Package
+ | E_Generic_Procedure
then
Error_Msg_N ("generic declaration not allowed in rci unit",
Parent (E));
@@ -1815,7 +1815,17 @@ package body Sem_Cat is
-- 4. called from sem_res Resolve_Actuals
- if K = N_Attribute_Reference then
+ if K = N_Attribute_Definition_Clause then
+ E := Etype (Entity (N));
+
+ if Is_Remote_Access_To_Class_Wide_Type (E) then
+ Error_Msg_Name_1 := Chars (N);
+ Error_Msg_N
+ ("cannot specify% aspect for a remote operand", N);
+ return;
+ end if;
+
+ elsif K = N_Attribute_Reference then
E := Etype (Prefix (N));
if Is_Remote_Access_To_Class_Wide_Type (E) then
diff --git a/gcc/ada/sem_cat.ads b/gcc/ada/sem_cat.ads
index 960b158..2c95897 100644
--- a/gcc/ada/sem_cat.ads
+++ b/gcc/ada/sem_cat.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -120,8 +120,8 @@ package Sem_Cat is
-- Checks that Storage_Pool and Storage_Size attribute references are
-- not applied to remote access-to-class-wide types. Also checks that the
-- expected type for an allocator cannot be a remote access-to-class-wide
- -- type. ALso checks that a remote access-to-class-wide type cannot be an
- -- actual parameter for a generic formal access type. RM E.2.3(22).
+ -- type. Also checks that a remote access-to-class-wide type cannot be an
+ -- actual parameter for a generic formal access type. RM E.2.2(17).
procedure Validate_RT_RAT_Component (N : Node_Id);
-- Given N, the package library unit declaration node, we should check
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index ee18b37..76b68a1 100644
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,6 +29,7 @@ with Contracts; use Contracts;
with Debug; use Debug;
with Einfo; use Einfo;
with Errout; use Errout;
+with Exp_Put_Image;
with Exp_Util; use Exp_Util;
with Elists; use Elists;
with Fname; use Fname;
@@ -320,7 +321,6 @@ package body Sem_Ch10 is
Nam_Ent : constant Entity_Id := Entity (Name (Clause));
Cont_Item : Node_Id;
Prag_Unit : Node_Id;
- Subt_Mark : Node_Id;
Use_Item : Node_Id;
function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean;
@@ -390,19 +390,31 @@ package body Sem_Ch10 is
elsif Nkind (Cont_Item) = N_Use_Type_Clause
and then not Used_Type_Or_Elab
then
- Subt_Mark := Subtype_Mark (Cont_Item);
- if not Used_Type_Or_Elab
- and then Same_Unit (Prefix (Subt_Mark), Nam_Ent)
- then
- Used_Type_Or_Elab := True;
- end if;
+ declare
+ UE : Node_Id;
+
+ begin
+ -- Loop through prefixes looking for a match
+
+ UE := Prefix (Subtype_Mark (Cont_Item));
+ loop
+ if not Used_Type_Or_Elab
+ and then Same_Unit (UE, Nam_Ent)
+ then
+ Used_Type_Or_Elab := True;
+ end if;
+
+ exit when Nkind (UE) /= N_Expanded_Name;
+ UE := Prefix (UE);
+ end loop;
+ end;
-- Pragma Elaborate or Elaborate_All
elsif Nkind (Cont_Item) = N_Pragma
and then
- Nam_In (Pragma_Name_Unmapped (Cont_Item),
- Name_Elaborate, Name_Elaborate_All)
+ Pragma_Name_Unmapped (Cont_Item)
+ in Name_Elaborate | Name_Elaborate_All
and then not Used_Type_Or_Elab
then
Prag_Unit :=
@@ -610,6 +622,8 @@ package body Sem_Ch10 is
-- Start of processing for Analyze_Compilation_Unit
begin
+ Exp_Put_Image.Preload_Sink (N);
+
Process_Compilation_Unit_Pragmas (N);
-- If the unit is a subunit whose parent has not been analyzed (which
@@ -710,8 +724,8 @@ package body Sem_Ch10 is
-- Verify that the library unit is a package declaration
- if not Nkind_In (Unit (Lib_Unit), N_Package_Declaration,
- N_Generic_Package_Declaration)
+ if Nkind (Unit (Lib_Unit)) not in
+ N_Package_Declaration | N_Generic_Package_Declaration
then
Error_Msg_N
("no legal package declaration for package body", N);
@@ -938,8 +952,8 @@ package body Sem_Ch10 is
-- Analyze the contract of a [generic] subprogram that acts as a
-- compilation unit after all compilation pragmas have been analyzed.
- if Nkind_In (Unit_Node, N_Generic_Subprogram_Declaration,
- N_Subprogram_Declaration)
+ if Nkind (Unit_Node) in
+ N_Generic_Subprogram_Declaration | N_Subprogram_Declaration
then
Analyze_Entry_Or_Subprogram_Contract (Defining_Entity (Unit_Node));
end if;
@@ -984,10 +998,10 @@ package body Sem_Ch10 is
-- next compilation, which is either the main unit or some other unit
-- in the context.
- if Nkind_In (Unit_Node, N_Package_Declaration,
- N_Package_Renaming_Declaration,
- N_Subprogram_Declaration)
- or else Nkind (Unit_Node) in N_Generic_Declaration
+ if Nkind (Unit_Node) in N_Package_Declaration
+ | N_Package_Renaming_Declaration
+ | N_Subprogram_Declaration
+ | N_Generic_Declaration
or else (Nkind (Unit_Node) = N_Subprogram_Body
and then Acts_As_Spec (Unit_Node))
then
@@ -1135,9 +1149,9 @@ package body Sem_Ch10 is
-- are triggered by these subprograms.
if GNATprove_Mode
- and then Nkind_In (Unit_Node, N_Function_Instantiation,
- N_Procedure_Instantiation,
- N_Subprogram_Body)
+ and then Nkind (Unit_Node) in N_Function_Instantiation
+ | N_Procedure_Instantiation
+ | N_Subprogram_Body
then
declare
Spec : Node_Id;
@@ -1176,10 +1190,10 @@ package body Sem_Ch10 is
-- units manufactured by the compiler never need elab checks.
if Comes_From_Source (N)
- and then Nkind_In (Unit_Node, N_Package_Declaration,
- N_Generic_Package_Declaration,
- N_Subprogram_Declaration,
- N_Generic_Subprogram_Declaration)
+ and then Nkind (Unit_Node) in N_Package_Declaration
+ | N_Generic_Package_Declaration
+ | N_Subprogram_Declaration
+ | N_Generic_Subprogram_Declaration
then
declare
Loc : constant Source_Ptr := Sloc (N);
@@ -1464,10 +1478,10 @@ package body Sem_Ch10 is
-- Verify that the illegal contexts given in 10.1.2 (18/2) are
-- properly rejected, including renaming declarations.
- if not Nkind_In (Ukind, N_Package_Declaration,
- N_Subprogram_Declaration)
- and then Ukind not in N_Generic_Declaration
- and then Ukind not in N_Generic_Instantiation
+ if Ukind not in N_Package_Declaration
+ | N_Subprogram_Declaration
+ | N_Generic_Declaration
+ | N_Generic_Instantiation
then
Error_Msg_N ("limited with_clause not allowed here", Item);
@@ -1522,10 +1536,9 @@ package body Sem_Ch10 is
if Item /= It
and then Nkind (It) = N_With_Clause
and then not Limited_Present (It)
- and then
- Nkind_In (Unit (Library_Unit (It)),
- N_Package_Declaration,
- N_Package_Renaming_Declaration)
+ and then Nkind (Unit (Library_Unit (It))) in
+ N_Package_Declaration |
+ N_Package_Renaming_Declaration
then
if Nkind (Unit (Library_Unit (It))) =
N_Package_Declaration
@@ -1655,9 +1668,9 @@ package body Sem_Ch10 is
procedure Optional_Subunit;
-- This procedure is called when the main unit is a stub, or when we
-- are not generating code. In such a case, we analyze the subunit if
- -- present, which is user-friendly and in fact required for ASIS, but we
- -- don't complain if the subunit is missing. In GNATprove_Mode, we issue
- -- an error to avoid formal verification of a partial unit.
+ -- present, which is user-friendly, but we don't complain if the subunit
+ -- is missing. In GNATprove_Mode, we issue an error to avoid formal
+ -- verification of a partial unit.
----------------------
-- Optional_Subunit --
@@ -1673,7 +1686,7 @@ package body Sem_Ch10 is
-- ignore all errors. Note that Fatal_Error will still be set, so we
-- will be able to check for this case below.
- if not (ASIS_Mode or GNATprove_Mode) then
+ if not GNATprove_Mode then
Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
end if;
@@ -1684,7 +1697,7 @@ package body Sem_Ch10 is
Subunit => True,
Error_Node => N);
- if not (ASIS_Mode or GNATprove_Mode) then
+ if not GNATprove_Mode then
Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
end if;
@@ -1808,27 +1821,13 @@ package body Sem_Ch10 is
-- If the main unit is a subunit, then we are just performing semantic
-- analysis on that subunit, and any other subunits of any parent unit
- -- should be ignored, except that if we are building trees for ASIS
- -- usage we want to annotate the stub properly. If the main unit is
- -- itself a subunit, another subunit is irrelevant unless it is a
- -- subunit of the current one, that is to say appears in the current
- -- source tree.
+ -- should be ignored. If the main unit is itself a subunit, another
+ -- subunit is irrelevant unless it is a subunit of the current one, that
+ -- is to say appears in the current source tree.
elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
and then Subunit_Name /= Unit_Name (Main_Unit)
then
- if ASIS_Mode then
- declare
- PB : constant Node_Id := Proper_Body (Unit (Cunit (Main_Unit)));
- begin
- if Nkind_In (PB, N_Package_Body, N_Subprogram_Body)
- and then List_Containing (N) = Declarations (PB)
- then
- Optional_Subunit;
- end if;
- end;
- end if;
-
-- But before we return, set the flag for unloaded subunits. This
-- will suppress junk warnings of variables in the same declarative
-- part (or a higher level one) that are in danger of looking unused
@@ -2022,9 +2021,8 @@ package body Sem_Ch10 is
-- Verify that the identifier for the stub is unique within this
-- declarative part.
- if Nkind_In (Parent (N), N_Block_Statement,
- N_Package_Body,
- N_Subprogram_Body)
+ if Nkind (Parent (N)) in
+ N_Block_Statement | N_Package_Body | N_Subprogram_Body
then
Decl := First (Declarations (Parent (N)));
while Present (Decl) and then Decl /= N loop
@@ -2361,8 +2359,7 @@ package body Sem_Ch10 is
Remove_Scope;
end if;
- if Nkind_In (Unit (Lib_Spec), N_Package_Body,
- N_Subprogram_Body)
+ if Nkind (Unit (Lib_Spec)) in N_Package_Body | N_Subprogram_Body
then
Remove_Context (Library_Unit (Lib_Spec));
end if;
@@ -2610,14 +2607,7 @@ package body Sem_Ch10 is
-- clauses into regular with clauses.
if Sloc (U) /= No_Location then
- if In_Predefined_Unit (U)
-
- -- In ASIS mode the rtsfind mechanism plays no role, and
- -- we need to maintain the original tree structure, so
- -- this transformation is not performed in this case.
-
- and then not ASIS_Mode
- then
+ if In_Predefined_Unit (U) then
Set_Limited_Present (N, False);
Analyze_With_Clause (N);
else
@@ -2662,9 +2652,8 @@ package body Sem_Ch10 is
if Nkind (Nam) = N_Selected_Component
and then Nkind (Prefix (Nam)) = N_Identifier
and then Chars (Prefix (Nam)) = Name_Gnat
- and then Nam_In (Chars (Selector_Name (Nam)),
- Name_Most_Recent_Exception,
- Name_Exception_Traces)
+ and then Chars (Selector_Name (Nam))
+ in Name_Most_Recent_Exception | Name_Exception_Traces
then
Check_Restriction (No_Exception_Propagation, N);
Special_Exception_Package_Used := True;
@@ -2716,7 +2705,7 @@ package body Sem_Ch10 is
if Ada_Version < Ada_2020
and then Warn_On_Ada_202X_Compatibility
then
- Error_Msg_N ("& is an Ada 202X unit?i?", Name (N));
+ Error_Msg_N ("& is an Ada 202x unit?i?", Name (N));
end if;
end case;
end if;
@@ -2974,7 +2963,7 @@ package body Sem_Ch10 is
-- Start of processing for Check_Private_Child_Unit
begin
- if Nkind_In (Lib_Unit, N_Package_Body, N_Subprogram_Body) then
+ if Nkind (Lib_Unit) in N_Package_Body | N_Subprogram_Body then
Curr_Unit := Defining_Entity (Unit (Library_Unit (N)));
Par_Lib := Curr_Unit;
@@ -3081,7 +3070,7 @@ package body Sem_Ch10 is
elsif Curr_Private
or else Private_Present (Item)
- or else Nkind_In (Lib_Unit, N_Package_Body, N_Subunit)
+ or else Nkind (Lib_Unit) in N_Package_Body | N_Subunit
or else (Nkind (Lib_Unit) = N_Subprogram_Body
and then not Acts_As_Spec (Parent (Lib_Unit)))
then
@@ -3108,11 +3097,9 @@ package body Sem_Ch10 is
Kind : constant Node_Kind := Nkind (Par);
begin
- if Nkind_In (Kind, N_Package_Body,
- N_Subprogram_Body,
- N_Task_Body,
- N_Protected_Body)
- and then Nkind_In (Parent (Par), N_Compilation_Unit, N_Subunit)
+ if Kind in
+ N_Package_Body | N_Subprogram_Body | N_Task_Body | N_Protected_Body
+ and then Nkind (Parent (Par)) in N_Compilation_Unit | N_Subunit
then
null;
@@ -3204,12 +3191,16 @@ package body Sem_Ch10 is
Set_Library_Unit (Withn, Parent (Unit_Declaration_Node (Ent)));
Set_Parent_With (Withn);
- -- If the unit is a package or generic package declaration, a private_
- -- with_clause on a child unit implies that the implicit with on the
- -- parent is also private.
+ -- If the unit is a [generic] package or subprogram declaration
+ -- (including a subprogram body acting as spec), a private_with_clause
+ -- on a child unit implies that the implicit with on the parent is also
+ -- private.
- if Nkind_In (Unit (N), N_Generic_Package_Declaration,
- N_Package_Declaration)
+ if Nkind (Unit (N)) in N_Generic_Package_Declaration
+ | N_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Subprogram_Declaration
+ | N_Subprogram_Body
then
Set_Private_Present (Withn, Private_Present (Item));
end if;
@@ -3718,10 +3709,10 @@ package body Sem_Ch10 is
Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N);
end if;
- if Nkind_In (Lib_Unit, N_Generic_Package_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Package_Declaration,
- N_Subprogram_Declaration)
+ if Nkind (Lib_Unit) in N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Package_Declaration
+ | N_Subprogram_Declaration
then
if Is_Child_Spec (Lib_Unit) then
Lib_Parent := Defining_Entity (Unit (Parent_Spec (Lib_Unit)));
@@ -3911,9 +3902,8 @@ package body Sem_Ch10 is
elsif Private_Present (Parent (Item))
or else Curr_Private
or else Private_Present (Item)
- or else Nkind_In (Unit (Parent (Item)), N_Package_Body,
- N_Subprogram_Body,
- N_Subunit)
+ or else Nkind (Unit (Parent (Item))) in
+ N_Package_Body | N_Subprogram_Body | N_Subunit
then
-- Current unit is private, of descendant of a private unit
@@ -4071,9 +4061,8 @@ package body Sem_Ch10 is
then
if not Private_Present (Item)
or else Private_Present (N)
- or else Nkind_In (Unit (N), N_Package_Body,
- N_Subprogram_Body,
- N_Subunit)
+ or else Nkind (Unit (N)) in
+ N_Package_Body | N_Subprogram_Body | N_Subunit
then
Install_Limited_With_Clause (Item);
end if;
@@ -4165,9 +4154,9 @@ package body Sem_Ch10 is
end if;
if Ekind (P_Name) = E_Generic_Package
- and then not Nkind_In (Lib_Unit, N_Generic_Subprogram_Declaration,
- N_Generic_Package_Declaration)
- and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration
+ and then Nkind (Lib_Unit) not in N_Generic_Subprogram_Declaration
+ | N_Generic_Package_Declaration
+ | N_Generic_Renaming_Declaration
then
Error_Msg_N
("child of a generic package must be a generic unit", Lib_Unit);
@@ -4630,17 +4619,17 @@ package body Sem_Ch10 is
-- Save for subsequent examination of import pragmas.
if Comes_From_Source (Decl)
- and then (Nkind_In (Decl, N_Subprogram_Declaration,
- N_Subprogram_Renaming_Declaration,
- N_Generic_Subprogram_Declaration))
+ and then (Nkind (Decl) in N_Subprogram_Declaration
+ | N_Subprogram_Renaming_Declaration
+ | N_Generic_Subprogram_Declaration)
then
Append_Elmt (Defining_Entity (Decl), Subp_List);
-- Package declaration of generic package declaration. We need
-- to recursively examine nested declarations.
- elsif Nkind_In (Decl, N_Package_Declaration,
- N_Generic_Package_Declaration)
+ elsif Nkind (Decl) in N_Package_Declaration
+ | N_Generic_Package_Declaration
then
Check_Declarations (Specification (Decl));
@@ -4660,14 +4649,14 @@ package body Sem_Ch10 is
Decl := First (Private_Declarations (Spec));
while Present (Decl) loop
if Comes_From_Source (Decl)
- and then (Nkind_In (Decl, N_Subprogram_Declaration,
- N_Subprogram_Renaming_Declaration,
- N_Generic_Subprogram_Declaration))
+ and then Nkind (Decl) in N_Subprogram_Declaration
+ | N_Subprogram_Renaming_Declaration
+ | N_Generic_Subprogram_Declaration
then
Append_Elmt (Defining_Entity (Decl), Subp_List);
- elsif Nkind_In (Decl, N_Package_Declaration,
- N_Generic_Package_Declaration)
+ elsif Nkind (Decl) in N_Package_Declaration
+ | N_Generic_Package_Declaration
then
Check_Declarations (Specification (Decl));
@@ -4902,8 +4891,8 @@ package body Sem_Ch10 is
-- corresponding spec, otherwise follow pointer to parent spec.
if Present (Library_Unit (Aux_Unit))
- and then Nkind_In (Unit (Aux_Unit),
- N_Package_Body, N_Subprogram_Body)
+ and then Nkind (Unit (Aux_Unit)) in
+ N_Package_Body | N_Subprogram_Body
then
if Aux_Unit = Library_Unit (Aux_Unit) then
@@ -5273,9 +5262,8 @@ package body Sem_Ch10 is
-- Set entity of parent identifiers if the unit is a child
-- unit. This ensures that the tree is properly formed from
- -- semantic point of view (e.g. for ASIS queries). The unit
- -- entities are not fully analyzed, so we need to follow unit
- -- links in the tree.
+ -- semantic point of view. The unit entities are not fully
+ -- analyzed, so we need to follow unit links in the tree.
Set_Entity (Nam, Ent);
@@ -5555,7 +5543,7 @@ package body Sem_Ch10 is
E1 : constant Entity_Id := Defining_Entity (Unit (U1));
E2 : Entity_Id;
begin
- if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then
+ if Nkind (Unit (U2)) in N_Package_Body | N_Subprogram_Body then
E2 := Defining_Entity (Unit (Library_Unit (U2)));
return Is_Ancestor_Package (E1, E2);
else
@@ -6062,12 +6050,12 @@ package body Sem_Ch10 is
-- Types
- elsif Nkind_In (Decl, N_Full_Type_Declaration,
- N_Incomplete_Type_Declaration,
- N_Private_Extension_Declaration,
- N_Private_Type_Declaration,
- N_Protected_Type_Declaration,
- N_Task_Type_Declaration)
+ elsif Nkind (Decl) in N_Full_Type_Declaration
+ | N_Incomplete_Type_Declaration
+ | N_Private_Extension_Declaration
+ | N_Private_Type_Declaration
+ | N_Protected_Type_Declaration
+ | N_Task_Type_Declaration
then
Def_Id := Defining_Entity (Decl);
@@ -6086,8 +6074,8 @@ package body Sem_Ch10 is
(Nkind (Def) = N_Derived_Type_Definition
and then Present (Record_Extension_Part (Def)));
- elsif Nkind_In (Decl, N_Incomplete_Type_Declaration,
- N_Private_Type_Declaration)
+ elsif Nkind (Decl) in N_Incomplete_Type_Declaration
+ | N_Private_Type_Declaration
then
Is_Tagged := Tagged_Present (Decl);
@@ -6317,7 +6305,7 @@ package body Sem_Ch10 is
if Is_Subprogram (E) and then Has_Pragma_Inline (E) then
return True;
- elsif Ekind_In (E, E_Generic_Function, E_Generic_Procedure) then
+ elsif Is_Generic_Subprogram (E) then
-- A generic subprogram always requires the presence of its
-- body because an instantiation needs both templates. The only
@@ -6369,7 +6357,7 @@ package body Sem_Ch10 is
then
Set_Body_Needed_For_SAL (Unit_Name);
- elsif Ekind_In (Unit_Name, E_Generic_Procedure, E_Generic_Function) then
+ elsif Ekind (Unit_Name) in E_Generic_Procedure | E_Generic_Function then
Set_Body_Needed_For_SAL (Unit_Name);
elsif Is_Subprogram (Unit_Name)
@@ -6865,7 +6853,7 @@ package body Sem_Ch10 is
-- as a small optimization to subsequent handling of private_with
-- clauses in other nested packages. We replace the clause with
-- a null statement, which is otherwise ignored by the rest of
- -- the compiler, so that ASIS tools can reconstruct the source.
+ -- the compiler.
if In_Regular_With_Clause (Entity (Name (Item))) then
declare
diff --git a/gcc/ada/sem_ch10.ads b/gcc/ada/sem_ch10.ads
index 0a0cde0..11f1586 100644
--- a/gcc/ada/sem_ch10.ads
+++ b/gcc/ada/sem_ch10.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb
index 78c18f3..940c93b 100644
--- a/gcc/ada/sem_ch11.adb
+++ b/gcc/ada/sem_ch11.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -433,7 +433,7 @@ package body Sem_Ch11 is
if ((Is_Subprogram (Current_Scope) or else Is_Entry (Current_Scope))
and then Chars (Current_Scope) /= Name_uPostconditions)
- or else Ekind_In (Current_Scope, E_Block, E_Task_Type)
+ or else Ekind (Current_Scope) in E_Block | E_Task_Type
then
Warn_On_Useless_Assignments (Current_Scope);
end if;
@@ -460,8 +460,6 @@ package body Sem_Ch11 is
Check_Compiler_Unit ("raise expression", N);
end if;
- Check_SPARK_05_Restriction ("raise expression is not allowed", N);
-
-- Check exception restrictions on the original source
if Comes_From_Source (N) then
@@ -517,10 +515,6 @@ package body Sem_Ch11 is
Par : Node_Id;
begin
- if Comes_From_Source (N) then
- Check_SPARK_05_Restriction ("raise statement is not allowed", N);
- end if;
-
Check_Unreachable_Code (N);
-- Check exception restrictions on the original source
@@ -543,7 +537,7 @@ package body Sem_Ch11 is
-- Skip past null statements and pragmas
while Present (P)
- and then Nkind_In (P, N_Null_Statement, N_Pragma)
+ and then Nkind (P) in N_Null_Statement | N_Pragma
loop
P := Prev (P);
end loop;
@@ -600,11 +594,9 @@ package body Sem_Ch11 is
if No (Exception_Id) then
P := Parent (N);
- while not Nkind_In (P, N_Exception_Handler,
- N_Subprogram_Body,
- N_Package_Body,
- N_Task_Body,
- N_Entry_Body)
+ while Nkind (P) not in
+ N_Exception_Handler | N_Subprogram_Body | N_Package_Body |
+ N_Task_Body | N_Entry_Body
loop
P := Parent (P);
end loop;
@@ -722,10 +714,6 @@ package body Sem_Ch11 is
-- Start of processing for Analyze_Raise_xxx_Error
begin
- if Nkind (Original_Node (N)) = N_Raise_Statement then
- Check_SPARK_05_Restriction ("raise statement is not allowed", N);
- end if;
-
if No (Etype (N)) then
Set_Etype (N, Standard_Void_Type);
end if;
diff --git a/gcc/ada/sem_ch11.ads b/gcc/ada/sem_ch11.ads
index 3df93a3..b10bc9d 100644
--- a/gcc/ada/sem_ch11.ads
+++ b/gcc/ada/sem_ch11.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index dc3a3c2..cbf27e2 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -495,6 +495,22 @@ package body Sem_Ch12 is
-- nodes or subprogram body and declaration nodes depending on the case).
-- On return, the node N has been rewritten with the actual body.
+ function Build_Subprogram_Decl_Wrapper
+ (Formal_Subp : Entity_Id) return Node_Id;
+ -- Ada 2020 allows formal subprograms to carry pre/postconditions.
+ -- At the point of instantiation these contracts apply to uses of
+ -- the actual subprogram. This is implemented by creating wrapper
+ -- subprograms instead of the renamings previously used to link
+ -- formal subprograms and the corresponding actuals. If the actual
+ -- is not an entity (e.g. an attribute reference) a renaming is
+ -- created to handle the expansion of the attribute.
+
+ function Build_Subprogram_Body_Wrapper
+ (Formal_Subp : Entity_Id;
+ Actual_Name : Node_Id) return Node_Id;
+ -- The body of the wrapper is a call to the actual, with the generated
+ -- pre/postconditon checks added.
+
procedure Check_Access_Definition (N : Node_Id);
-- Subsidiary routine to null exclusion processing. Perform an assertion
-- check on Ada version and the presence of an access definition in N.
@@ -651,6 +667,10 @@ package body Sem_Ch12 is
-- Traverse the Exchanged_Views list to see if a type was private
-- and has already been flipped during this phase of instantiation.
+ function Has_Contracts (Decl : Node_Id) return Boolean;
+ -- Determine whether a formal subprogram has a Pre- or Postcondition,
+ -- in which case a subprogram wrapper has to be built for the actual.
+
procedure Hide_Current_Scope;
-- When instantiating a generic child unit, the parent context must be
-- present, but the instance and all entities that may be generated
@@ -1078,6 +1098,14 @@ package body Sem_Ch12 is
-- In Ada 2005, indicates partial parameterization of a formal
-- package. As usual an other association must be last in the list.
+ procedure Build_Subprogram_Wrappers;
+ -- Ada 2020: AI12-0272 introduces pre/postconditions for formal
+ -- subprograms. The implementation of making the formal into a renaming
+ -- of the actual does not work, given that subprogram renaming cannot
+ -- carry aspect specifications. Instead we must create subprogram
+ -- wrappers whose body is a call to the actual, and whose declaration
+ -- carries the aspects of the formal.
+
procedure Check_Fixed_Point_Actual (Actual : Node_Id);
-- Warn if an actual fixed-point type has user-defined arithmetic
-- operations, but there is no corresponding formal in the generic,
@@ -1101,7 +1129,7 @@ package body Sem_Ch12 is
-- actuals are positional, return the next one, if any. If the actuals
-- are named, scan the parameter associations to find the right one.
-- A_F is the corresponding entity in the analyzed generic, which is
- -- placed on the selector name for ASIS use.
+ -- placed on the selector name.
--
-- In Ada 2005, a named association may be given with a box, in which
-- case Matching_Actual sets Found_Assoc to the generic association,
@@ -1131,6 +1159,70 @@ package body Sem_Ch12 is
-- anonymous types, the presence a formal equality will introduce an
-- implicit declaration for the corresponding inequality.
+ -----------------------------------------
+ -- procedure Build_Subprogram_Wrappers --
+ -----------------------------------------
+
+ procedure Build_Subprogram_Wrappers is
+ Formal : constant Entity_Id :=
+ Defining_Unit_Name (Specification (Analyzed_Formal));
+ Aspect_Spec : Node_Id;
+ Decl_Node : Node_Id;
+ Actual_Name : Node_Id;
+
+ begin
+ -- Create declaration for wrapper subprogram
+ -- The actual can be overloaded, in which case it will be
+ -- resolved when the call in the wrapper body is analyzed.
+ -- We attach the possible interpretations of the actual to
+ -- the name to be used in the call in the wrapper body.
+
+ if Is_Entity_Name (Match) then
+ Actual_Name := New_Occurrence_Of (Entity (Match), Sloc (Match));
+
+ if Is_Overloaded (Match) then
+ Save_Interps (Match, Actual_Name);
+ end if;
+
+ else
+ -- Use renaming declaration created when analyzing actual.
+ -- This may be incomplete if there are several formal
+ -- subprograms whose actual is an attribute ???
+
+ declare
+ Renaming_Decl : constant Node_Id := Last (Assoc_List);
+
+ begin
+ Actual_Name := New_Occurrence_Of
+ (Defining_Entity (Renaming_Decl), Sloc (Match));
+ Set_Etype (Actual_Name, Get_Instance_Of (Etype (Formal)));
+ end;
+ end if;
+
+ Decl_Node := Build_Subprogram_Decl_Wrapper (Formal);
+
+ -- Transfer aspect specifications from formal subprogram to wrapper
+
+ Set_Aspect_Specifications (Decl_Node,
+ New_Copy_List_Tree (Aspect_Specifications (Analyzed_Formal)));
+
+ Aspect_Spec := First (Aspect_Specifications (Decl_Node));
+ while Present (Aspect_Spec) loop
+ Set_Analyzed (Aspect_Spec, False);
+ Next (Aspect_Spec);
+ end loop;
+
+ Append_To (Assoc_List, Decl_Node);
+
+ -- Create corresponding body, and append it to association list
+ -- that appears at the head of the declarations in the instance.
+ -- The subprogram may be called in the analysis of subsequent
+ -- actuals.
+
+ Append_To (Assoc_List,
+ Build_Subprogram_Body_Wrapper (Formal, Actual_Name));
+ end Build_Subprogram_Wrappers;
+
----------------------------------------
-- Check_Overloaded_Formal_Subprogram --
----------------------------------------
@@ -1481,9 +1573,9 @@ package body Sem_Ch12 is
(Defining_Unit_Name (Specification (Analyzed_Formal)));
when N_Formal_Package_Declaration =>
- exit when Nkind_In (Kind, N_Formal_Package_Declaration,
- N_Generic_Package_Declaration,
- N_Package_Declaration);
+ exit when Kind in N_Formal_Package_Declaration
+ | N_Generic_Package_Declaration
+ | N_Package_Declaration;
when N_Use_Package_Clause
| N_Use_Type_Clause
@@ -1497,10 +1589,10 @@ package body Sem_Ch12 is
exit when
Kind not in N_Formal_Subprogram_Declaration
- and then not Nkind_In (Kind, N_Subprogram_Declaration,
- N_Freeze_Entity,
- N_Null_Statement,
- N_Itype_Reference)
+ and then Kind not in N_Subprogram_Declaration
+ | N_Freeze_Entity
+ | N_Null_Statement
+ | N_Itype_Reference
and then Chars (Defining_Identifier (Formal)) =
Chars (Defining_Identifier (Analyzed_Formal));
end case;
@@ -1626,7 +1718,7 @@ package body Sem_Ch12 is
Assoc_List);
-- For a defaulted in_parameter, create an entry in the
- -- the list of defaulted actuals, for GNATProve use. Do
+ -- the list of defaulted actuals, for GNATprove use. Do
-- not included these defaults for an instance nested
-- within a generic, because the defaults are also used
-- in the analysis of the enclosing generic, and only
@@ -1685,7 +1777,7 @@ package body Sem_Ch12 is
-- Warn when an actual is a fixed-point with user-
-- defined promitives. The warning is superfluous
- -- if the fornal is private, because there can be
+ -- if the formal is private, because there can be
-- no arithmetic operations in the generic so there
-- no danger of confusion.
@@ -1793,6 +1885,16 @@ package body Sem_Ch12 is
Instantiate_Formal_Subprogram
(Formal, Match, Analyzed_Formal));
+ -- If formal subprogram has contracts, create wrappers
+ -- for it. This is an expansion activity that cannot
+ -- take place e.g. within an enclosing generic unit.
+
+ if Has_Contracts (Analyzed_Formal)
+ and then Expander_Active
+ then
+ Build_Subprogram_Wrappers;
+ end if;
+
-- An instantiation is a freeze point for the actuals,
-- unless this is a rewritten formal package.
@@ -1826,7 +1928,7 @@ package body Sem_Ch12 is
end if;
-- If this is a nested generic, preserve default for later
- -- instantiations. We do this as well for GNATProve use,
+ -- instantiations. We do this as well for GNATprove use,
-- so that the list of generic associations is complete.
if No (Match) and then Box_Present (Formal) then
@@ -1846,10 +1948,19 @@ package body Sem_Ch12 is
end if;
when N_Formal_Package_Declaration =>
- Match :=
- Matching_Actual
- (Defining_Identifier (Formal),
- Defining_Identifier (Original_Node (Analyzed_Formal)));
+ -- The name of the formal package may be hidden by the
+ -- formal parameter itself.
+
+ if Error_Posted (Analyzed_Formal) then
+ Abandon_Instantiation (Instantiation_Node);
+
+ else
+ Match :=
+ Matching_Actual
+ (Defining_Identifier (Formal),
+ Defining_Identifier
+ (Original_Node (Analyzed_Formal)));
+ end if;
if No (Match) then
if Partial_Parameterization then
@@ -1992,10 +2103,10 @@ package body Sem_Ch12 is
S := Current_Scope;
while Present (S) loop
- if Ekind_In (S, E_Block,
- E_Function,
- E_Loop,
- E_Procedure)
+ if Ekind (S) in E_Block
+ | E_Function
+ | E_Loop
+ | E_Procedure
then
Needs_Freezing := False;
exit;
@@ -2139,9 +2250,9 @@ package body Sem_Ch12 is
if Nkind (Def) = N_Constrained_Array_Definition then
DSS := First (Discrete_Subtype_Definitions (Def));
while Present (DSS) loop
- if Nkind_In (DSS, N_Subtype_Indication,
- N_Range,
- N_Attribute_Reference)
+ if Nkind (DSS) in N_Subtype_Indication
+ | N_Range
+ | N_Attribute_Reference
then
Error_Msg_N ("only a subtype mark is allowed in a formal", DSS);
end if;
@@ -3048,8 +3159,7 @@ package body Sem_Ch12 is
Set_Has_Completion (Formal, True);
- -- Add semantic information to the original defining identifier for ASIS
- -- use.
+ -- Add semantic information to the original defining identifier.
Set_Ekind (Pack_Id, E_Package);
Set_Etype (Pack_Id, Standard_Void_Type);
@@ -3476,6 +3586,12 @@ package body Sem_Ch12 is
end loop;
Generate_Reference_To_Generic_Formals (Current_Scope);
+
+ -- For Ada 2020, some formal parameters can carry aspects, which must
+ -- be name-resolved at the end of the list of formal parameters (which
+ -- has the semantics of a declaration list).
+
+ Analyze_Contracts (Generic_Formal_Declarations (N));
end Analyze_Generic_Formal_Part;
------------------------------------------
@@ -3493,8 +3609,6 @@ package body Sem_Ch12 is
Save_Parent : Node_Id;
begin
- Check_SPARK_05_Restriction ("generic is not allowed", N);
-
-- A generic may grant access to its private enclosing context depending
-- on the placement of its corresponding body. From elaboration point of
-- view, the flow of execution may enter this private context, and then
@@ -3699,8 +3813,6 @@ package body Sem_Ch12 is
Typ : Entity_Id;
begin
- Check_SPARK_05_Restriction ("generic is not allowed", N);
-
-- A generic may grant access to its private enclosing context depending
-- on the placement of its corresponding body. From elaboration point of
-- view, the flow of execution may enter this private context, and then
@@ -3748,13 +3860,6 @@ package body Sem_Ch12 is
Enter_Name (Id);
Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1);
- -- Analyze the aspects of the generic copy to ensure that all generated
- -- pragmas (if any) perform their semantic effects.
-
- if Has_Aspects (N) then
- Analyze_Aspect_Specifications (N, Id);
- end if;
-
Push_Scope (Id);
Enter_Generic_Scope (Id);
Set_Inner_Instances (Id, New_Elmt_List);
@@ -3839,6 +3944,13 @@ package body Sem_Ch12 is
Set_Etype (Id, Standard_Void_Type);
end if;
+ -- Analyze the aspects of the generic copy to ensure that all generated
+ -- pragmas (if any) perform their semantic effects.
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
+
-- For a library unit, we have reconstructed the entity for the unit,
-- and must reset it in the library tables. We also make sure that
-- Body_Required is set properly in the original compilation unit node.
@@ -4032,8 +4144,6 @@ package body Sem_Ch12 is
Modes => True,
Warnings => True);
- Check_SPARK_05_Restriction ("generic is not allowed", N);
-
-- Very first thing: check for Text_IO special unit in case we are
-- instantiating one of the children of [[Wide_]Wide_]Text_IO.
@@ -4348,8 +4458,7 @@ package body Sem_Ch12 is
-- body if there is one and it needs to be instantiated here.
-- We instantiate the body only if we are generating code, or if we
- -- are generating cross-reference information, or if we are building
- -- trees for ASIS use or GNATprove use.
+ -- are generating cross-reference information, or for GNATprove use.
declare
Enclosing_Body_Present : Boolean := False;
@@ -4446,7 +4555,7 @@ package body Sem_Ch12 is
and then not Inline_Now
and then (Operating_Mode = Generate_Code
or else (Operating_Mode = Check_Semantics
- and then (ASIS_Mode or GNATprove_Mode)));
+ and then GNATprove_Mode));
-- If front-end inlining is enabled or there are any subprograms
-- marked with Inline_Always, do not instantiate body when within
@@ -4781,17 +4890,6 @@ package body Sem_Ch12 is
Inline_Instance_Body (N, Gen_Unit, Act_Decl);
end if;
- -- The following is a tree patch for ASIS: ASIS needs separate nodes to
- -- be used as defining identifiers for a formal package and for the
- -- corresponding expanded package.
-
- if Nkind (N) = N_Formal_Package_Declaration then
- Act_Decl_Id := New_Copy (Defining_Entity (N));
- Set_Comes_From_Source (Act_Decl_Id, True);
- Set_Is_Generic_Instance (Act_Decl_Id, False);
- Set_Defining_Identifier (N, Act_Decl_Id);
- end if;
-
-- Check that if N is an instantiation of System.Dim_Float_IO or
-- System.Dim_Integer_IO, the formal type has a dimension system.
@@ -4934,7 +5032,7 @@ package body Sem_Ch12 is
while Present (S) and then S /= Standard_Standard loop
if Is_Generic_Instance (S)
and then (In_Package_Body (S)
- or else Ekind_In (S, E_Procedure, E_Function))
+ or else Ekind (S) in E_Procedure | E_Function)
then
-- We still have to remove the entities of the enclosing
-- instance from direct visibility.
@@ -5103,7 +5201,7 @@ package body Sem_Ch12 is
Set_Is_Generic_Instance (Inst, True);
if In_Package_Body (Inst)
- or else Ekind_In (S, E_Procedure, E_Function)
+ or else Ekind (S) in E_Procedure | E_Function
then
E := First_Entity (Instances (J));
while Present (E) loop
@@ -5185,17 +5283,17 @@ package body Sem_Ch12 is
if (Is_In_Main_Unit (N) or else Is_Inlined_Or_Child_Of_Inlined (Subp))
- -- Must be generating code or analyzing code in ASIS/GNATprove mode
+ -- Must be generating code or analyzing code in GNATprove mode
and then (Operating_Mode = Generate_Code
or else (Operating_Mode = Check_Semantics
- and then (ASIS_Mode or GNATprove_Mode)))
+ and then GNATprove_Mode))
- -- The body is needed when generating code (full expansion), in ASIS
- -- mode for other tools, and in GNATprove mode (special expansion) for
- -- formal verification of the body itself.
+ -- The body is needed when generating code (full expansion) and in
+ -- in GNATprove mode (special expansion) for formal verification of
+ -- the body itself.
- and then (Expander_Active or ASIS_Mode or GNATprove_Mode)
+ and then (Expander_Active or GNATprove_Mode)
-- No point in inlining if ABE is inevitable
@@ -5367,7 +5465,7 @@ package body Sem_Ch12 is
-- Subprogram instance comes from source only if generic does
- Set_Comes_From_Source (Act_Decl_Id, Comes_From_Source (Gen_Unit));
+ Preserve_Comes_From_Source (Act_Decl_Id, Gen_Unit);
-- If the instance is a child unit, mark the Id accordingly. Mark
-- the anonymous entity as well, which is the real subprogram and
@@ -5491,8 +5589,6 @@ package body Sem_Ch12 is
Modes => True,
Warnings => True);
- Check_SPARK_05_Restriction ("generic is not allowed", N);
-
-- Very first thing: check for special Text_IO unit in case we are
-- instantiating one of the children of [[Wide_]Wide_]Text_IO. Of course
-- such an instantiation is bogus (these are packages, not subprograms),
@@ -5568,8 +5664,7 @@ package body Sem_Ch12 is
-- If renaming, get original unit
if Present (Renamed_Object (Gen_Unit))
- and then Ekind_In (Renamed_Object (Gen_Unit), E_Generic_Procedure,
- E_Generic_Function)
+ and then Is_Generic_Subprogram (Renamed_Object (Gen_Unit))
then
Gen_Unit := Renamed_Object (Gen_Unit);
Set_Is_Instantiated (Gen_Unit);
@@ -5814,8 +5909,7 @@ package body Sem_Ch12 is
-- constitute a freeze point, but to insure that the freeze node
-- is placed properly, it is created directly when instantiating
-- the body (otherwise the freeze node might appear to early for
- -- nested instantiations). For ASIS purposes, indicate that the
- -- wrapper package has replaced the instantiation node.
+ -- nested instantiations).
elsif Nkind (Parent (N)) = N_Compilation_Unit then
Rewrite (N, Unit (Parent (N)));
@@ -5823,7 +5917,7 @@ package body Sem_Ch12 is
end if;
-- Replace instance node for library-level instantiations of
- -- intrinsic subprograms, for ASIS use.
+ -- intrinsic subprograms.
elsif Nkind (Parent (N)) = N_Compilation_Unit then
Rewrite (N, Unit (Parent (N)));
@@ -5880,7 +5974,7 @@ package body Sem_Ch12 is
if Nkind (Assoc) /= Nkind (N) then
return Assoc;
- elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then
+ elsif Nkind (Assoc) in N_Aggregate | N_Extension_Aggregate then
return Assoc;
else
@@ -5900,11 +5994,11 @@ package body Sem_Ch12 is
if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op)
and then Present (Associated_Node (Assoc))
- and then (Nkind_In (Associated_Node (Assoc), N_Function_Call,
- N_Explicit_Dereference,
- N_Integer_Literal,
- N_Real_Literal,
- N_String_Literal))
+ and then Nkind (Associated_Node (Assoc)) in N_Function_Call
+ | N_Explicit_Dereference
+ | N_Integer_Literal
+ | N_Real_Literal
+ | N_String_Literal
then
Assoc := Associated_Node (Assoc);
end if;
@@ -6129,6 +6223,117 @@ package body Sem_Ch12 is
return Decl;
end Build_Operator_Wrapper;
+ -----------------------------------
+ -- Build_Subprogram_Decl_Wrapper --
+ -----------------------------------
+
+ function Build_Subprogram_Decl_Wrapper
+ (Formal_Subp : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Current_Scope);
+ Ret_Type : constant Entity_Id := Get_Instance_Of (Etype (Formal_Subp));
+ Decl : Node_Id;
+ Subp : Entity_Id;
+ Parm_Spec : Node_Id;
+ Profile : List_Id := New_List;
+ Spec : Node_Id;
+ Form_F : Entity_Id;
+ New_F : Entity_Id;
+
+ begin
+
+ Subp := Make_Defining_Identifier (Loc, Chars (Formal_Subp));
+ Set_Ekind (Subp, Ekind (Formal_Subp));
+ Set_Is_Generic_Actual_Subprogram (Subp);
+
+ Profile := Parameter_Specifications (
+ New_Copy_Tree
+ (Specification (Unit_Declaration_Node (Formal_Subp))));
+
+ Form_F := First_Formal (Formal_Subp);
+ Parm_Spec := First (Profile);
+
+ -- Create new entities for the formals. Reset entities so that
+ -- parameter types are properly resolved when wrapper declaration
+ -- is analyzed.
+
+ while Present (Parm_Spec) loop
+ New_F := Make_Defining_Identifier (Loc, Chars (Form_F));
+ Set_Defining_Identifier (Parm_Spec, New_F);
+ Set_Entity (Parameter_Type (Parm_Spec), Empty);
+ Next (Parm_Spec);
+ Next_Formal (Form_F);
+ end loop;
+
+ if Ret_Type = Standard_Void_Type then
+ Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Subp,
+ Parameter_Specifications => Profile);
+ else
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Subp,
+ Parameter_Specifications => Profile,
+ Result_Definition => New_Occurrence_Of (Ret_Type, Loc));
+ end if;
+
+ Decl :=
+ Make_Subprogram_Declaration (Loc, Specification => Spec);
+
+ return Decl;
+ end Build_Subprogram_Decl_Wrapper;
+
+ -----------------------------------
+ -- Build_Subprogram_Body_Wrapper --
+ -----------------------------------
+
+ function Build_Subprogram_Body_Wrapper
+ (Formal_Subp : Entity_Id;
+ Actual_Name : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Current_Scope);
+ Ret_Type : constant Entity_Id := Get_Instance_Of (Etype (Formal_Subp));
+ Spec_Node : constant Node_Id :=
+ Specification
+ (Build_Subprogram_Decl_Wrapper (Formal_Subp));
+ Act : Node_Id;
+ Actuals : List_Id;
+ Body_Node : Node_Id;
+ Stmt : Node_Id;
+ begin
+ Actuals := New_List;
+ Act := First (Parameter_Specifications (Spec_Node));
+
+ while Present (Act) loop
+ Append_To (Actuals,
+ Make_Identifier (Loc, Chars (Defining_Identifier (Act))));
+ Next (Act);
+ end loop;
+
+ if Ret_Type = Standard_Void_Type then
+ Stmt := Make_Procedure_Call_Statement (Loc,
+ Name => Actual_Name,
+ Parameter_Associations => Actuals);
+
+ else
+ Stmt := Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => Actual_Name,
+ Parameter_Associations => Actuals));
+ end if;
+
+ Body_Node := Make_Subprogram_Body (Loc,
+ Specification => Spec_Node,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Stmt)));
+
+ return Body_Node;
+ end Build_Subprogram_Body_Wrapper;
+
-------------------------------------------
-- Build_Instance_Compilation_Unit_Nodes --
-------------------------------------------
@@ -6301,9 +6506,9 @@ package body Sem_Ch12 is
if Kind = N_Formal_Type_Declaration then
return;
- elsif Nkind_In (Kind, N_Formal_Object_Declaration,
- N_Formal_Package_Declaration)
- or else Kind in N_Formal_Subprogram_Declaration
+ elsif Kind in N_Formal_Object_Declaration
+ | N_Formal_Package_Declaration
+ | N_Formal_Subprogram_Declaration
then
null;
@@ -6496,9 +6701,8 @@ package body Sem_Ch12 is
-- If the formal entity comes from a formal declaration, it was
-- defaulted in the formal package, and no check is needed on it.
- elsif Nkind_In (Original_Node (Parent (E2)),
- N_Formal_Object_Declaration,
- N_Formal_Type_Declaration)
+ elsif Nkind (Original_Node (Parent (E2))) in
+ N_Formal_Object_Declaration | N_Formal_Type_Declaration
then
-- If the formal is a tagged type the corresponding class-wide
-- type has been generated as well, and it must be skipped.
@@ -6808,48 +7012,6 @@ package body Sem_Ch12 is
E : Entity_Id;
Astype : Entity_Id;
- function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean;
- -- For a formal that is an array type, the component type is often a
- -- previous formal in the same unit. The privacy status of the component
- -- type will have been examined earlier in the traversal of the
- -- corresponding actuals, and this status should not be modified for
- -- the array (sub)type itself. However, if the base type of the array
- -- (sub)type is private, its full view must be restored in the body to
- -- be consistent with subsequent index subtypes, etc.
- --
- -- To detect this case we have to rescan the list of formals, which is
- -- usually short enough to ignore the resulting inefficiency.
-
- -----------------------------
- -- Denotes_Previous_Actual --
- -----------------------------
-
- function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is
- Prev : Entity_Id;
-
- begin
- Prev := First_Entity (Instance);
- while Present (Prev) loop
- if Is_Type (Prev)
- and then Nkind (Parent (Prev)) = N_Subtype_Declaration
- and then Is_Entity_Name (Subtype_Indication (Parent (Prev)))
- and then Entity (Subtype_Indication (Parent (Prev))) = Typ
- then
- return True;
-
- elsif Prev = E then
- return False;
-
- else
- Next_Entity (Prev);
- end if;
- end loop;
-
- return False;
- end Denotes_Previous_Actual;
-
- -- Start of processing for Check_Generic_Actuals
-
begin
E := First_Entity (Instance);
while Present (E) loop
@@ -6858,14 +7020,34 @@ package body Sem_Ch12 is
and then Scope (Etype (E)) /= Instance
and then Is_Entity_Name (Subtype_Indication (Parent (E)))
then
- if Is_Array_Type (E)
- and then not Is_Private_Type (Etype (E))
- and then Denotes_Previous_Actual (Component_Type (E))
- then
- null;
- else
- Check_Private_View (Subtype_Indication (Parent (E)));
- end if;
+ -- Restore the proper view of the actual from the information
+ -- saved earlier by Instantiate_Type.
+
+ Check_Private_View (Subtype_Indication (Parent (E)));
+
+ -- If the actual is itself the formal of a parent instance,
+ -- then also restore the proper view of its actual and so on.
+ -- That's necessary for nested instantiations of the form
+
+ -- generic
+ -- type Component is private;
+ -- type Array_Type is array (Positive range <>) of Component;
+ -- procedure Proc;
+
+ -- when the outermost actuals have inconsistent views, because
+ -- the Component_Type of Array_Type of the inner instantiations
+ -- is the actual of Component of the outermost one and not that
+ -- of the corresponding inner instantiations.
+
+ Astype := Ancestor_Subtype (E);
+ while Present (Astype)
+ and then Nkind (Parent (Astype)) = N_Subtype_Declaration
+ and then Present (Generic_Parent_Type (Parent (Astype)))
+ and then Is_Entity_Name (Subtype_Indication (Parent (Astype)))
+ loop
+ Check_Private_View (Subtype_Indication (Parent (Astype)));
+ Astype := Ancestor_Subtype (Astype);
+ end loop;
Set_Is_Generic_Actual_Type (E);
@@ -6900,15 +7082,6 @@ package body Sem_Ch12 is
if Is_Discrete_Or_Fixed_Point_Type (E) then
Set_RM_Size (E, RM_Size (Astype));
-
- -- In nested instances, the base type of an access actual may
- -- itself be private, and need to be exchanged.
-
- elsif Is_Access_Type (E)
- and then Is_Private_Type (Etype (E))
- then
- Check_Private_View
- (New_Occurrence_Of (Etype (E), Sloc (Instance)));
end if;
elsif Ekind (E) = E_Package then
@@ -7445,92 +7618,25 @@ package body Sem_Ch12 is
and then Present (Full_View (T))
and then not In_Open_Scopes (Scope (T))
then
- -- In the generic, the full type was visible. Save the private
- -- entity, for subsequent exchange.
+ -- In the generic, the full declaration was visible
Switch_View (T);
elsif Has_Private_View (N)
and then not Is_Private_Type (T)
and then not Has_Been_Exchanged (T)
- and then Etype (Get_Associated_Node (N)) /= T
+ and then (not In_Open_Scopes (Scope (T))
+ or else Nkind (Parent (N)) = N_Subtype_Declaration)
then
- -- Only the private declaration was visible in the generic. If
- -- the type appears in a subtype declaration, the subtype in the
+ -- In the generic, only the private declaration was visible
+
+ -- If the type appears in a subtype declaration, the subtype in
-- instance must have a view compatible with that of its parent,
-- which must be exchanged (see corresponding code in Restore_
- -- Private_Views). Otherwise, if the type is defined in a parent
- -- unit, leave full visibility within instance, which is safe.
-
- if In_Open_Scopes (Scope (Base_Type (T)))
- and then not Is_Private_Type (Base_Type (T))
- and then Comes_From_Source (Base_Type (T))
- then
- null;
-
- elsif Nkind (Parent (N)) = N_Subtype_Declaration
- or else not In_Private_Part (Scope (Base_Type (T)))
- then
- Prepend_Elmt (T, Exchanged_Views);
- Exchange_Declarations (Etype (Get_Associated_Node (N)));
- end if;
-
- -- For composite types with inconsistent representation exchange
- -- component types accordingly.
-
- elsif Is_Access_Type (T)
- and then Is_Private_Type (Designated_Type (T))
- and then not Has_Private_View (N)
- and then Present (Full_View (Designated_Type (T)))
- then
- Switch_View (Designated_Type (T));
-
- elsif Is_Array_Type (T) then
- if Is_Private_Type (Component_Type (T))
- and then not Has_Private_View (N)
- and then Present (Full_View (Component_Type (T)))
- then
- Switch_View (Component_Type (T));
- end if;
-
- -- The normal exchange mechanism relies on the setting of a
- -- flag on the reference in the generic. However, an additional
- -- mechanism is needed for types that are not explicitly
- -- mentioned in the generic, but may be needed in expanded code
- -- in the instance. This includes component types of arrays and
- -- designated types of access types. This processing must also
- -- include the index types of arrays which we take care of here.
-
- declare
- Indx : Node_Id;
- Typ : Entity_Id;
-
- begin
- Indx := First_Index (T);
- while Present (Indx) loop
- Typ := Base_Type (Etype (Indx));
-
- if Is_Private_Type (Typ)
- and then Present (Full_View (Typ))
- then
- Switch_View (Typ);
- end if;
+ -- Private_Views) so we make an exception to the open scope rule.
- Next_Index (Indx);
- end loop;
- end;
-
- -- The following case does not test Has_Private_View (N) so it may
- -- end up switching views when they are not supposed to be switched.
- -- This might be in keeping with Set_Global_Type setting the flag
- -- for an array type even if it is not private ???
-
- elsif Is_Private_Type (T)
- and then Present (Full_View (T))
- and then Is_Array_Type (Full_View (T))
- and then Is_Private_Type (Component_Type (Full_View (T)))
- then
- Switch_View (T);
+ Prepend_Elmt (T, Exchanged_Views);
+ Exchange_Declarations (Etype (Get_Associated_Node (N)));
-- Finally, a non-private subtype may have a private base type, which
-- must be exchanged for consistency. This can happen when a package
@@ -7701,9 +7807,8 @@ package body Sem_Ch12 is
function In_Defining_Unit_Name (Nam : Node_Id) return Boolean;
-- True if an identifier is part of the defining program unit name of
- -- a child unit. The entity of such an identifier must be kept (for
- -- ASIS use) even though as the name of an enclosing generic it would
- -- otherwise not be preserved in the generic tree.
+ -- a child unit.
+ -- Consider removing this subprogram now that ASIS no longer uses it.
----------------------
-- Copy_Descendants --
@@ -7852,11 +7957,11 @@ package body Sem_Ch12 is
-- Special casing for identifiers and other entity names and operators
- if Nkind_In (New_N, N_Character_Literal,
- N_Expanded_Name,
- N_Identifier,
- N_Operator_Symbol)
- or else Nkind (New_N) in N_Op
+ if Nkind (New_N) in N_Character_Literal
+ | N_Expanded_Name
+ | N_Identifier
+ | N_Operator_Symbol
+ | N_Op
then
if not Instantiating then
@@ -7887,7 +7992,7 @@ package body Sem_Ch12 is
-- The entities for parent units in the defining_program_unit of a
-- generic child unit are established when the context of the unit
-- is first analyzed, before the generic copy is made. They are
- -- preserved in the copy for use in ASIS queries.
+ -- preserved in the copy for use in e.g. ASIS queries.
Ent := Entity (New_N);
@@ -7900,10 +8005,9 @@ package body Sem_Ch12 is
end if;
elsif No (Ent)
- or else
- not Nkind_In (Ent, N_Defining_Identifier,
- N_Defining_Character_Literal,
- N_Defining_Operator_Symbol)
+ or else Nkind (Ent) not in N_Defining_Identifier
+ | N_Defining_Character_Literal
+ | N_Defining_Operator_Symbol
or else No (Scope (Ent))
or else
(Scope (Ent) = Current_Instantiated_Parent.Gen_Id
@@ -7936,6 +8040,117 @@ package body Sem_Ch12 is
Set_Entity (New_N, Entity (Assoc));
Check_Private_View (N);
+ -- Here we deal with a very peculiar case for which the
+ -- Has_Private_View mechanism is not sufficient, because
+ -- the reference to the type is implicit in the tree,
+ -- that is to say, it's not referenced from a node but
+ -- only from another type, namely through Component_Type.
+
+ -- package P is
+
+ -- type Pt is private;
+
+ -- generic
+ -- type Ft is array (Positive range <>) of Pt;
+ -- package G is
+ -- procedure Check (F1, F2 : Ft; Lt : Boolean);
+ -- end G;
+
+ -- private
+ -- type Pt is new Boolean;
+ -- end P;
+
+ -- package body P is
+ -- package body G is
+ -- procedure Check (F1, F2 : Ft; Lt : Boolean) is
+ -- begin
+ -- if (F1 < F2) /= Lt then
+ -- null;
+ -- end if;
+ -- end Check;
+ -- end G;
+ -- end P;
+
+ -- type Arr is array (Positive range <>) of P.Pt;
+
+ -- package Inst is new P.G (Arr);
+
+ -- Pt is a global type for the generic package G and it
+ -- is not referenced in its body, but only as component
+ -- type of Ft, which is a local type. This means that no
+ -- references to Pt or Ft are seen during the copy of the
+ -- body, the only reference to Pt being seen is when the
+ -- actuals are checked by Check_Generic_Actuals, but Pt
+ -- is still private at this point. In the end, the views
+ -- of Pt are not switched in the body and, therefore, the
+ -- array comparison is rejected because the component is
+ -- still private.
+
+ -- Adding e.g. a dummy variable of type Pt in the body is
+ -- sufficient to make everything work, so we generate an
+ -- artificial reference to Pt on the fly and thus force
+ -- the switching of views on the grounds that, if the
+ -- comparison was accepted during the semantic analysis
+ -- of the generic, this means that the component cannot
+ -- have been private (see Sem_Type.Valid_Comparison_Arg).
+
+ if Nkind (Assoc) in N_Op_Compare
+ and then Present (Etype (Left_Opnd (Assoc)))
+ and then Is_Array_Type (Etype (Left_Opnd (Assoc)))
+ and then Present (Etype (Right_Opnd (Assoc)))
+ and then Is_Array_Type (Etype (Right_Opnd (Assoc)))
+ then
+ declare
+ Ltyp : constant Entity_Id :=
+ Etype (Left_Opnd (Assoc));
+ Rtyp : constant Entity_Id :=
+ Etype (Right_Opnd (Assoc));
+ begin
+ if Is_Private_Type (Component_Type (Ltyp)) then
+ Check_Private_View
+ (New_Occurrence_Of (Component_Type (Ltyp),
+ Sloc (N)));
+ end if;
+ if Is_Private_Type (Component_Type (Rtyp)) then
+ Check_Private_View
+ (New_Occurrence_Of (Component_Type (Rtyp),
+ Sloc (N)));
+ end if;
+ end;
+
+ -- Here is a similar case, for the Designated_Type of an
+ -- access type that is present as target type in a type
+ -- conversion from another access type. In this case, if
+ -- the base types of the designated types are different
+ -- and the conversion was accepted during the semantic
+ -- analysis of the generic, this means that the target
+ -- type cannot have been private (see Valid_Conversion).
+
+ elsif Nkind (Assoc) = N_Identifier
+ and then Nkind (Parent (Assoc)) = N_Type_Conversion
+ and then Subtype_Mark (Parent (Assoc)) = Assoc
+ and then Present (Etype (Assoc))
+ and then Is_Access_Type (Etype (Assoc))
+ and then Present (Etype (Expression (Parent (Assoc))))
+ and then
+ Is_Access_Type (Etype (Expression (Parent (Assoc))))
+ then
+ declare
+ Targ_Desig : constant Entity_Id :=
+ Designated_Type (Etype (Assoc));
+ Expr_Desig : constant Entity_Id :=
+ Designated_Type
+ (Etype (Expression (Parent (Assoc))));
+ begin
+ if Base_Type (Targ_Desig) /= Base_Type (Expr_Desig)
+ and then Is_Private_Type (Targ_Desig)
+ then
+ Check_Private_View
+ (New_Occurrence_Of (Targ_Desig, Sloc (N)));
+ end if;
+ end;
+ end if;
+
-- The node is a reference to a global type and acts as the
-- subtype mark of a qualified expression created in order
-- to aid resolution of accidental overloading in instances.
@@ -7959,9 +8174,9 @@ package body Sem_Ch12 is
then
Set_Entity (New_N, Entity (Name (Assoc)));
- elsif Nkind_In (Assoc, N_Defining_Identifier,
- N_Defining_Character_Literal,
- N_Defining_Operator_Symbol)
+ elsif Nkind (Assoc) in N_Defining_Identifier
+ | N_Defining_Character_Literal
+ | N_Defining_Operator_Symbol
and then Expander_Active
then
-- Inlining case: we are copying a tree that contains
@@ -8170,7 +8385,7 @@ package body Sem_Ch12 is
Set_Assignment_OK (Name (New_N), True);
end if;
- elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
+ elsif Nkind (N) in N_Aggregate | N_Extension_Aggregate then
if not Instantiating then
Set_Associated_Node (N, New_N);
@@ -8290,7 +8505,7 @@ package body Sem_Ch12 is
-- Do not copy Comment or Ident pragmas their content is relevant to
-- the generic unit, not to the instantiating unit.
- if Nam_In (Pragma_Name_Unmapped (N), Name_Comment, Name_Ident) then
+ if Pragma_Name_Unmapped (N) in Name_Comment | Name_Ident then
New_N := Make_Null_Statement (Sloc (N));
-- Do not copy pragmas generated from aspects because the pragmas do
@@ -8310,7 +8525,7 @@ package body Sem_Ch12 is
Copy_Descendants;
end if;
- elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then
+ elsif Nkind (N) in N_Integer_Literal | N_Real_Literal then
-- No descendant fields need traversing
@@ -9009,10 +9224,10 @@ package body Sem_Ch12 is
else
Inst := Next (Decl);
- while not Nkind_In (Inst, N_Formal_Package_Declaration,
- N_Function_Instantiation,
- N_Package_Instantiation,
- N_Procedure_Instantiation)
+ while Nkind (Inst) not in N_Formal_Package_Declaration
+ | N_Function_Instantiation
+ | N_Package_Instantiation
+ | N_Procedure_Instantiation
loop
Next (Inst);
end loop;
@@ -9041,6 +9256,32 @@ package body Sem_Ch12 is
return False;
end Has_Been_Exchanged;
+ -------------------
+ -- Has_Contracts --
+ -------------------
+
+ function Has_Contracts (Decl : Node_Id) return Boolean is
+ A_List : constant List_Id := Aspect_Specifications (Decl);
+ A_Spec : Node_Id;
+ A_Id : Aspect_Id;
+ begin
+ if No (A_List) then
+ return False;
+ else
+ A_Spec := First (A_List);
+ while Present (A_Spec) loop
+ A_Id := Get_Aspect_Id (A_Spec);
+ if A_Id = Aspect_Pre or else A_Id = Aspect_Post then
+ return True;
+ end if;
+
+ Next (A_Spec);
+ end loop;
+
+ return False;
+ end if;
+ end Has_Contracts;
+
----------
-- Hash --
----------
@@ -9279,7 +9520,7 @@ package body Sem_Ch12 is
while Present (P)
and then Nkind (Parent (P)) /= N_Compilation_Unit
loop
- if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then
+ if Nkind (P) in N_Package_Body | N_Subprogram_Body then
if Nkind (Parent (P)) = N_Subunit then
return Corresponding_Stub (Parent (P));
else
@@ -9377,8 +9618,8 @@ package body Sem_Ch12 is
-- the current scope as well.
elsif Present (Next (N))
- and then Nkind_In (Next (N), N_Subprogram_Body,
- N_Package_Body)
+ and then Nkind (Next (N)) in N_Subprogram_Body
+ | N_Package_Body
and then Comes_From_Source (Next (N))
then
null;
@@ -9592,8 +9833,8 @@ package body Sem_Ch12 is
Must_Delay :=
(Gen_Unit = Act_Unit
- and then (Nkind_In (Gen_Unit, N_Generic_Package_Declaration,
- N_Package_Declaration)
+ and then (Nkind (Gen_Unit) in N_Generic_Package_Declaration
+ | N_Package_Declaration
or else (Gen_Unit = Body_Unit
and then True_Sloc (N, Act_Unit) <
Sloc (Orig_Body)))
@@ -9664,7 +9905,7 @@ package body Sem_Ch12 is
-- Freeze package enclosing instance of inner generic after
-- instance of enclosing generic.
- elsif Nkind_In (Parent (N), N_Package_Body, N_Subprogram_Body)
+ elsif Nkind (Parent (N)) in N_Package_Body | N_Subprogram_Body
and then In_Same_Declarative_Part
(Parent (Freeze_Node (Par)), Parent (N))
then
@@ -10168,7 +10409,9 @@ package body Sem_Ch12 is
=>
Formal_Ent := Defining_Identifier (F);
- while Chars (Act) /= Chars (Formal_Ent) loop
+ while Present (Act)
+ and then Chars (Act) /= Chars (Formal_Ent)
+ loop
Next_Entity (Act);
end loop;
@@ -10179,7 +10422,9 @@ package body Sem_Ch12 is
=>
Formal_Ent := Defining_Entity (F);
- while Chars (Act) /= Chars (Formal_Ent) loop
+ while Present (Act)
+ and then Chars (Act) /= Chars (Formal_Ent)
+ loop
Next_Entity (Act);
end loop;
@@ -10364,7 +10609,7 @@ package body Sem_Ch12 is
-- such as a parent generic within the body of a generic child.
if not Is_Entity_Name (Actual)
- or else not Ekind_In (Entity (Actual), E_Generic_Package, E_Package)
+ or else not Is_Package_Or_Generic_Package (Entity (Actual))
then
Error_Msg_N
("expect package instance to instantiate formal", Actual);
@@ -10663,10 +10908,10 @@ package body Sem_Ch12 is
end if;
if (Present (Act_E) and then Is_Overloadable (Act_E))
- or else Nkind_In (Act, N_Attribute_Reference,
- N_Indexed_Component,
- N_Character_Literal,
- N_Explicit_Dereference)
+ or else Nkind (Act) in N_Attribute_Reference
+ | N_Indexed_Component
+ | N_Character_Literal
+ | N_Explicit_Dereference
then
return;
end if;
@@ -10699,7 +10944,23 @@ package body Sem_Ch12 is
-- Create new entity for the actual (New_Copy_Tree does not), and
-- indicate that it is an actual.
- New_Subp := Make_Defining_Identifier (Loc, Chars (Formal_Sub));
+ -- If the actual is not an entity (i.e. an attribute reference)
+ -- and the formal includes aspect specifications for contracts,
+ -- we create an internal name for the renaming declaration. The
+ -- constructed wrapper contains a call to the entity in the renaming.
+ -- This is an expansion activity, as is the wrapper creation.
+
+ if Ada_Version >= Ada_2020
+ and then Has_Contracts (Analyzed_Formal)
+ and then not Is_Entity_Name (Actual)
+ and then Expander_Active
+ then
+ New_Subp := Make_Temporary (Sloc (Actual), 'S');
+ Set_Defining_Unit_Name (New_Spec, New_Subp);
+ else
+ New_Subp := Make_Defining_Identifier (Loc, Chars (Formal_Sub));
+ end if;
+
Set_Ekind (New_Subp, Ekind (Analyzed_S));
Set_Is_Generic_Actual_Subprogram (New_Subp);
Set_Defining_Unit_Name (New_Spec, New_Subp);
@@ -10749,10 +11010,10 @@ package body Sem_Ch12 is
Nam := Actual;
elsif Present (Default_Name (Formal)) then
- if not Nkind_In (Default_Name (Formal), N_Attribute_Reference,
- N_Selected_Component,
- N_Indexed_Component,
- N_Character_Literal)
+ if Nkind (Default_Name (Formal)) not in N_Attribute_Reference
+ | N_Selected_Component
+ | N_Indexed_Component
+ | N_Character_Literal
and then Present (Entity (Default_Name (Formal)))
then
Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc);
@@ -10788,7 +11049,13 @@ package body Sem_Ch12 is
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Make_Null_Statement (Loc))));
- Set_Is_Intrinsic_Subprogram (Defining_Unit_Name (New_Spec));
+ -- RM 12.6 (16 2/2): The procedure has convention Intrinsic
+
+ Set_Convention (Defining_Unit_Name (New_Spec), Convention_Intrinsic);
+
+ -- Eliminate the calls to it when optimization is enabled
+
+ Set_Is_Inlined (Defining_Unit_Name (New_Spec));
return Decl_Node;
else
@@ -10924,41 +11191,6 @@ package body Sem_Ch12 is
Subt_Decl : Node_Id := Empty;
Subt_Mark : Node_Id := Empty;
- function Copy_Access_Def return Node_Id;
- -- If formal is an anonymous access, copy access definition of formal
- -- for generated object declaration.
-
- ---------------------
- -- Copy_Access_Def --
- ---------------------
-
- function Copy_Access_Def return Node_Id is
- begin
- Def := New_Copy_Tree (Acc_Def);
-
- -- In addition, if formal is an access to subprogram we need to
- -- generate new formals for the signature of the default, so that
- -- the tree is properly formatted for ASIS use.
-
- if Present (Access_To_Subprogram_Definition (Acc_Def)) then
- declare
- Par_Spec : Node_Id;
- begin
- Par_Spec :=
- First (Parameter_Specifications
- (Access_To_Subprogram_Definition (Def)));
- while Present (Par_Spec) loop
- Set_Defining_Identifier (Par_Spec,
- Make_Defining_Identifier (Sloc (Acc_Def),
- Chars => Chars (Defining_Identifier (Par_Spec))));
- Next (Par_Spec);
- end loop;
- end;
- end if;
-
- return Def;
- end Copy_Access_Def;
-
-- Start of processing for Instantiate_Object
begin
@@ -10990,8 +11222,9 @@ package body Sem_Ch12 is
-- use the actual directly, rather than a copy, because it is not
-- used further in the list of actuals, and because a copy or a use
-- of relocate_node is incorrect if the instance is nested within a
- -- generic. In order to simplify ASIS searches, the Generic_Parent
- -- field links the declaration to the generic association.
+ -- generic. In order to simplify e.g. ASIS queries, the
+ -- Generic_Parent field links the declaration to the generic
+ -- association.
if No (Actual) then
Error_Msg_NE
@@ -11103,10 +11336,8 @@ package body Sem_Ch12 is
-- access type.
if Ada_Version < Ada_2005
- or else Ekind (Base_Type (Ftyp)) /=
- E_Anonymous_Access_Type
- or else Ekind (Base_Type (Etype (Actual))) /=
- E_Anonymous_Access_Type
+ or else not Is_Anonymous_Access_Type (Base_Type (Ftyp))
+ or else not Is_Anonymous_Access_Type (Base_Type (Etype (Actual)))
then
Error_Msg_NE
("type of actual does not match type of&", Actual, Gen_Obj);
@@ -11147,6 +11378,44 @@ package body Sem_Ch12 is
Actual);
end if;
+ -- Check actual/formal compatibility with respect to the four
+ -- volatility refinement aspects.
+
+ declare
+ Actual_Obj : Entity_Id;
+ N : Node_Id := Actual;
+ begin
+ -- Similar to Sem_Util.Get_Enclosing_Object, but treat
+ -- pointer dereference like component selection.
+ loop
+ if Is_Entity_Name (N) then
+ Actual_Obj := Entity (N);
+ exit;
+ end if;
+
+ case Nkind (N) is
+ when N_Indexed_Component
+ | N_Selected_Component
+ | N_Slice
+ | N_Explicit_Dereference
+ =>
+ N := Prefix (N);
+
+ when N_Type_Conversion =>
+ N := Expression (N);
+
+ when others =>
+ Actual_Obj := Etype (N);
+ exit;
+ end case;
+ end loop;
+
+ Check_Volatility_Compatibility
+ (Actual_Obj, A_Gen_Obj, "actual object",
+ "its corresponding formal object of mode in out",
+ Srcpos_Bearer => Actual);
+ end;
+
-- Formal in-parameter
else
@@ -11159,8 +11428,9 @@ package body Sem_Ch12 is
if Present (Actual) then
if Present (Subt_Mark) then
Def := New_Copy_Tree (Subt_Mark);
- else pragma Assert (Present (Acc_Def));
- Def := Copy_Access_Def;
+ else
+ pragma Assert (Present (Acc_Def));
+ Def := New_Copy_Tree (Acc_Def);
end if;
Decl_Node :=
@@ -11241,8 +11511,9 @@ package body Sem_Ch12 is
if Present (Subt_Mark) then
Def := New_Copy (Subt_Mark);
- else pragma Assert (Present (Acc_Def));
- Def := Copy_Access_Def;
+ else
+ pragma Assert (Present (Acc_Def));
+ Def := New_Copy_Tree (Acc_Def);
end if;
Decl_Node :=
@@ -11299,23 +11570,32 @@ package body Sem_Ch12 is
Actual_Decl := Parent (Entity (Actual));
end if;
- -- Ada 2005 (AI-423): For a formal object declaration with a null
- -- exclusion or an access definition that has a null exclusion: If the
- -- actual matching the formal object declaration denotes a generic
- -- formal object of another generic unit G, and the instantiation
- -- containing the actual occurs within the body of G or within the body
- -- of a generic unit declared within the declarative region of G, then
- -- the declaration of the formal object of G must have a null exclusion.
- -- Otherwise, the subtype of the actual matching the formal object
- -- declaration shall exclude null.
+ -- Ada 2005 (AI-423) refined by AI12-0287:
+ -- For an object_renaming_declaration with a null_exclusion or an
+ -- access_definition that has a null_exclusion, the subtype of the
+ -- object_name shall exclude null. In addition, if the
+ -- object_renaming_declaration occurs within the body of a generic unit
+ -- G or within the body of a generic unit declared within the
+ -- declarative region of generic unit G, then:
+ -- * if the object_name statically denotes a generic formal object of
+ -- mode in out of G, then the declaration of that object shall have a
+ -- null_exclusion;
+ -- * if the object_name statically denotes a call of a generic formal
+ -- function of G, then the declaration of the result of that function
+ -- shall have a null_exclusion.
if Ada_Version >= Ada_2005
and then Present (Actual_Decl)
- and then Nkind_In (Actual_Decl, N_Formal_Object_Declaration,
- N_Object_Declaration)
+ and then Nkind (Actual_Decl) in N_Formal_Object_Declaration
+ | N_Object_Declaration
and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration
and then not Has_Null_Exclusion (Actual_Decl)
and then Has_Null_Exclusion (Analyzed_Formal)
+ and then Ekind (Defining_Identifier (Analyzed_Formal))
+ = E_Generic_In_Out_Parameter
+ and then ((In_Generic_Scope (Entity (Actual))
+ and then In_Package_Body (Scope (Entity (Actual))))
+ or else not Can_Never_Be_Null (Etype (Actual)))
then
Error_Msg_Sloc := Sloc (Analyzed_Formal);
Error_Msg_N
@@ -11331,6 +11611,7 @@ package body Sem_Ch12 is
and then Present (Actual)
and then Is_Object_Reference (Actual)
and then Is_Effectively_Volatile_Object (Actual)
+ and then not Is_Effectively_Volatile (A_Gen_Obj)
then
Error_Msg_N
("volatile object cannot act as actual in generic instantiation",
@@ -11622,7 +11903,7 @@ package body Sem_Ch12 is
Act_Body_Id :=
Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id));
- Set_Comes_From_Source (Act_Body_Id, Comes_From_Source (Act_Decl_Id));
+ Preserve_Comes_From_Source (Act_Body_Id, Act_Decl_Id);
-- Some attributes of spec entity are not inherited by body entity
@@ -11746,6 +12027,19 @@ package body Sem_Ch12 is
end if;
Restore_Hidden_Primitives (Vis_Prims_List);
+
+ -- Restore the private views that were made visible when the body of
+ -- the instantiation was created. Note that, in the case where one of
+ -- these private views is declared in the parent, there is a nesting
+ -- issue with the calls to Install_Parent and Remove_Parent made in
+ -- between above with In_Body set to True, because these calls also
+ -- want to swap and restore this private view respectively. In this
+ -- case, the call to Install_Parent does nothing, but the call to
+ -- Remove_Parent does restore the private view, thus undercutting the
+ -- call to Restore_Private_Views. That's OK under the condition that
+ -- the two mechanisms swap exactly the same entities, in particular
+ -- the private entities dependent on the primary private entities.
+
Restore_Private_Views (Act_Decl_Id);
-- Remove the current unit from visibility if this is an instance
@@ -11989,7 +12283,7 @@ package body Sem_Ch12 is
Act_Body_Id :=
Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id));
- Set_Comes_From_Source (Act_Body_Id, Comes_From_Source (Act_Decl_Id));
+ Preserve_Comes_From_Source (Act_Body_Id, Act_Decl_Id);
Set_Defining_Unit_Name (Specification (Act_Body), Act_Body_Id);
Set_Corresponding_Spec (Act_Body, Act_Decl_Id);
@@ -12183,7 +12477,7 @@ package body Sem_Ch12 is
Subt : Entity_Id;
procedure Check_Shared_Variable_Control_Aspects;
- -- Ada_2020: Verify that shared variable control aspects (RM C.6)
+ -- Ada 2020: Verify that shared variable control aspects (RM C.6)
-- that may be specified for a formal type are obeyed by the actual.
procedure Diagnose_Predicated_Actual;
@@ -12214,27 +12508,40 @@ package body Sem_Ch12 is
-- Check_Shared_Variable_Control_Aspects --
--------------------------------------------
- -- Ada_2020: Verify that shared variable control aspects (RM C.6)
+ -- Ada 2020: Verify that shared variable control aspects (RM C.6)
-- that may be specified for the formal are obeyed by the actual.
+ -- If the formal is a derived type the aspect specifications must match.
+ -- NOTE: AI12-0282 implies that matching of aspects is required between
+ -- formal and actual in all cases, but this is too restrictive.
+ -- In particular it violates a language design rule: a limited private
+ -- indefinite formal can be matched by any actual. The current code
+ -- reflects an older and more permissive version of RM C.6 (12/5).
procedure Check_Shared_Variable_Control_Aspects is
begin
if Ada_Version >= Ada_2020 then
if Is_Atomic (A_Gen_T) and then not Is_Atomic (Act_T) then
Error_Msg_NE
- ("actual for& must be an atomic type", Actual, A_Gen_T);
+ ("actual for& must have Atomic aspect", Actual, A_Gen_T);
+
+ elsif Is_Derived_Type (A_Gen_T)
+ and then Is_Atomic (A_Gen_T) /= Is_Atomic (Act_T)
+ then
+ Error_Msg_NE
+ ("actual for& has different Atomic aspect", Actual, A_Gen_T);
end if;
if Is_Volatile (A_Gen_T) and then not Is_Volatile (Act_T) then
Error_Msg_NE
- ("actual for& must be a Volatile type", Actual, A_Gen_T);
- end if;
+ ("actual for& has different Volatile aspect",
+ Actual, A_Gen_T);
- if
- Is_Independent (A_Gen_T) and then not Is_Independent (Act_T)
+ elsif Is_Derived_Type (A_Gen_T)
+ and then Is_Volatile (A_Gen_T) /= Is_Volatile (Act_T)
then
Error_Msg_NE
- ("actual for& must be an Independent type", Actual, A_Gen_T);
+ ("actual for& has different Volatile aspect",
+ Actual, A_Gen_T);
end if;
-- We assume that an array type whose atomic component type
@@ -12242,44 +12549,60 @@ package body Sem_Ch12 is
-- aspect Has_Atomic_Components. This is a reasonable inference
-- from the intent of AI12-0282, and makes it legal to use an
-- actual that does not have the identical aspect as the formal.
+ -- Ditto for volatile components.
- if Has_Atomic_Components (A_Gen_T)
- and then not Has_Atomic_Components (Act_T)
- then
- if Is_Array_Type (Act_T)
- and then Is_Atomic (Component_Type (Act_T))
- then
- null;
+ declare
+ Actual_Atomic_Comp : constant Boolean :=
+ Has_Atomic_Components (Act_T)
+ or else (Is_Array_Type (Act_T)
+ and then Is_Atomic (Component_Type (Act_T)));
+ begin
+ if Has_Atomic_Components (A_Gen_T) /= Actual_Atomic_Comp then
+ Error_Msg_NE
+ ("formal and actual for& must agree on atomic components",
+ Actual, A_Gen_T);
+ end if;
+ end;
- else
+ declare
+ Actual_Volatile_Comp : constant Boolean :=
+ Has_Volatile_Components (Act_T)
+ or else (Is_Array_Type (Act_T)
+ and then Is_Volatile (Component_Type (Act_T)));
+ begin
+ if Has_Volatile_Components (A_Gen_T) /= Actual_Volatile_Comp
+ then
Error_Msg_NE
- ("actual for& must have atomic components",
+ ("actual for& must have volatile components",
Actual, A_Gen_T);
end if;
+ end;
+
+ -- The following two aspects do not require exact matching,
+ -- but only one-way agreement. See RM C.6.
+
+ if Is_Independent (A_Gen_T) and then not Is_Independent (Act_T)
+ then
+ Error_Msg_NE
+ ("actual for& must have Independent aspect specified",
+ Actual, A_Gen_T);
end if;
if Has_Independent_Components (A_Gen_T)
- and then not Has_Independent_Components (Act_T)
+ and then not Has_Independent_Components (Act_T)
then
Error_Msg_NE
- ("actual for& must have independent components",
- Actual, A_Gen_T);
+ ("actual for& must have Independent_Components specified",
+ Actual, A_Gen_T);
end if;
- if Has_Volatile_Components (A_Gen_T)
- and then not Has_Volatile_Components (Act_T)
- then
- if Is_Array_Type (Act_T)
- and then Is_Volatile (Component_Type (Act_T))
- then
- null;
+ -- Check actual/formal compatibility with respect to the four
+ -- volatility refinement aspects.
- else
- Error_Msg_NE
- ("actual for& must have volatile components",
- Actual, A_Gen_T);
- end if;
- end if;
+ Check_Volatility_Compatibility
+ (Act_T, A_Gen_T,
+ "actual type", "its corresponding formal type",
+ Srcpos_Bearer => Act_T);
end if;
end Check_Shared_Variable_Control_Aspects;
@@ -12327,8 +12650,8 @@ package body Sem_Ch12 is
Root_Type (Act_T)))
or else
- (Ekind_In (Gen_T, E_Anonymous_Access_Subprogram_Type,
- E_Anonymous_Access_Type)
+ (Ekind (Gen_T) in E_Anonymous_Access_Subprogram_Type
+ | E_Anonymous_Access_Type
and then Ekind (Act_T) = Ekind (Gen_T)
and then Subtypes_Statically_Match
(Designated_Type (Gen_T), Designated_Type (Act_T)));
@@ -12901,8 +13224,8 @@ package body Sem_Ch12 is
-- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1
-- removes the second instance of the phrase "or allow pass by copy".
- -- In Ada_2020 the aspect may be specified explicitly for the formal
- -- regardless of whether an ancestor obeys it.
+ -- For Ada 2020, the aspect may be specified explicitly for the
+ -- formal regardless of whether an ancestor obeys it.
if Is_Atomic (Act_T)
and then not Is_Atomic (Ancestor)
@@ -13016,8 +13339,16 @@ package body Sem_Ch12 is
if not Subtypes_Statically_Compatible
(Act_T, Ancestor, Formal_Derived_Matching => True)
then
- Error_Msg_N
- ("constraint on actual is incompatible with formal", Actual);
+ Error_Msg_NE
+ ("actual for & must be statically compatible with ancestor",
+ Actual, Gen_T);
+
+ if not Predicates_Compatible (Act_T, Ancestor) then
+ Error_Msg_N
+ ("\predicate on actual is not compatible with ancestor",
+ Actual);
+ end if;
+
Abandon_Instantiation (Actual);
end if;
end if;
@@ -13261,17 +13592,8 @@ package body Sem_Ch12 is
-- explicitly so. If not declared limited, the actual cannot be
-- limited (see AI05-0087).
- -- Even though this AI is a binding interpretation, we enable the
- -- check only in Ada 2012 mode, because this improper construct
- -- shows up in user code and in existing B-tests.
-
- if Is_Limited_Type (Act_T)
- and then not Is_Limited_Type (A_Gen_T)
- and then Ada_Version >= Ada_2012
- then
- if In_Instance then
- null;
- else
+ if Is_Limited_Type (Act_T) and then not Is_Limited_Type (A_Gen_T) then
+ if not In_Instance then
Error_Msg_NE
("actual for non-limited & cannot be a limited type",
Actual, Gen_T);
@@ -13280,30 +13602,25 @@ package body Sem_Ch12 is
end if;
end if;
- -- Don't check Ada_Version here (for now) because AI12-0036 is
- -- a binding interpretation; this decision may be reversed if
- -- the situation turns out to be similar to that of the preceding
- -- Is_Limited_Type test (see preceding comment).
+ -- Check for AI12-0036
declare
Formal_Is_Private_Extension : constant Boolean :=
Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration;
Actual_Is_Tagged : constant Boolean := Is_Tagged_Type (Act_T);
+
begin
if Actual_Is_Tagged /= Formal_Is_Private_Extension then
- if In_Instance then
- null;
- else
+ if not In_Instance then
if Actual_Is_Tagged then
Error_Msg_NE
- ("actual for & cannot be a tagged type",
- Actual, Gen_T);
+ ("actual for & cannot be a tagged type", Actual, Gen_T);
else
Error_Msg_NE
- ("actual for & must be a tagged type",
- Actual, Gen_T);
+ ("actual for & must be a tagged type", Actual, Gen_T);
end if;
+
Abandon_Instantiation (Actual);
end if;
end if;
@@ -13696,12 +14013,11 @@ package body Sem_Ch12 is
Defining_Identifier => Subt,
Subtype_Indication => New_Occurrence_Of (Act_T, Loc));
- if Is_Private_Type (Act_T) then
- Set_Has_Private_View (Subtype_Indication (Decl_Node));
+ -- Record whether the actual is private at this point, so that
+ -- Check_Generic_Actuals can restore its proper view before the
+ -- semantic analysis of the instance.
- elsif Is_Access_Type (Act_T)
- and then Is_Private_Type (Designated_Type (Act_T))
- then
+ if Is_Private_Type (Act_T) then
Set_Has_Private_View (Subtype_Indication (Decl_Node));
end if;
@@ -13734,8 +14050,8 @@ package body Sem_Ch12 is
Set_Generic_Parent_Type (Decl_Node, Ancestor);
end if;
- elsif Nkind_In (Def, N_Formal_Private_Type_Definition,
- N_Formal_Incomplete_Type_Definition)
+ elsif Nkind (Def) in N_Formal_Private_Type_Definition
+ | N_Formal_Incomplete_Type_Definition
then
Set_Generic_Parent_Type (Decl_Node, A_Gen_T);
end if;
@@ -13886,8 +14202,8 @@ package body Sem_Ch12 is
-- For a subprogram instantiation, omit instantiations intrinsic
-- operations (Unchecked_Conversions, etc.) that have no bodies.
- elsif Nkind_In (Decl, N_Function_Instantiation,
- N_Procedure_Instantiation)
+ elsif Nkind (Decl) in N_Function_Instantiation
+ | N_Procedure_Instantiation
and then not Is_Intrinsic_Subprogram (Entity (Name (Decl)))
then
Append_Elmt (Decl, Previous_Instances);
@@ -13987,6 +14303,21 @@ package body Sem_Ch12 is
exit;
+ -- If an ancestor of the generic comes from a formal package
+ -- there is no source for the ancestor body. This is detected
+ -- by examining the scope of the ancestor and its declaration.
+ -- The body, if any is needed, will be available when the
+ -- current unit (containing a formal package) is instantiated.
+
+ elsif Nkind (True_Parent) = N_Package_Specification
+ and then Present (Generic_Parent (True_Parent))
+ and then Nkind
+ (Original_Node (Unit_Declaration_Node
+ (Scope (Generic_Parent (True_Parent)))))
+ = N_Formal_Package_Declaration
+ then
+ return;
+
else
True_Parent := Parent (True_Parent);
end if;
@@ -14114,10 +14445,10 @@ package body Sem_Ch12 is
(Last (Visible_Declarations
(Specification (Info.Act_Decl))));
begin
- while Nkind_In (Decl,
- N_Null_Statement,
- N_Pragma,
- N_Subprogram_Renaming_Declaration)
+ while Nkind (Decl) in
+ N_Null_Statement |
+ N_Pragma |
+ N_Subprogram_Renaming_Declaration
loop
Decl := Prev (Decl);
end loop;
@@ -14836,9 +15167,9 @@ package body Sem_Ch12 is
-- explicitly now, in order to remain consistent with the view of the
-- parent type.
- if Ekind_In (Typ, E_Private_Type,
- E_Limited_Private_Type,
- E_Record_Type_With_Private)
+ if Ekind (Typ) in E_Private_Type
+ | E_Limited_Private_Type
+ | E_Record_Type_With_Private
then
Dep_Elmt := First_Elmt (Private_Dependents (Typ));
while Present (Dep_Elmt) loop
@@ -15270,11 +15601,7 @@ package body Sem_Ch12 is
-- If not a private type, nothing else to do
if not Is_Private_Type (Typ) then
- if Is_Array_Type (Typ)
- and then Is_Private_Type (Component_Type (Typ))
- then
- Set_Has_Private_View (N);
- end if;
+ null;
-- If it is a derivation of a private type in a context where no
-- full view is needed, nothing to do either.
@@ -15329,9 +15656,9 @@ package body Sem_Ch12 is
-- preserve in this case, since the expansion will be redone in
-- the instance.
- if not Nkind_In (E, N_Defining_Character_Literal,
- N_Defining_Identifier,
- N_Defining_Operator_Symbol)
+ if Nkind (E) not in N_Defining_Character_Literal
+ | N_Defining_Identifier
+ | N_Defining_Operator_Symbol
then
Set_Associated_Node (N, Empty);
Set_Etype (N, Empty);
@@ -15353,38 +15680,7 @@ package body Sem_Ch12 is
end if;
if Is_Global (E) then
-
- -- If the entity is a package renaming that is the prefix of
- -- an expanded name, it has been rewritten as the renamed
- -- package, which is necessary semantically but complicates
- -- ASIS tree traversal, so we recover the original entity to
- -- expose the renaming. Take into account that the context may
- -- be a nested generic, that the original node may itself have
- -- an associated node that had better be an entity, and that
- -- the current node is still a selected component.
-
- if Ekind (E) = E_Package
- and then Nkind (N) = N_Selected_Component
- and then Nkind (Parent (N)) = N_Expanded_Name
- and then Present (Original_Node (N2))
- and then Is_Entity_Name (Original_Node (N2))
- and then Present (Entity (Original_Node (N2)))
- then
- if Is_Global (Entity (Original_Node (N2))) then
- N2 := Original_Node (N2);
- Set_Associated_Node (N, N2);
- Set_Global_Type (N, N2);
-
- -- Renaming is local, and will be resolved in instance
-
- else
- Set_Associated_Node (N, Empty);
- Set_Etype (N, Empty);
- end if;
-
- else
- Set_Global_Type (N, N2);
- end if;
+ Set_Global_Type (N, N2);
elsif Nkind (N) = N_Op_Concat
and then Is_Generic_Type (Etype (N2))
@@ -15453,7 +15749,7 @@ package body Sem_Ch12 is
-- its value. Otherwise the folding will happen in any instantiation.
elsif Nkind (Parent (N)) = N_Selected_Component
- and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal)
+ and then Nkind (Parent (N2)) in N_Integer_Literal | N_Real_Literal
then
if Present (Entity (Original_Node (Parent (N2))))
and then Is_Global (Entity (Original_Node (Parent (N2))))
@@ -15755,12 +16051,12 @@ package body Sem_Ch12 is
-- global references within their aspects due to the timing of
-- annotation analysis.
- if Nkind_In (Nod, N_Generic_Package_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Package_Body,
- N_Package_Body_Stub,
- N_Subprogram_Body,
- N_Subprogram_Body_Stub)
+ if Nkind (Nod) in N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Package_Body
+ | N_Package_Body_Stub
+ | N_Subprogram_Body
+ | N_Subprogram_Body_Stub
then
-- Since the capture of global references is done on the
-- unanalyzed generic template, there is no information around
@@ -15917,41 +16213,14 @@ package body Sem_Ch12 is
-- The node did not undergo a transformation
if Nkind (N) = Nkind (Get_Associated_Node (N)) then
- declare
- Aux_N2 : constant Node_Id := Get_Associated_Node (N);
- Orig_N2_Parent : constant Node_Id :=
- Original_Node (Parent (Aux_N2));
- begin
- -- The parent of this identifier is a selected component
- -- which denotes a named number that was constant folded.
- -- Preserve the original name for ASIS and link the parent
- -- with its expanded name. The constant folding will be
- -- repeated in the instance.
-
- if Nkind (Parent (N)) = N_Selected_Component
- and then Nkind_In (Parent (Aux_N2), N_Integer_Literal,
- N_Real_Literal)
- and then Is_Entity_Name (Orig_N2_Parent)
- and then Ekind (Entity (Orig_N2_Parent)) in Named_Kind
- and then Is_Global (Entity (Orig_N2_Parent))
- then
- N2 := Aux_N2;
- Set_Associated_Node
- (Parent (N), Original_Node (Parent (N2)));
-
- -- Common case
+ -- If this is a discriminant reference, always save it.
+ -- It is used in the instance to find the corresponding
+ -- discriminant positionally rather than by name.
- else
- -- If this is a discriminant reference, always save it.
- -- It is used in the instance to find the corresponding
- -- discriminant positionally rather than by name.
-
- Set_Original_Discriminant
- (N, Original_Discriminant (Get_Associated_Node (N)));
- end if;
+ Set_Original_Discriminant
+ (N, Original_Discriminant (Get_Associated_Node (N)));
- Reset_Entity (N);
- end;
+ Reset_Entity (N);
-- The analysis of the generic copy transformed the identifier
-- into another construct. Propagate the changes to the template.
@@ -15975,8 +16244,9 @@ package body Sem_Ch12 is
-- The identifier denotes a named number that was constant
-- folded. Preserve the original name for ASIS and undo the
-- constant folding which will be repeated in the instance.
+ -- Is this still needed???
- elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal)
+ elsif Nkind (N2) in N_Integer_Literal | N_Real_Literal
and then Is_Entity_Name (Original_Node (N2))
then
Set_Associated_Node (N, Original_Node (N2));
@@ -16078,16 +16348,17 @@ package body Sem_Ch12 is
-- The operator was folded into a literal
- elsif Nkind_In (N2, N_Integer_Literal,
- N_Real_Literal,
- N_String_Literal)
+ elsif Nkind (N2) in N_Integer_Literal
+ | N_Real_Literal
+ | N_String_Literal
then
if Present (Original_Node (N2))
and then Nkind (Original_Node (N2)) = Nkind (N)
then
-- Operation was constant-folded. Whenever possible,
- -- recover semantic information from unfolded node,
- -- for ASIS use.
+ -- recover semantic information from unfolded node.
+ -- This was initially done for ASIS but is apparently
+ -- needed also for e.g. compiling a-nbnbin.adb.
Set_Associated_Node (N, Original_Node (N2));
@@ -16189,12 +16460,12 @@ package body Sem_Ch12 is
-- Aggregates
- elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
+ elsif Nkind (N) in N_Aggregate | N_Extension_Aggregate then
Save_References_In_Aggregate (N);
-- Character literals, operator symbols
- elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then
+ elsif Nkind (N) in N_Character_Literal | N_Operator_Symbol then
Save_References_In_Char_Lit_Or_Op_Symbol (N);
-- Defining identifiers
@@ -16420,19 +16691,9 @@ package body Sem_Ch12 is
end if;
while Present (Priv_Elmt) loop
- Priv_Sub := (Node (Priv_Elmt));
-
- -- We avoid flipping the subtype if the Etype of its full view is
- -- private because this would result in a malformed subtype. This
- -- occurs when the Etype of the subtype full view is the full view of
- -- the base type (and since the base types were just switched, the
- -- subtype is pointing to the wrong view). This is currently the case
- -- for tagged record types, access types (maybe more?) and needs to
- -- be resolved. ???
-
- if Present (Full_View (Priv_Sub))
- and then not Is_Private_Type (Etype (Full_View (Priv_Sub)))
- then
+ Priv_Sub := Node (Priv_Elmt);
+
+ if Present (Full_View (Priv_Sub)) then
Prepend_Elmt (Full_View (Priv_Sub), Exchanged_Views);
Exchange_Declarations (Priv_Sub);
end if;
@@ -16513,6 +16774,7 @@ package body Sem_Ch12 is
OK := (Is_Fun and then Num_F = 1);
when Attribute_Output
+ | Attribute_Put_Image
| Attribute_Read
| Attribute_Write
=>
diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads
index f0b72f4..a568b26 100644
--- a/gcc/ada/sem_ch12.ads
+++ b/gcc/ada/sem_ch12.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 5944ba5..30cade8 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -48,6 +48,7 @@ with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
+with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
@@ -91,6 +92,13 @@ package body Sem_Ch13 is
-- type whose inherited alignment is no longer appropriate for the new
-- size value. In this case, we reset the Alignment to unknown.
+ function All_Static_Choices (L : List_Id) return Boolean;
+ -- Returns true if all elements of the list are OK static choices
+ -- as defined below for Is_Static_Choice. Used for case expression
+ -- alternatives and for the right operand of a membership test. An
+ -- others_choice is static if the corresponding expression is static.
+ -- The staticness of the bounds is checked separately.
+
procedure Build_Discrete_Static_Predicate
(Typ : Entity_Id;
Expr : Node_Id;
@@ -154,6 +162,15 @@ package body Sem_Ch13 is
-- that do not specify a representation characteristic are operational
-- attributes.
+ function Is_Static_Choice (N : Node_Id) return Boolean;
+ -- Returns True if N represents a static choice (static subtype, or
+ -- static subtype indication, or static expression, or static range).
+ --
+ -- Note that this is a bit more inclusive than we actually need
+ -- (in particular membership tests do not allow the use of subtype
+ -- indications). But that doesn't matter, we have already checked
+ -- that the construct is legal to get this far.
+
function Is_Type_Related_Rep_Item (N : Node_Id) return Boolean;
-- Returns True for a representation clause/pragma that specifies a
-- type-related representation (as opposed to operational) aspect.
@@ -186,6 +203,12 @@ package body Sem_Ch13 is
-- We can't allow this, otherwise we have predicate-static applying to a
-- larger class than static expressions, which was never intended.
+ procedure New_Put_Image_Subprogram
+ (N : Node_Id;
+ Ent : Entity_Id;
+ Subp : Entity_Id);
+ -- Similar to New_Stream_Subprogram, but for the Put_Image attribute
+
procedure New_Stream_Subprogram
(N : Node_Id;
Ent : Entity_Id;
@@ -206,6 +229,10 @@ package body Sem_Ch13 is
-- renaming_as_body. For tagged types, the specification is one of the
-- primitive specs.
+ procedure No_Type_Rep_Item (N : Node_Id);
+ -- Output message indicating that no type-related aspects can be
+ -- specified due to some property of the parent type.
+
procedure Register_Address_Clause_Check
(N : Node_Id;
X : Entity_Id;
@@ -215,6 +242,16 @@ package body Sem_Ch13 is
-- Register a check for the address clause N. The rest of the parameters
-- are in keeping with the components of Address_Clause_Check_Record below.
+ procedure Validate_Aspect_Aggregate (N : Node_Id);
+ -- Check legality of operations given in the Ada 202x Aggregate aspect for
+ -- containers.
+
+ procedure Resolve_Aspect_Aggregate
+ (Typ : Entity_Id;
+ Expr : Node_Id);
+ -- Resolve each one of the operations specified in the specification of
+ -- Aspect_Aggregate.
+
procedure Resolve_Iterable_Operation
(N : Node_Id;
Cursor : Entity_Id;
@@ -814,6 +851,45 @@ package body Sem_Ch13 is
end if;
end Alignment_Check_For_Size_Change;
+ -----------------------------------
+ -- All_Membership_Choices_Static --
+ -----------------------------------
+
+ function All_Membership_Choices_Static (Expr : Node_Id) return Boolean is
+ pragma Assert (Nkind (Expr) in N_Membership_Test);
+ begin
+ pragma Assert
+ (Present (Right_Opnd (Expr))
+ xor
+ Present (Alternatives (Expr)));
+
+ if Present (Right_Opnd (Expr)) then
+ return Is_Static_Choice (Right_Opnd (Expr));
+ else
+ return All_Static_Choices (Alternatives (Expr));
+ end if;
+ end All_Membership_Choices_Static;
+
+ ------------------------
+ -- All_Static_Choices --
+ ------------------------
+
+ function All_Static_Choices (L : List_Id) return Boolean is
+ N : Node_Id;
+
+ begin
+ N := First (L);
+ while Present (N) loop
+ if not Is_Static_Choice (N) then
+ return False;
+ end if;
+
+ Next (N);
+ end loop;
+
+ return True;
+ end All_Static_Choices;
+
-------------------------------------
-- Analyze_Aspects_At_Freeze_Point --
-------------------------------------
@@ -823,6 +899,14 @@ package body Sem_Ch13 is
-- This routine analyzes an Aspect_Default_[Component_]Value denoted by
-- the aspect specification node ASN.
+ procedure Check_Aspect_Too_Late (N : Node_Id);
+ -- This procedure is similar to Rep_Item_Too_Late for representation
+ -- aspects that apply to type and that do not have a corresponding
+ -- pragma.
+ -- Used to check in particular that the expression associated with
+ -- aspect node N for the given type (entity) of the aspect does not
+ -- appear too late according to the rules in RM 13.1(9) and 13.1(10).
+
procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id);
-- As discussed in the spec of Aspects (see Aspect_Delay declaration),
-- a derived type can inherit aspects from its parent which have been
@@ -856,47 +940,112 @@ package body Sem_Ch13 is
----------------------------------
procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is
- A_Id : constant Aspect_Id := Get_Aspect_Id (ASN);
Ent : constant Entity_Id := Entity (ASN);
Expr : constant Node_Id := Expression (ASN);
- Id : constant Node_Id := Identifier (ASN);
begin
- Error_Msg_Name_1 := Chars (Id);
+ Set_Has_Default_Aspect (Base_Type (Ent));
- if not Is_Type (Ent) then
- Error_Msg_N ("aspect% can only apply to a type", Id);
- return;
+ if Is_Scalar_Type (Ent) then
+ Set_Default_Aspect_Value (Base_Type (Ent), Expr);
+ else
+ Set_Default_Aspect_Component_Value (Base_Type (Ent), Expr);
+ end if;
- elsif not Is_First_Subtype (Ent) then
- Error_Msg_N ("aspect% cannot apply to subtype", Id);
- return;
+ Check_Aspect_Too_Late (ASN);
+ end Analyze_Aspect_Default_Value;
- elsif A_Id = Aspect_Default_Value
- and then not Is_Scalar_Type (Ent)
- then
- Error_Msg_N ("aspect% can only be applied to scalar type", Id);
- return;
+ ---------------------------
+ -- Check_Aspect_Too_Late --
+ ---------------------------
- elsif A_Id = Aspect_Default_Component_Value then
- if not Is_Array_Type (Ent) then
- Error_Msg_N ("aspect% can only be applied to array type", Id);
- return;
+ procedure Check_Aspect_Too_Late (N : Node_Id) is
+ Typ : constant Entity_Id := Entity (N);
+ Expr : constant Node_Id := Expression (N);
- elsif not Is_Scalar_Type (Component_Type (Ent)) then
- Error_Msg_N ("aspect% requires scalar components", Id);
- return;
- end if;
+ function Find_Type_Reference
+ (Typ : Entity_Id; Expr : Node_Id) return Boolean;
+ -- Return True if a reference to type Typ is found in the expression
+ -- Expr.
+
+ -------------------------
+ -- Find_Type_Reference --
+ -------------------------
+
+ function Find_Type_Reference
+ (Typ : Entity_Id; Expr : Node_Id) return Boolean
+ is
+ function Find_Type (N : Node_Id) return Traverse_Result;
+ -- Set Found to True if N refers to Typ
+
+ ---------------
+ -- Find_Type --
+ ---------------
+
+ function Find_Type (N : Node_Id) return Traverse_Result is
+ begin
+ if N = Typ
+ or else (Nkind (N) in N_Identifier | N_Expanded_Name
+ and then Present (Entity (N))
+ and then Entity (N) = Typ)
+ then
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Find_Type;
+
+ function Search_Type_Reference is new Traverse_Func (Find_Type);
+
+ begin
+ return Search_Type_Reference (Expr) = Abandon;
+ end Find_Type_Reference;
+
+ Parent_Type : Entity_Id;
+
+ begin
+ -- Ensure Expr is analyzed so that e.g. all types are properly
+ -- resolved for Find_Type_Reference.
+
+ Analyze (Expr);
+
+ -- A self-referential aspect is illegal if it forces freezing the
+ -- entity before the corresponding aspect has been analyzed.
+
+ if Find_Type_Reference (Typ, Expr) then
+ Error_Msg_NE
+ ("aspect specification causes premature freezing of&", N, Typ);
end if;
- Set_Has_Default_Aspect (Base_Type (Ent));
+ -- For representation aspects, check for case of untagged derived
+ -- type whose parent either has primitive operations (pre Ada 202x),
+ -- or is a by-reference type (RM 13.1(10)).
+ -- Strictly speaking the check also applies to Ada 2012 but it is
+ -- really too constraining for existing code already, so relax it.
+ -- ??? Confirming aspects should be allowed here.
- if Is_Scalar_Type (Ent) then
- Set_Default_Aspect_Value (Base_Type (Ent), Expr);
- else
- Set_Default_Aspect_Component_Value (Base_Type (Ent), Expr);
+ if Is_Representation_Aspect (Get_Aspect_Id (N))
+ and then Is_Derived_Type (Typ)
+ and then not Is_Tagged_Type (Typ)
+ then
+ Parent_Type := Etype (Base_Type (Typ));
+
+ if Ada_Version <= Ada_2012
+ and then Has_Primitive_Operations (Parent_Type)
+ then
+ Error_Msg_N
+ ("|representation aspect not permitted before Ada 202x: " &
+ "use -gnat2020!", N);
+ Error_Msg_NE
+ ("\parent type & has primitive operations!", N, Parent_Type);
+
+ elsif Is_By_Reference_Type (Parent_Type) then
+ No_Type_Rep_Item (N);
+ Error_Msg_NE
+ ("\parent type & is a by-reference type!", N, Parent_Type);
+ end if;
end if;
- end Analyze_Aspect_Default_Value;
+ end Check_Aspect_Too_Late;
---------------------------------
-- Inherit_Delayed_Rep_Aspects --
@@ -905,7 +1054,7 @@ package body Sem_Ch13 is
procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id) is
A_Id : constant Aspect_Id := Get_Aspect_Id (ASN);
P : constant Entity_Id := Entity (ASN);
- -- Entithy for parent type
+ -- Entity for parent type
N : Node_Id;
-- Item from Rep_Item chain
@@ -1085,7 +1234,7 @@ package body Sem_Ch13 is
end if;
end if;
- N := Next_Rep_Item (N);
+ Next_Rep_Item (N);
end loop;
end Inherit_Delayed_Rep_Aspects;
@@ -1324,9 +1473,18 @@ package body Sem_Ch13 is
ASN, E);
end if;
+ when Aspect_Integer_Literal
+ | Aspect_Real_Literal
+ | Aspect_String_Literal
+ =>
+ Validate_Literal_Aspect (E, ASN);
+
when Aspect_Iterable =>
Validate_Iterable_Aspect (E, ASN);
+ when Aspect_Aggregate =>
+ null;
+
when others =>
null;
end case;
@@ -1429,11 +1587,11 @@ package body Sem_Ch13 is
-- package body Pack is
-- pragma Prag;
- if Nkind_In (N, N_Entry_Body,
- N_Package_Body,
- N_Protected_Body,
- N_Subprogram_Body,
- N_Task_Body)
+ if Nkind (N) in N_Entry_Body
+ | N_Package_Body
+ | N_Protected_Body
+ | N_Subprogram_Body
+ | N_Task_Body
then
Decls := Declarations (N);
@@ -1453,8 +1611,8 @@ package body Sem_Ch13 is
-- package Pack is
-- pragma Prag;
- elsif Nkind_In (N, N_Generic_Package_Declaration,
- N_Package_Declaration)
+ elsif Nkind (N) in N_Generic_Package_Declaration
+ | N_Package_Declaration
then
Decls := Visible_Declarations (Specification (N));
@@ -1580,7 +1738,7 @@ package body Sem_Ch13 is
-- Local variables
Aspect : Node_Id;
- Aitem : Node_Id;
+ Aitem : Node_Id := Empty;
Ent : Node_Id;
L : constant List_Id := Aspect_Specifications (N);
@@ -1646,6 +1804,15 @@ package body Sem_Ch13 is
procedure Analyze_Aspect_Implicit_Dereference;
-- Perform analysis of the Implicit_Dereference aspects
+ procedure Analyze_Aspect_Relaxed_Initialization;
+ -- Perform analysis of aspect Relaxed_Initialization
+
+ procedure Analyze_Aspect_Yield;
+ -- Perform analysis of aspect Yield
+
+ procedure Analyze_Aspect_Static;
+ -- Ada 202x (AI12-0075): Perform analysis of aspect Static
+
procedure Make_Aitem_Pragma
(Pragma_Argument_Associations : List_Id;
Pragma_Name : Name_Id);
@@ -1931,10 +2098,9 @@ package body Sem_Ch13 is
begin
while Present (Disc) loop
if Chars (Expr) = Chars (Disc)
- and then Ekind_In
- (Etype (Disc),
- E_Anonymous_Access_Subprogram_Type,
- E_Anonymous_Access_Type)
+ and then Ekind (Etype (Disc)) in
+ E_Anonymous_Access_Subprogram_Type |
+ E_Anonymous_Access_Type
then
Set_Has_Implicit_Dereference (E);
Set_Has_Implicit_Dereference (Disc);
@@ -1978,6 +2144,512 @@ package body Sem_Ch13 is
end Analyze_Aspect_Implicit_Dereference;
+ -------------------------------------------
+ -- Analyze_Aspect_Relaxed_Initialization --
+ -------------------------------------------
+
+ procedure Analyze_Aspect_Relaxed_Initialization is
+ procedure Analyze_Relaxed_Parameter
+ (Subp_Id : Entity_Id;
+ Param : Node_Id;
+ Seen : in out Elist_Id);
+ -- Analyze parameter that appears in the expression of the
+ -- aspect Relaxed_Initialization.
+
+ -------------------------------
+ -- Analyze_Relaxed_Parameter --
+ -------------------------------
+
+ procedure Analyze_Relaxed_Parameter
+ (Subp_Id : Entity_Id;
+ Param : Node_Id;
+ Seen : in out Elist_Id)
+ is
+ begin
+ -- The relaxed parameter is a formal parameter
+
+ if Nkind (Param) in N_Identifier | N_Expanded_Name then
+ Analyze (Param);
+
+ declare
+ Item : constant Entity_Id := Entity (Param);
+ begin
+ -- It must be a formal of the analyzed subprogram
+
+ if Scope (Item) = Subp_Id then
+
+ pragma Assert (Is_Formal (Item));
+
+ -- Detect duplicated items
+
+ if Contains (Seen, Item) then
+ Error_Msg_N ("duplicate aspect % item", Param);
+ else
+ Append_New_Elmt (Item, Seen);
+ end if;
+ else
+ Error_Msg_N ("illegal aspect % item", Param);
+ end if;
+ end;
+
+ -- The relaxed parameter is the function's Result attribute
+
+ elsif Is_Attribute_Result (Param) then
+ Analyze (Param);
+
+ declare
+ Pref : constant Node_Id := Prefix (Param);
+ begin
+ if Present (Pref)
+ and then
+ Nkind (Pref) in N_Identifier | N_Expanded_Name
+ and then
+ Entity (Pref) = Subp_Id
+ then
+ -- Detect duplicated items
+
+ if Contains (Seen, Subp_Id) then
+ Error_Msg_N ("duplicate aspect % item", Param);
+ else
+ Append_New_Elmt (Entity (Pref), Seen);
+ end if;
+
+ else
+ Error_Msg_N ("illegal aspect % item", Param);
+ end if;
+ end;
+ else
+ Error_Msg_N ("illegal aspect % item", Param);
+ end if;
+ end Analyze_Relaxed_Parameter;
+
+ -- Local variables
+
+ Seen : Elist_Id := No_Elist;
+ -- Items that appear in the relaxed initialization aspect
+ -- expression of a subprogram; for detecting duplicates.
+
+ Restore_Scope : Boolean;
+ -- Will be set to True if we need to restore the scope table
+ -- after analyzing the aspect expression.
+
+ Prev_Id : Entity_Id;
+
+ -- Start of processing for Analyze_Aspect_Relaxed_Initialization
+
+ begin
+ -- Set name of the aspect for error messages
+ Error_Msg_Name_1 := Nam;
+
+ -- Annotation of a type; no aspect expression is allowed.
+ -- For a private type, the aspect must be attached to the
+ -- partial view.
+ --
+ -- ??? Once the exact rule for this aspect is ready, we will
+ -- likely reject concurrent types, etc., so let's keep the code
+ -- for types and variable separate.
+
+ if Is_First_Subtype (E) then
+ Prev_Id := Incomplete_Or_Partial_View (E);
+ if Present (Prev_Id) then
+
+ -- Aspect may appear on the full view of an incomplete
+ -- type because the incomplete declaration cannot have
+ -- any aspects.
+
+ if Ekind (Prev_Id) = E_Incomplete_Type then
+ null;
+ else
+ Error_Msg_N ("aspect % must apply to partial view", N);
+ end if;
+
+ elsif Present (Expr) then
+ Error_Msg_N ("illegal aspect % expression", Expr);
+ end if;
+
+ -- Annotation of a variable; no aspect expression is allowed
+
+ elsif Ekind (E) = E_Variable then
+ if Present (Expr) then
+ Error_Msg_N ("illegal aspect % expression", Expr);
+ end if;
+
+ -- Annotation of a constant; no aspect expression is allowed.
+ -- For a deferred constant, the aspect must be attached to the
+ -- partial view.
+
+ elsif Ekind (E) = E_Constant then
+ if Present (Incomplete_Or_Partial_View (E)) then
+ Error_Msg_N
+ ("aspect % must apply to deferred constant", N);
+
+ elsif Present (Expr) then
+ Error_Msg_N ("illegal aspect % expression", Expr);
+ end if;
+
+ -- Annotation of a subprogram; aspect expression is required
+
+ elsif Is_Subprogram_Or_Entry (E)
+ or else Is_Generic_Subprogram (E)
+ then
+ if Present (Expr) then
+
+ -- If we analyze subprogram body that acts as its own
+ -- spec, then the subprogram itself and its formals are
+ -- already installed; otherwise, we need to install them,
+ -- as they must be visible when analyzing the aspect
+ -- expression.
+
+ if In_Open_Scopes (E) then
+ Restore_Scope := False;
+ else
+ Restore_Scope := True;
+ Push_Scope (E);
+
+ -- Only formals of the subprogram itself can appear
+ -- in Relaxed_Initialization aspect expression, not
+ -- formals of the enclosing generic unit. (This is
+ -- different than in Precondition or Depends aspects,
+ -- where both kinds of formals are allowed.)
+
+ Install_Formals (E);
+ end if;
+
+ -- Aspect expression is either an aggregate with list of
+ -- parameters (and possibly the Result attribute for a
+ -- function).
+
+ if Nkind (Expr) = N_Aggregate then
+
+ -- Component associations in the aggregate must be a
+ -- parameter name followed by a static boolean
+ -- expression.
+
+ if Present (Component_Associations (Expr)) then
+ declare
+ Assoc : Node_Id :=
+ First (Component_Associations (Expr));
+ begin
+ while Present (Assoc) loop
+ if List_Length (Choices (Assoc)) = 1 then
+ Analyze_Relaxed_Parameter
+ (E, First (Choices (Assoc)), Seen);
+
+ if Inside_A_Generic then
+ Preanalyze_And_Resolve
+ (Expression (Assoc), Any_Boolean);
+ else
+ Analyze_And_Resolve
+ (Expression (Assoc), Any_Boolean);
+ end if;
+
+ if not Is_OK_Static_Expression
+ (Expression (Assoc))
+ then
+ Error_Msg_N
+ ("expression of aspect %" &
+ "must be static", Aspect);
+ end if;
+
+ else
+ Error_Msg_N
+ ("illegal aspect % expression", Expr);
+ end if;
+ Next (Assoc);
+ end loop;
+ end;
+ end if;
+
+ -- Expressions of the aggregate are parameter names
+
+ if Present (Expressions (Expr)) then
+ declare
+ Param : Node_Id := First (Expressions (Expr));
+
+ begin
+ while Present (Param) loop
+ Analyze_Relaxed_Parameter (E, Param, Seen);
+ Next (Param);
+ end loop;
+ end;
+ end if;
+
+ -- Mark the aggregate expression itself as analyzed;
+ -- its subexpressions were marked when they themselves
+ -- were analyzed.
+
+ Set_Analyzed (Expr);
+
+ -- Otherwise, it is a single name of a subprogram
+ -- parameter (or possibly the Result attribute for
+ -- a function).
+
+ else
+ Analyze_Relaxed_Parameter (E, Expr, Seen);
+ end if;
+
+ if Restore_Scope then
+ End_Scope;
+ end if;
+ else
+ Error_Msg_N ("missing expression for aspect %", N);
+ end if;
+
+ else
+ Error_Msg_N ("inappropriate entity for aspect %", E);
+ end if;
+ end Analyze_Aspect_Relaxed_Initialization;
+
+ ---------------------------
+ -- Analyze_Aspect_Static --
+ ---------------------------
+
+ procedure Analyze_Aspect_Static is
+ function Has_Convention_Intrinsic (L : List_Id) return Boolean;
+ -- Return True if L contains a pragma argument association
+ -- node representing a convention Intrinsic.
+
+ ------------------------------
+ -- Has_Convention_Intrinsic --
+ ------------------------------
+
+ function Has_Convention_Intrinsic
+ (L : List_Id) return Boolean
+ is
+ Arg : Node_Id := First (L);
+ begin
+ while Present (Arg) loop
+ if Nkind (Arg) = N_Pragma_Argument_Association
+ and then Chars (Arg) = Name_Convention
+ and then Chars (Expression (Arg)) = Name_Intrinsic
+ then
+ return True;
+ end if;
+
+ Next (Arg);
+ end loop;
+
+ return False;
+ end Has_Convention_Intrinsic;
+
+ Is_Imported_Intrinsic : Boolean;
+
+ begin
+ if Ada_Version < Ada_2020 then
+ Error_Msg_N
+ ("aspect % is an Ada 202x feature", Aspect);
+ Error_Msg_N ("\compile with -gnat2020", Aspect);
+
+ return;
+ end if;
+
+ Is_Imported_Intrinsic := Is_Imported (E)
+ and then
+ Has_Convention_Intrinsic
+ (Pragma_Argument_Associations (Import_Pragma (E)));
+
+ -- The aspect applies only to expression functions that
+ -- statisfy the requirements for a static expression function
+ -- (such as having an expression that is predicate-static) as
+ -- well as Intrinsic imported functions as a -gnatX extension.
+
+ if not Is_Expression_Function (E)
+ and then
+ not (Extensions_Allowed and then Is_Imported_Intrinsic)
+ then
+ if Extensions_Allowed then
+ Error_Msg_N
+ ("aspect % requires intrinsic or expression function",
+ Aspect);
+
+ elsif Is_Imported_Intrinsic then
+ Error_Msg_N
+ ("aspect % on intrinsic function is an extension: " &
+ "use -gnatX",
+ Aspect);
+
+ else
+ Error_Msg_N
+ ("aspect % requires expression function", Aspect);
+ end if;
+
+ return;
+
+ -- Ada 202x (AI12-0075): Check that the function satisfies
+ -- several requirements of static functions as specified in
+ -- RM 6.8(5.1-5.8). Note that some of the requirements given
+ -- there are checked elsewhere.
+
+ else
+ -- The expression of the expression function must be a
+ -- potentially static expression (RM 202x 6.8(3.2-3.4)).
+ -- That's checked in Sem_Ch6.Analyze_Expression_Function.
+
+ -- The function must not contain any calls to itself, which
+ -- is checked in Sem_Res.Resolve_Call.
+
+ -- Each formal must be of mode in and have a static subtype
+
+ declare
+ Formal : Entity_Id := First_Formal (E);
+ begin
+ while Present (Formal) loop
+ if Ekind (Formal) /= E_In_Parameter then
+ Error_Msg_N
+ ("aspect % requires formals of mode IN",
+ Aspect);
+
+ return;
+ end if;
+
+ if not Is_Static_Subtype (Etype (Formal)) then
+ Error_Msg_N
+ ("aspect % requires formals with static subtypes",
+ Aspect);
+
+ return;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+ end;
+
+ -- The function's result subtype must be a static subtype
+
+ if not Is_Static_Subtype (Etype (E)) then
+ Error_Msg_N
+ ("aspect % requires function with result of "
+ & "a static subtype",
+ Aspect);
+
+ return;
+ end if;
+
+ -- Check that the function does not have any applicable
+ -- precondition or postcondition expression.
+
+ for Asp in Pre_Post_Aspects loop
+ if Has_Aspect (E, Asp) then
+ Error_Msg_N
+ ("this aspect not allowed for static expression "
+ & "functions", Find_Aspect (E, Asp));
+
+ return;
+ end if;
+ end loop;
+
+ -- ??? TBD: Must check that "for result type R, if the
+ -- function is a boundary entity for type R (see 7.3.2),
+ -- no type invariant applies to type R; if R has a
+ -- component type C, a similar rule applies to C."
+ end if;
+
+ -- Preanalyze the expression (if any) when the aspect resides
+ -- in a generic unit. (Is this generic-related code necessary
+ -- for this aspect? It's modeled on what's done for aspect
+ -- Disable_Controlled. ???)
+
+ if Inside_A_Generic then
+ if Present (Expr) then
+ Preanalyze_And_Resolve (Expr, Any_Boolean);
+ end if;
+
+ -- Otherwise the aspect resides in a nongeneric context
+
+ else
+ -- When the expression statically evaluates to True, the
+ -- expression function is treated as a static function.
+ -- Otherwise the aspect appears without an expression and
+ -- defaults to True.
+
+ if Present (Expr) then
+ Analyze_And_Resolve (Expr, Any_Boolean);
+
+ -- Error if the boolean expression is not static
+
+ if not Is_OK_Static_Expression (Expr) then
+ Error_Msg_N
+ ("expression of aspect % must be static", Aspect);
+ end if;
+ end if;
+ end if;
+ end Analyze_Aspect_Static;
+
+ --------------------------
+ -- Analyze_Aspect_Yield --
+ --------------------------
+
+ procedure Analyze_Aspect_Yield is
+ Expr_Value : Boolean := False;
+
+ begin
+ -- Check valid declarations for 'Yield
+
+ if Nkind (N) in N_Abstract_Subprogram_Declaration
+ | N_Entry_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Subprogram_Declaration
+ | N_Formal_Subprogram_Declaration
+ and then not Within_Protected_Type (E)
+ then
+ null;
+
+ elsif Within_Protected_Type (E) then
+ Error_Msg_N
+ ("aspect% not applicable to protected operations", Id);
+ return;
+
+ else
+ Error_Msg_N
+ ("aspect% only applicable to subprogram and entry "
+ & "declarations", Id);
+ return;
+ end if;
+
+ -- Evaluate its static expression (if available); otherwise it
+ -- defaults to True.
+
+ if No (Expr) then
+ Expr_Value := True;
+
+ -- Otherwise it must have a static boolean expression
+
+ else
+ if Inside_A_Generic then
+ Preanalyze_And_Resolve (Expr, Any_Boolean);
+ else
+ Analyze_And_Resolve (Expr, Any_Boolean);
+ end if;
+
+ if Is_OK_Static_Expression (Expr) then
+ if Is_True (Static_Boolean (Expr)) then
+ Expr_Value := True;
+ end if;
+ else
+ Error_Msg_N
+ ("expression of aspect % must be static", Aspect);
+ end if;
+ end if;
+
+ if Expr_Value then
+ Set_Has_Yield_Aspect (E);
+ end if;
+
+ -- If the Yield aspect is specified for a dispatching
+ -- subprogram that inherits the aspect, the specified
+ -- value shall be confirming.
+
+ if Present (Expr)
+ and then Is_Dispatching_Operation (E)
+ and then Present (Overridden_Operation (E))
+ and then Has_Yield_Aspect (Overridden_Operation (E))
+ /= Is_True (Static_Boolean (Expr))
+ then
+ Error_Msg_N ("specification of inherited aspect% can only " &
+ "confirm parent value", Id);
+ end if;
+ end Analyze_Aspect_Yield;
+
-----------------------
-- Make_Aitem_Pragma --
-----------------------
@@ -2118,7 +2790,12 @@ package body Sem_Ch13 is
-- Check some general restrictions on language defined aspects
- if not Implementation_Defined_Aspect (A_Id) then
+ if not Implementation_Defined_Aspect (A_Id)
+ or else A_Id = Aspect_Async_Readers
+ or else A_Id = Aspect_Async_Writers
+ or else A_Id = Aspect_Effective_Reads
+ or else A_Id = Aspect_Effective_Reads
+ then
Error_Msg_Name_1 := Nam;
-- Not allowed for renaming declarations. Examine the original
@@ -2147,6 +2824,10 @@ package body Sem_Ch13 is
and then A_Id /= Aspect_Atomic_Components
and then A_Id /= Aspect_Independent_Components
and then A_Id /= Aspect_Volatile_Components
+ and then A_Id /= Aspect_Async_Readers
+ and then A_Id /= Aspect_Async_Writers
+ and then A_Id /= Aspect_Effective_Reads
+ and then A_Id /= Aspect_Effective_Reads
then
Error_Msg_N
("aspect % not allowed for formal type declaration",
@@ -2180,17 +2861,30 @@ package body Sem_Ch13 is
if A_Id in Boolean_Aspects and then No (Expr) then
Delay_Required := False;
- -- For non-Boolean aspects, don't delay if integer literal,
- -- unless the aspect is Alignment, which affects the
- -- freezing of an initialized object.
+ -- For non-Boolean aspects, don't delay if integer literal
elsif A_Id not in Boolean_Aspects
- and then A_Id /= Aspect_Alignment
and then Present (Expr)
and then Nkind (Expr) = N_Integer_Literal
then
Delay_Required := False;
+ -- For Alignment and various Size aspects, don't delay for
+ -- an attribute reference whose prefix is Standard, for
+ -- example Standard'Maximum_Alignment or Standard'Word_Size.
+
+ elsif (A_Id = Aspect_Alignment
+ or else A_Id = Aspect_Component_Size
+ or else A_Id = Aspect_Object_Size
+ or else A_Id = Aspect_Size
+ or else A_Id = Aspect_Value_Size)
+ and then Present (Expr)
+ and then Nkind (Expr) = N_Attribute_Reference
+ and then Nkind (Prefix (Expr)) = N_Identifier
+ and then Chars (Prefix (Expr)) = Name_Standard
+ then
+ Delay_Required := False;
+
-- All other cases are delayed
else
@@ -2199,6 +2893,17 @@ package body Sem_Ch13 is
end if;
end case;
+ -- Check 13.1(9.2/5): A representation aspect of a subtype or type
+ -- shall not be specified (whether by a representation item or an
+ -- aspect_specification) before the type is completely defined
+ -- (see 3.11.1).
+
+ if Is_Representation_Aspect (A_Id)
+ and then Rep_Item_Too_Early (E, N)
+ then
+ goto Continue;
+ end if;
+
-- Processing based on specific aspect
case A_Id is
@@ -2227,6 +2932,7 @@ package body Sem_Ch13 is
| Aspect_Machine_Radix
| Aspect_Object_Size
| Aspect_Output
+ | Aspect_Put_Image
| Aspect_Read
| Aspect_Scalar_Storage_Order
| Aspect_Simple_Storage_Pool
@@ -2294,26 +3000,13 @@ package body Sem_Ch13 is
-- Construct the attribute_definition_clause. The expression
-- in the aspect specification is simply shared with the
-- constructed attribute, because it will be fully analyzed
- -- when the attribute is processed. However, in ASIS mode
- -- the aspect expression itself is preanalyzed and resolved
- -- to catch visibility errors that are otherwise caught
- -- later, and we create a separate copy of the expression
- -- to prevent analysis of a malformed tree (e.g. a function
- -- call with parameter associations).
-
- if ASIS_Mode then
- Aitem :=
- Make_Attribute_Definition_Clause (Loc,
- Name => Ent,
- Chars => Chars (Id),
- Expression => New_Copy_Tree (Expr));
- else
- Aitem :=
- Make_Attribute_Definition_Clause (Loc,
- Name => Ent,
- Chars => Chars (Id),
- Expression => Relocate_Node (Expr));
- end if;
+ -- when the attribute is processed.
+
+ Aitem :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => Ent,
+ Chars => Chars (Id),
+ Expression => Relocate_Node (Expr));
-- If the address is specified, then we treat the entity as
-- referenced, to avoid spurious warnings. This is analogous
@@ -2460,6 +3153,21 @@ package body Sem_Ch13 is
Set_Has_Delayed_Aspects (Full_View (E));
Ensure_Freeze_Node (Full_View (E));
+
+ -- If there is an Underlying_Full_View, also create a
+ -- freeze node for that one.
+
+ if Is_Private_Type (Full_View (E)) then
+ declare
+ U_Full : constant Entity_Id :=
+ Underlying_Full_View (Full_View (E));
+ begin
+ if Present (U_Full) then
+ Set_Has_Delayed_Aspects (U_Full);
+ Ensure_Freeze_Node (U_Full);
+ end if;
+ end;
+ end if;
end if;
-- Predicate_Failure
@@ -2478,6 +3186,12 @@ package body Sem_Ch13 is
Error_Msg_N
("predicate cannot apply to incomplete view", Aspect);
goto Continue;
+
+ elsif not Has_Predicates (E) then
+ Error_Msg_N
+ ("Predicate_Failure requires previous predicate" &
+ " specification", Aspect);
+ goto Continue;
end if;
-- Construct the pragma
@@ -2490,18 +3204,6 @@ package body Sem_Ch13 is
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Predicate_Failure);
- Set_Has_Predicates (E);
-
- -- If the type is private, indicate that its completion
- -- has a freeze node, because that is the one that will
- -- be visible at freeze time.
-
- if Is_Private_Type (E) and then Present (Full_View (E)) then
- Set_Has_Predicates (Full_View (E));
- Set_Has_Delayed_Aspects (Full_View (E));
- Ensure_Freeze_Node (Full_View (E));
- end if;
-
-- Case 2b: Aspects corresponding to pragmas with two
-- arguments, where the second argument is a local name
-- referring to the entity, and the first argument is the
@@ -2540,8 +3242,7 @@ package body Sem_Ch13 is
| Aspect_Interrupt_Priority
| Aspect_Priority
=>
- if Nkind_In (N, N_Subprogram_Body,
- N_Subprogram_Declaration)
+ if Nkind (N) in N_Subprogram_Body | N_Subprogram_Declaration
then
-- Analyze the aspect expression
@@ -2731,8 +3432,8 @@ package body Sem_Ch13 is
Context := Instance_Spec (Context);
end if;
- if Nkind_In (Context, N_Generic_Package_Declaration,
- N_Package_Declaration)
+ if Nkind (Context) in N_Generic_Package_Declaration
+ | N_Package_Declaration
then
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
@@ -2958,8 +3659,8 @@ package body Sem_Ch13 is
Context := Instance_Spec (Context);
end if;
- if Nkind_In (Context, N_Generic_Package_Declaration,
- N_Package_Declaration)
+ if Nkind (Context) in N_Generic_Package_Declaration
+ | N_Package_Declaration
then
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
@@ -3006,8 +3707,8 @@ package body Sem_Ch13 is
Context := Instance_Spec (Context);
end if;
- if Nkind_In (Context, N_Generic_Package_Declaration,
- N_Package_Declaration)
+ if Nkind (Context) in N_Generic_Package_Declaration
+ | N_Package_Declaration
then
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
@@ -3108,8 +3809,8 @@ package body Sem_Ch13 is
-- Part_Of
when Aspect_Part_Of =>
- if Nkind_In (N, N_Object_Declaration,
- N_Package_Instantiation)
+ if Nkind (N) in N_Object_Declaration
+ | N_Package_Instantiation
or else Is_Single_Concurrent_Type_Declaration (N)
then
Make_Aitem_Pragma
@@ -3264,6 +3965,12 @@ package body Sem_Ch13 is
end;
end if;
+ -- Relaxed_Initialization
+
+ when Aspect_Relaxed_Initialization =>
+ Analyze_Aspect_Relaxed_Initialization;
+ goto Continue;
+
-- Secondary_Stack_Size
-- Aspect Secondary_Stack_Size needs to be converted into a
@@ -3381,26 +4088,57 @@ package body Sem_Ch13 is
-- Case 3a: The aspects listed below don't correspond to
-- pragmas/attributes but do require delayed analysis.
- -- Default_Value can only apply to a scalar type
+ when Aspect_Default_Value | Aspect_Default_Component_Value =>
+ Error_Msg_Name_1 := Chars (Id);
- when Aspect_Default_Value =>
- if not Is_Scalar_Type (E) then
- Error_Msg_N
- ("aspect Default_Value must apply to a scalar type", N);
+ if not Is_Type (E) then
+ Error_Msg_N ("aspect% can only apply to a type", Id);
+ goto Continue;
+
+ elsif not Is_First_Subtype (E) then
+ Error_Msg_N ("aspect% cannot apply to subtype", Id);
+ goto Continue;
+
+ elsif A_Id = Aspect_Default_Value
+ and then not Is_Scalar_Type (E)
+ then
+ Error_Msg_N ("aspect% can only be applied to scalar type",
+ Id);
+ goto Continue;
+
+ elsif A_Id = Aspect_Default_Component_Value then
+ if not Is_Array_Type (E) then
+ Error_Msg_N ("aspect% can only be applied to array " &
+ "type", Id);
+ goto Continue;
+
+ elsif not Is_Scalar_Type (Component_Type (E)) then
+ Error_Msg_N ("aspect% requires scalar components", Id);
+ goto Continue;
+ end if;
end if;
Aitem := Empty;
- -- Default_Component_Value can only apply to an array type
- -- with scalar components.
+ when Aspect_Aggregate =>
+ Validate_Aspect_Aggregate (Expr);
+ Record_Rep_Item (E, Aspect);
+ return;
- when Aspect_Default_Component_Value =>
- if not (Is_Array_Type (E)
- and then Is_Scalar_Type (Component_Type (E)))
- then
+ when Aspect_Integer_Literal
+ | Aspect_Real_Literal
+ | Aspect_String_Literal
+ =>
+
+ if not Is_First_Subtype (E) then
Error_Msg_N
- ("aspect Default_Component_Value can only apply to an "
- & "array of scalar components", N);
+ ("may only be specified for a first subtype", Aspect);
+ goto Continue;
+ end if;
+
+ if Ada_Version < Ada_2020 then
+ Check_Restriction
+ (No_Implementation_Aspect_Specifications, N);
end if;
Aitem := Empty;
@@ -3464,7 +4202,7 @@ package body Sem_Ch13 is
if Class_Present (Aspect)
and then Is_Concurrent_Type (Current_Scope)
- and then Ekind_In (E, E_Entry, E_Function, E_Procedure)
+ and then Ekind (E) in E_Entry | E_Function | E_Procedure
then
Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Aspect);
Error_Msg_N
@@ -3488,17 +4226,14 @@ package body Sem_Ch13 is
-- We do not do this for Pre'Class, since we have to put
-- these conditions together in a complex OR expression.
- -- We do not do this in ASIS mode, as ASIS relies on the
- -- original node representing the complete expression, when
- -- retrieving it through the source aspect table. Also, we
- -- don't do this in GNATprove mode, because it brings no
- -- benefit for proof and causes annoynace for flow analysis,
+ -- We don't do this in GNATprove mode, because it brings no
+ -- benefit for proof and causes annoyance for flow analysis,
-- which prefers to be as close to the original source code
-- as possible. Also we don't do this when analyzing generic
-- units since it causes spurious visibility errors in the
-- preanalysis of instantiations.
- if not (ASIS_Mode or GNATprove_Mode)
+ if not GNATprove_Mode
and then (Pname = Name_Postcondition
or else not Class_Present (Aspect))
and then not Inside_A_Generic
@@ -3521,16 +4256,16 @@ package body Sem_Ch13 is
-- because subsequent visibility analysis of the aspect
-- depends on this sharing. This should be cleaned up???
- -- If the context is generic or involves ASIS, we want
- -- to preserve the original tree, and simply share it
- -- between aspect and generated attribute. This parallels
- -- what is done in sem_prag.adb (see Get_Argument).
+ -- If the context is generic, we want to preserve the
+ -- original tree, and simply share it between aspect and
+ -- generated attribute. This parallels what is done in
+ -- sem_prag.adb (see Get_Argument).
declare
New_Expr : Node_Id;
begin
- if ASIS_Mode or else Inside_A_Generic then
+ if Inside_A_Generic then
New_Expr := Expr;
else
New_Expr := Relocate_Node (Expr);
@@ -3577,7 +4312,6 @@ package body Sem_Ch13 is
Args : List_Id;
Comp_Expr : Node_Id;
Comp_Assn : Node_Id;
- New_Expr : Node_Id;
begin
Args := New_List;
@@ -3595,17 +4329,14 @@ package body Sem_Ch13 is
goto Continue;
end if;
- -- Make pragma expressions refer to the original aspect
- -- expressions through the Original_Node link. This is used
- -- in semantic analysis for ASIS mode, so that the original
- -- expression also gets analyzed.
+ -- Create the list of arguments for building the Test_Case
+ -- pragma.
Comp_Expr := First (Expressions (Expr));
while Present (Comp_Expr) loop
- New_Expr := Relocate_Node (Comp_Expr);
Append_To (Args,
Make_Pragma_Argument_Association (Sloc (Comp_Expr),
- Expression => New_Expr));
+ Expression => Relocate_Node (Comp_Expr)));
Next (Comp_Expr);
end loop;
@@ -3695,6 +4426,18 @@ package body Sem_Ch13 is
elsif A_Id = Aspect_Disable_Controlled then
Analyze_Aspect_Disable_Controlled;
goto Continue;
+
+ -- Ada 202x (AI12-0075): static expression functions
+
+ elsif A_Id = Aspect_Static then
+ Analyze_Aspect_Static;
+ goto Continue;
+
+ -- Ada 2020 (AI12-0279)
+
+ elsif A_Id = Aspect_Yield then
+ Analyze_Aspect_Yield;
+ goto Continue;
end if;
-- Library unit aspects require special handling in the case
@@ -3704,8 +4447,8 @@ package body Sem_Ch13 is
if A_Id in Library_Unit_Aspects
and then
- Nkind_In (N, N_Package_Declaration,
- N_Generic_Package_Declaration)
+ Nkind (N) in N_Package_Declaration
+ | N_Generic_Package_Declaration
and then Nkind (Parent (N)) /= N_Compilation_Unit
-- Aspect is legal on a local instantiation of a library-
@@ -3914,13 +4657,9 @@ package body Sem_Ch13 is
-- as well, even though it appears on a first subtype. This is
-- mandated by the semantics of the aspect. Do not establish
-- the link when processing the base type itself as this leads
- -- to a rep item circularity. Verify that we are dealing with
- -- a scalar type to prevent cascaded errors.
+ -- to a rep item circularity.
- if A_Id = Aspect_Default_Value
- and then Is_Scalar_Type (E)
- and then Base_Type (E) /= E
- then
+ if A_Id = Aspect_Default_Value and then Base_Type (E) /= E then
Set_Has_Delayed_Aspects (Base_Type (E));
Record_Rep_Item (Base_Type (E), Aspect);
end if;
@@ -3931,7 +4670,7 @@ package body Sem_Ch13 is
-- When delay is not required and the context is a package or a
-- subprogram body, insert the pragma in the body declarations.
- elsif Nkind_In (N, N_Package_Body, N_Subprogram_Body) then
+ elsif Nkind (N) in N_Package_Body | N_Subprogram_Body then
if No (Declarations (N)) then
Set_Declarations (N, New_List);
end if;
@@ -4164,6 +4903,8 @@ package body Sem_Ch13 is
-- Storage_Size for derived task types, but that is also clearly
-- unintentional.
+ procedure Analyze_Put_Image_TSS_Definition;
+
procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type);
-- Common processing for 'Read, 'Write, 'Input and 'Output attribute
-- definition clauses.
@@ -4187,6 +4928,152 @@ package body Sem_Ch13 is
-- Common legality check for the previous two
-----------------------------------
+ -- Analyze_Put_Image_TSS_Definition --
+ -----------------------------------
+
+ procedure Analyze_Put_Image_TSS_Definition is
+ Subp : Entity_Id := Empty;
+ I : Interp_Index;
+ It : Interp;
+ Pnam : Entity_Id;
+
+ function Has_Good_Profile
+ (Subp : Entity_Id;
+ Report : Boolean := False) return Boolean;
+ -- Return true if the entity is a subprogram with an appropriate
+ -- profile for the attribute being defined. If result is False and
+ -- Report is True, function emits appropriate error.
+
+ ----------------------
+ -- Has_Good_Profile --
+ ----------------------
+
+ function Has_Good_Profile
+ (Subp : Entity_Id;
+ Report : Boolean := False) return Boolean
+ is
+ F : Entity_Id;
+ Typ : Entity_Id;
+
+ begin
+ if Ekind (Subp) /= E_Procedure then
+ return False;
+ end if;
+
+ F := First_Formal (Subp);
+
+ if No (F) or else Etype (F) /= Class_Wide_Type (RTE (RE_Sink)) then
+ return False;
+ end if;
+
+ Next_Formal (F);
+
+ if Parameter_Mode (F) /= E_In_Parameter then
+ return False;
+ end if;
+
+ Typ := Etype (F);
+
+ -- Verify that the prefix of the attribute and the local name for
+ -- the type of the formal match.
+
+ if Typ /= Ent then
+ return False;
+ end if;
+
+ if Present (Next_Formal (F)) then
+ return False;
+
+ elsif not Is_Scalar_Type (Typ)
+ and then not Is_First_Subtype (Typ)
+ then
+ if Report and not Is_First_Subtype (Typ) then
+ Error_Msg_N
+ ("subtype of formal in Put_Image operation must be a "
+ & "first subtype", Parameter_Type (Parent (F)));
+ end if;
+
+ return False;
+
+ else
+ return True;
+ end if;
+ end Has_Good_Profile;
+
+ -- Start of processing for Analyze_Put_Image_TSS_Definition
+
+ begin
+ if not Is_Type (U_Ent) then
+ Error_Msg_N ("local name must be a subtype", Nam);
+ return;
+
+ elsif not Is_First_Subtype (U_Ent) then
+ Error_Msg_N ("local name must be a first subtype", Nam);
+ return;
+ end if;
+
+ Pnam := TSS (Base_Type (U_Ent), TSS_Put_Image);
+
+ -- If Pnam is present, it can be either inherited from an ancestor
+ -- type (in which case it is legal to redefine it for this type), or
+ -- be a previous definition of the attribute for the same type (in
+ -- which case it is illegal).
+
+ -- In the first case, it will have been analyzed already, and we can
+ -- check that its profile does not match the expected profile for the
+ -- Put_Image attribute of U_Ent. In the second case, either Pnam has
+ -- been analyzed (and has the expected profile), or it has not been
+ -- analyzed yet (case of a type that has not been frozen yet and for
+ -- which Put_Image has been set using Set_TSS).
+
+ if Present (Pnam)
+ and then (No (First_Entity (Pnam)) or else Has_Good_Profile (Pnam))
+ then
+ Error_Msg_Sloc := Sloc (Pnam);
+ Error_Msg_Name_1 := Attr;
+ Error_Msg_N ("% attribute already defined #", Nam);
+ return;
+ end if;
+
+ Analyze (Expr);
+
+ if Is_Entity_Name (Expr) then
+ if not Is_Overloaded (Expr) then
+ if Has_Good_Profile (Entity (Expr), Report => True) then
+ Subp := Entity (Expr);
+ end if;
+
+ else
+ Get_First_Interp (Expr, I, It);
+ while Present (It.Nam) loop
+ if Has_Good_Profile (It.Nam) then
+ Subp := It.Nam;
+ exit;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
+ end if;
+
+ if Present (Subp) then
+ if Is_Abstract_Subprogram (Subp) then
+ Error_Msg_N ("Put_Image subprogram must not be abstract", Expr);
+ return;
+ end if;
+
+ Set_Entity (Expr, Subp);
+ Set_Etype (Expr, Etype (Subp));
+
+ New_Put_Image_Subprogram (N, U_Ent, Subp);
+
+ else
+ Error_Msg_Name_1 := Attr;
+ Error_Msg_N ("incorrect expression for% attribute", Expr);
+ end if;
+ end Analyze_Put_Image_TSS_Definition;
+
+ -----------------------------------
-- Analyze_Stream_TSS_Definition --
-----------------------------------
@@ -4250,33 +5137,14 @@ package body Sem_Ch13 is
Typ := Etype (F);
- -- If the attribute specification comes from an aspect
- -- specification for a class-wide stream, the parameter must be
- -- a class-wide type of the entity to which the aspect applies.
-
- if From_Aspect_Specification (N)
- and then Class_Present (Parent (N))
- and then Is_Class_Wide_Type (Typ)
- then
- Typ := Etype (Typ);
- end if;
-
else
Typ := Etype (Subp);
end if;
-- Verify that the prefix of the attribute and the local name for
- -- the type of the formal match, or one is the class-wide of the
- -- other, in the case of a class-wide stream operation.
-
- if Base_Type (Typ) = Base_Type (Ent)
- or else (Is_Class_Wide_Type (Typ)
- and then Typ = Class_Wide_Type (Base_Type (Ent)))
- or else (Is_Class_Wide_Type (Ent)
- and then Ent = Class_Wide_Type (Base_Type (Typ)))
- then
- null;
- else
+ -- the type of the formal match.
+
+ if Base_Type (Typ) /= Base_Type (Ent) then
return False;
end if;
@@ -4389,7 +5257,13 @@ package body Sem_Ch13 is
else
Error_Msg_Name_1 := Attr;
- Error_Msg_N ("incorrect expression for% attribute", Expr);
+
+ if Is_Class_Wide_Type (Base_Type (Ent)) then
+ Error_Msg_N
+ ("incorrect expression for class-wide% attribute", Expr);
+ else
+ Error_Msg_N ("incorrect expression for% attribute", Expr);
+ end if;
end if;
end Analyze_Stream_TSS_Definition;
@@ -4401,8 +5275,11 @@ package body Sem_Ch13 is
Indexing_Found : Boolean := False;
procedure Check_Inherited_Indexing;
- -- For a derived type, check that no indexing aspect is specified
- -- for the type if it is also inherited
+ -- For a derived type, check that for a derived type, a specification
+ -- of an indexing aspect can only be confirming, i.e. uses the same
+ -- name as in the parent type.
+ -- AI12-0160: Verify that an indexing cannot be specified for
+ -- a derived type unless it is specified for the parent.
procedure Check_One_Function (Subp : Entity_Id);
-- Check one possible interpretation. Sets Indexing_Found True if a
@@ -4417,15 +5294,21 @@ package body Sem_Ch13 is
------------------------------
procedure Check_Inherited_Indexing is
- Inherited : Node_Id;
+ Inherited : Node_Id;
+ Other_Indexing : Node_Id;
begin
if Attr = Name_Constant_Indexing then
Inherited :=
Find_Aspect (Etype (Ent), Aspect_Constant_Indexing);
+ Other_Indexing :=
+ Find_Aspect (Etype (Ent), Aspect_Variable_Indexing);
+
else pragma Assert (Attr = Name_Variable_Indexing);
Inherited :=
Find_Aspect (Etype (Ent), Aspect_Variable_Indexing);
+ Other_Indexing :=
+ Find_Aspect (Etype (Ent), Aspect_Constant_Indexing);
end if;
if Present (Inherited) then
@@ -4438,6 +5321,16 @@ package body Sem_Ch13 is
elsif Aspect_Rep_Item (Inherited) = N then
null;
+ -- Check if this is a confirming specification. The name
+ -- may be overloaded between the parent operation and the
+ -- inherited one, so we check that the Chars fields match.
+
+ elsif Is_Entity_Name (Expression (Inherited))
+ and then Chars (Entity (Expression (Inherited))) =
+ Chars (Entity (Expression (N)))
+ then
+ Indexing_Found := True;
+
-- Indicate the operation that must be overridden, rather than
-- redefining the indexing aspect.
@@ -4448,6 +5341,15 @@ package body Sem_Ch13 is
("!override & instead",
N, Entity (Expression (Inherited)));
end if;
+
+ -- If not inherited and the parent has another indexing function
+ -- this is illegal, because it leads to inconsistent results in
+ -- class-wide calls.
+
+ elsif Present (Other_Indexing) then
+ Error_Msg_N
+ ("cannot specify indexing operation on derived type"
+ & " if not specified for parent", N);
end if;
end Check_Inherited_Indexing;
@@ -4470,7 +5372,12 @@ package body Sem_Ch13 is
-- Indexing function can't be declared elsewhere
Illegal_Indexing
- ("indexing function must be declared in scope of type&");
+ ("indexing function must be declared"
+ & " in scope of type&");
+ end if;
+
+ if Is_Derived_Type (Ent) then
+ Check_Inherited_Indexing;
end if;
return;
@@ -4561,9 +5468,10 @@ package body Sem_Ch13 is
end if;
else
- if Has_Implicit_Dereference (Ret_Type)
+ if Has_Implicit_Dereference (Ret_Type)
and then not
- Is_Access_Constant (Etype (First_Discriminant (Ret_Type)))
+ Is_Access_Constant
+ (Etype (Get_Reference_Discriminant (Ret_Type)))
then
Illegal_Indexing
("constant indexing must return an access to constant");
@@ -4578,7 +5486,7 @@ package body Sem_Ch13 is
end if;
end if;
- -- All checks succeeded.
+ -- All checks succeeded
Indexing_Found := True;
end Check_One_Function;
@@ -4672,7 +5580,7 @@ package body Sem_Ch13 is
-- False if any subsequent formal has no default expression
- Formal := Next_Formal (Formal);
+ Next_Formal (Formal);
while Present (Formal) loop
if No (Expression (Parent (Formal))) then
return False;
@@ -4853,6 +5761,13 @@ package body Sem_Ch13 is
Check_Restriction_No_Use_Of_Attribute (N);
+ if Get_Aspect_Id (Chars (N)) /= No_Aspect then
+ -- 6.1/3 No_Specification_of_Aspect: Identifies an aspect for which
+ -- no aspect_specification, attribute_definition_clause, or pragma
+ -- is given.
+ Check_Restriction_No_Specification_Of_Aspect (N);
+ end if;
+
-- Ignore some selected attributes in CodePeer mode since they are not
-- relevant in this context.
@@ -4906,6 +5821,7 @@ package body Sem_Ch13 is
when Attribute_External_Tag
| Attribute_Input
| Attribute_Output
+ | Attribute_Put_Image
| Attribute_Read
| Attribute_Simple_Storage_Pool
| Attribute_Storage_Pool
@@ -4936,20 +5852,17 @@ package body Sem_Ch13 is
return;
end if;
- -- Rep clause applies to full view of incomplete type or private type if
- -- we have one (if not, this is a premature use of the type). However,
- -- certain semantic checks need to be done on the specified entity (i.e.
- -- the private view), so we save it in Ent.
+ -- Rep clause applies to (underlying) full view of private or incomplete
+ -- type if we have one (if not, this is a premature use of the type).
+ -- However, some semantic checks need to be done on the specified entity
+ -- i.e. the private view, so we save it in Ent.
if Is_Private_Type (Ent)
and then Is_Derived_Type (Ent)
and then not Is_Tagged_Type (Ent)
and then No (Full_View (Ent))
+ and then No (Underlying_Full_View (Ent))
then
- -- If this is a private type whose completion is a derivation from
- -- another private type, there is no full view, and the attribute
- -- belongs to the type itself, not its underlying parent.
-
U_Ent := Ent;
elsif Ekind (Ent) = E_Incomplete_Type then
@@ -5085,7 +5998,7 @@ package body Sem_Ch13 is
if Ignore_Rep_Clauses then
Set_Address_Taken (U_Ent);
- if Ekind_In (U_Ent, E_Variable, E_Constant) then
+ if Ekind (U_Ent) in E_Variable | E_Constant then
Record_Rep_Item (U_Ent, N);
end if;
@@ -5164,7 +6077,7 @@ package body Sem_Ch13 is
-- Case of address clause for an object
- elsif Ekind_In (U_Ent, E_Constant, E_Variable) then
+ elsif Ekind (U_Ent) in E_Constant | E_Variable then
declare
Expr : constant Node_Id := Expression (N);
O_Ent : Entity_Id;
@@ -5226,10 +6139,10 @@ package body Sem_Ch13 is
(N, U_Ent, No_Uint, O_Ent, Off);
end if;
- -- If the overlay changes the storage order, mark the
- -- entity as being volatile to block any optimization
- -- for it since the construct is not really supported
- -- by the back end.
+ -- If the overlay changes the storage order, warn since
+ -- the construct is not really supported by the back end.
+ -- Also mark the entity as being volatile to block the
+ -- optimizer, even if there is no warranty on the result.
if (Is_Record_Type (Etype (U_Ent))
or else Is_Array_Type (Etype (U_Ent)))
@@ -5238,6 +6151,8 @@ package body Sem_Ch13 is
and then Reverse_Storage_Order (Etype (U_Ent)) /=
Reverse_Storage_Order (Etype (O_Ent))
then
+ Error_Msg_N
+ ("??overlay changes scalar storage order", Expr);
Set_Treat_As_Volatile (U_Ent);
end if;
@@ -5273,9 +6188,13 @@ package body Sem_Ch13 is
-- Issue an unconditional warning for a constant overlaying
-- a variable. For the reverse case, we will issue it only
-- if the variable is modified.
+ -- Within a generic unit an In_Parameter is a constant.
+ -- It can be instantiated with a variable, in which case
+ -- there will be a warning on the instance.
if Ekind (U_Ent) = E_Constant
and then Present (O_Ent)
+ and then Ekind (O_Ent) /= E_Generic_In_Parameter
and then not Overlays_Constant (U_Ent)
and then Address_Clause_Overlay_Warnings
then
@@ -5375,14 +6294,9 @@ package body Sem_Ch13 is
Set_Has_Alignment_Clause (U_Ent);
-- Tagged type case, check for attempt to set alignment to a
- -- value greater than Max_Align, and reset if so. This error
- -- is suppressed in ASIS mode to allow for different ASIS
- -- back ends or ASIS-based tools to query the illegal clause.
+ -- value greater than Max_Align, and reset if so.
- if Is_Tagged_Type (U_Ent)
- and then Align > Max_Align
- and then not ASIS_Mode
- then
+ if Is_Tagged_Type (U_Ent) and then Align > Max_Align then
Error_Msg_N
("alignment for & set to Maximum_Aligment??", Nam);
Set_Alignment (U_Ent, Max_Align);
@@ -5530,37 +6444,48 @@ package body Sem_Ch13 is
---------
when Attribute_CPU =>
+ pragma Assert (From_Aspect_Specification (N));
+ -- The parser forbids this clause in source code, so it must have
+ -- come from an aspect specification.
- -- CPU attribute definition clause not allowed except from aspect
- -- specification.
+ if not Is_Task_Type (U_Ent) then
+ Error_Msg_N ("CPU can only be defined for task", Nam);
- if From_Aspect_Specification (N) then
- if not Is_Task_Type (U_Ent) then
- Error_Msg_N ("CPU can only be defined for task", Nam);
-
- elsif Duplicate_Clause then
- null;
-
- else
- -- The expression must be analyzed in the special manner
- -- described in "Handling of Default and Per-Object
- -- Expressions" in sem.ads.
-
- -- The visibility to the components must be established
- -- and restored before and after analysis.
-
- Push_Type (U_Ent);
- Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range));
- Pop_Type (U_Ent);
+ elsif Duplicate_Clause then
+ null;
- if not Is_OK_Static_Expression (Expr) then
- Check_Restriction (Static_Priorities, Expr);
+ else
+ -- The expression must be analyzed in the special manner
+ -- described in "Handling of Default and Per-Object
+ -- Expressions" in sem.ads.
+
+ -- The visibility to the components must be established
+ -- and restored before and after analysis.
+
+ Push_Type (U_Ent);
+ Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range));
+ Pop_Type (U_Ent);
+
+ -- AI12-0117-1, "Restriction No_Tasks_Unassigned_To_CPU":
+ -- If the expression is static, and its value is
+ -- System.Multiprocessors.Not_A_Specific_CPU (i.e. zero) then
+ -- that's a violation of No_Tasks_Unassigned_To_CPU. It might
+ -- seem better to refer to Not_A_Specific_CPU here, but that
+ -- involves a lot of horsing around with Rtsfind, and this
+ -- value is not going to change, so it's better to hardwire
+ -- Uint_0.
+ --
+ -- AI12-0055-1, "All properties of a usage profile are defined
+ -- by pragmas": If the expression is nonstatic, that's a
+ -- violation of No_Dynamic_CPU_Assignment.
+
+ if Is_OK_Static_Expression (Expr) then
+ if Expr_Value (Expr) = Uint_0 then
+ Check_Restriction (No_Tasks_Unassigned_To_CPU, Expr);
end if;
+ else
+ Check_Restriction (No_Dynamic_CPU_Assignment, Expr);
end if;
-
- else
- Error_Msg_N
- ("attribute& cannot be set with definition clause", N);
end if;
----------------------
@@ -5624,36 +6549,30 @@ package body Sem_Ch13 is
------------------------
when Attribute_Dispatching_Domain =>
+ pragma Assert (From_Aspect_Specification (N));
+ -- The parser forbids this clause in source code, so it must have
+ -- come from an aspect specification.
- -- Dispatching_Domain attribute definition clause not allowed
- -- except from aspect specification.
-
- if From_Aspect_Specification (N) then
- if not Is_Task_Type (U_Ent) then
- Error_Msg_N
- ("Dispatching_Domain can only be defined for task", Nam);
-
- elsif Duplicate_Clause then
- null;
+ if not Is_Task_Type (U_Ent) then
+ Error_Msg_N
+ ("Dispatching_Domain can only be defined for task", Nam);
- else
- -- The expression must be analyzed in the special manner
- -- described in "Handling of Default and Per-Object
- -- Expressions" in sem.ads.
+ elsif Duplicate_Clause then
+ null;
- -- The visibility to the components must be restored
+ else
+ -- The expression must be analyzed in the special manner
+ -- described in "Handling of Default and Per-Object
+ -- Expressions" in sem.ads.
- Push_Type (U_Ent);
+ -- The visibility to the components must be restored
- Preanalyze_Spec_Expression
- (Expr, RTE (RE_Dispatching_Domain));
+ Push_Type (U_Ent);
- Pop_Type (U_Ent);
- end if;
+ Preanalyze_Spec_Expression
+ (Expr, RTE (RE_Dispatching_Domain));
- else
- Error_Msg_N
- ("attribute& cannot be set with definition clause", N);
+ Pop_Type (U_Ent);
end if;
------------------
@@ -5711,43 +6630,37 @@ package body Sem_Ch13 is
------------------------
when Attribute_Interrupt_Priority =>
+ pragma Assert (From_Aspect_Specification (N));
+ -- The parser forbids this clause in source code, so it must have
+ -- come from an aspect specification.
- -- Interrupt_Priority attribute definition clause not allowed
- -- except from aspect specification.
-
- if From_Aspect_Specification (N) then
- if not Is_Concurrent_Type (U_Ent) then
- Error_Msg_N
- ("Interrupt_Priority can only be defined for task and "
- & "protected object", Nam);
+ if not Is_Concurrent_Type (U_Ent) then
+ Error_Msg_N
+ ("Interrupt_Priority can only be defined for task and "
+ & "protected object", Nam);
- elsif Duplicate_Clause then
- null;
+ elsif Duplicate_Clause then
+ null;
- else
- -- The expression must be analyzed in the special manner
- -- described in "Handling of Default and Per-Object
- -- Expressions" in sem.ads.
+ else
+ -- The expression must be analyzed in the special manner
+ -- described in "Handling of Default and Per-Object
+ -- Expressions" in sem.ads.
- -- The visibility to the components must be restored
+ -- The visibility to the components must be restored
- Push_Type (U_Ent);
+ Push_Type (U_Ent);
- Preanalyze_Spec_Expression
- (Expr, RTE (RE_Interrupt_Priority));
+ Preanalyze_Spec_Expression
+ (Expr, RTE (RE_Interrupt_Priority));
- Pop_Type (U_Ent);
+ Pop_Type (U_Ent);
- -- Check the No_Task_At_Interrupt_Priority restriction
+ -- Check the No_Task_At_Interrupt_Priority restriction
- if Is_Task_Type (U_Ent) then
- Check_Restriction (No_Task_At_Interrupt_Priority, N);
- end if;
+ if Is_Task_Type (U_Ent) then
+ Check_Restriction (No_Task_At_Interrupt_Priority, N);
end if;
-
- else
- Error_Msg_N
- ("attribute& cannot be set with definition clause", N);
end if;
--------------
@@ -5788,6 +6701,7 @@ package body Sem_Ch13 is
or else not Is_Type (Entity (Expr))
then
Error_Msg_N ("aspect Iterator_Element must be a type", Expr);
+ return;
end if;
-------------------
@@ -5816,11 +6730,7 @@ package body Sem_Ch13 is
elsif Radix = 10 then
Set_Machine_Radix_10 (U_Ent);
- -- The following error is suppressed in ASIS mode to allow for
- -- different ASIS back ends or ASIS-based tools to query the
- -- illegal clause.
-
- elsif not ASIS_Mode then
+ else
Error_Msg_N ("machine radix value must be 2 or 10", Expr);
end if;
end if;
@@ -5848,14 +6758,7 @@ package body Sem_Ch13 is
else
Check_Size (Expr, U_Ent, Size, Biased);
- -- The following errors are suppressed in ASIS mode to allow
- -- for different ASIS back ends or ASIS-based tools to query
- -- the illegal clause.
-
- if ASIS_Mode then
- null;
-
- elsif Size <= 0 then
+ if Size <= 0 then
Error_Msg_N ("Object_Size must be positive", Expr);
elsif Is_Scalar_Type (U_Ent) then
@@ -5926,6 +6829,13 @@ package body Sem_Ch13 is
("attribute& cannot be set with definition clause", N);
end if;
+ ---------------
+ -- Put_Image --
+ ---------------
+
+ when Attribute_Put_Image =>
+ Analyze_Put_Image_TSS_Definition;
+
----------
-- Read --
----------
@@ -6065,16 +6975,11 @@ package body Sem_Ch13 is
-- For objects, set Esize only
else
- -- The following error is suppressed in ASIS mode to allow
- -- for different ASIS back ends or ASIS-based tools to query
- -- the illegal clause.
-
if Is_Elementary_Type (Etyp)
and then Size /= System_Storage_Unit
and then Size /= System_Storage_Unit * 2
and then Size /= System_Storage_Unit * 4
and then Size /= System_Storage_Unit * 8
- and then not ASIS_Mode
then
Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8;
@@ -6154,6 +7059,121 @@ package body Sem_Ch13 is
Pool : Entity_Id;
T : Entity_Id;
+ procedure Associate_Storage_Pool
+ (Ent : Entity_Id; Pool : Entity_Id);
+ -- Associate Pool to Ent and perform legality checks on subpools
+
+ ----------------------------
+ -- Associate_Storage_Pool --
+ ----------------------------
+
+ procedure Associate_Storage_Pool
+ (Ent : Entity_Id; Pool : Entity_Id)
+ is
+ function Object_From (Pool : Entity_Id) return Entity_Id;
+ -- Return the entity of which Pool is a part of
+
+ -----------------
+ -- Object_From --
+ -----------------
+
+ function Object_From
+ (Pool : Entity_Id) return Entity_Id
+ is
+ N : Node_Id := Pool;
+ begin
+ if Present (Renamed_Object (Pool)) then
+ N := Renamed_Object (Pool);
+ end if;
+
+ while Present (N) loop
+ case Nkind (N) is
+ when N_Defining_Identifier =>
+ return N;
+
+ when N_Identifier | N_Expanded_Name =>
+ return Entity (N);
+
+ when N_Indexed_Component | N_Selected_Component |
+ N_Explicit_Dereference
+ =>
+ N := Prefix (N);
+
+ when N_Type_Conversion =>
+ N := Expression (N);
+
+ when others =>
+ -- ??? we probably should handle more cases but
+ -- this is good enough in practice for this check
+ -- on a corner case.
+
+ return Empty;
+ end case;
+ end loop;
+
+ return Empty;
+ end Object_From;
+
+ Obj : Entity_Id;
+
+ begin
+ Set_Associated_Storage_Pool (Ent, Pool);
+
+ -- Check RM 13.11.4(22-23/3): a specification of a storage pool
+ -- is illegal if the storage pool supports subpools and:
+ -- (A) The access type is a general access type.
+ -- (B) The access type is statically deeper than the storage
+ -- pool object;
+ -- (C) The storage pool object is a part of a formal parameter;
+ -- (D) The storage pool object is a part of the dereference of
+ -- a non-library level general access type;
+
+ if Ada_Version >= Ada_2012
+ and then RTU_Loaded (System_Storage_Pools_Subpools)
+ and then
+ Is_Ancestor (RTE (RE_Root_Storage_Pool_With_Subpools),
+ Etype (Pool))
+ then
+ -- check (A)
+
+ if Ekind (Etype (Ent)) = E_General_Access_Type then
+ Error_Msg_N
+ ("subpool cannot be used on general access type", Ent);
+ end if;
+
+ -- check (B)
+
+ if Type_Access_Level (Ent) > Object_Access_Level (Pool) then
+ Error_Msg_N
+ ("subpool access type has deeper accessibility "
+ & "level than pool", Ent);
+ return;
+ end if;
+
+ Obj := Object_From (Pool);
+
+ -- check (C)
+
+ if Present (Obj) and then Ekind (Obj) in Formal_Kind then
+ Error_Msg_N
+ ("subpool cannot be part of a parameter", Ent);
+ return;
+ end if;
+
+ -- check (D)
+
+ if Present (Obj)
+ and then Ekind (Etype (Obj)) = E_General_Access_Type
+ and then not Is_Library_Level_Entity (Etype (Obj))
+ then
+ Error_Msg_N
+ ("subpool cannot be part of the dereference of a " &
+ "nested general access type", Ent);
+ return;
+ end if;
+ end if;
+ end Associate_Storage_Pool;
+
begin
if Ekind (U_Ent) = E_Access_Subprogram_Type then
Error_Msg_N
@@ -6161,7 +7181,7 @@ package body Sem_Ch13 is
Nam);
return;
- elsif not Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type)
+ elsif Ekind (U_Ent) not in E_Access_Type | E_General_Access_Type
then
Error_Msg_N
("storage pool can only be given for access types", Nam);
@@ -6241,6 +7261,12 @@ package body Sem_Ch13 is
return;
end if;
+ -- Validate_Remote_Access_To_Class_Wide_Type for attribute
+ -- Storage_Pool since this attribute cannot be defined for such
+ -- types (RM E.2.2(17)).
+
+ Validate_Remote_Access_To_Class_Wide_Type (N);
+
-- If the argument is a name that is not an entity name, then
-- we construct a renaming operation to define an entity of
-- type storage pool.
@@ -6271,7 +7297,7 @@ package body Sem_Ch13 is
end if;
Analyze (Rnode);
- Set_Associated_Storage_Pool (U_Ent, Pool);
+ Associate_Storage_Pool (U_Ent, Pool);
end;
elsif Is_Entity_Name (Expr) then
@@ -6293,14 +7319,14 @@ package body Sem_Ch13 is
Pool := Entity (Expression (Renamed_Object (Pool)));
end if;
- Set_Associated_Storage_Pool (U_Ent, Pool);
+ Associate_Storage_Pool (U_Ent, Pool);
elsif Nkind (Expr) = N_Type_Conversion
and then Is_Entity_Name (Expression (Expr))
and then Nkind (Original_Node (Expr)) = N_Attribute_Reference
then
Pool := Entity (Expression (Expr));
- Set_Associated_Storage_Pool (U_Ent, Pool);
+ Associate_Storage_Pool (U_Ent, Pool);
else
Error_Msg_N ("incorrect reference to a Storage Pool", Expr);
@@ -6350,6 +7376,12 @@ package body Sem_Ch13 is
null;
else
+ -- Validate_Remote_Access_To_Class_Wide_Type for attribute
+ -- Storage_Size since this attribute cannot be defined for such
+ -- types (RM E.2.2(17)).
+
+ Validate_Remote_Access_To_Class_Wide_Type (N);
+
Analyze_And_Resolve (Expr, Any_Integer);
if Is_Access_Type (U_Ent) then
@@ -6396,29 +7428,21 @@ package body Sem_Ch13 is
null;
elsif Is_Elementary_Type (U_Ent) then
-
- -- The following errors are suppressed in ASIS mode to allow
- -- for different ASIS back ends or ASIS-based tools to query
- -- the illegal clause.
-
- if ASIS_Mode then
- null;
-
- elsif Size /= System_Storage_Unit
+ if Size /= System_Storage_Unit
and then Size /= System_Storage_Unit * 2
+ and then Size /= System_Storage_Unit * 3
and then Size /= System_Storage_Unit * 4
and then Size /= System_Storage_Unit * 8
then
- Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
Error_Msg_N
- ("stream size for elementary type must be a power of 2 "
- & "and at least ^", N);
+ ("stream size for elementary type must be 8, 16, 24, " &
+ "32 or 64", N);
elsif RM_Size (U_Ent) > Size then
Error_Msg_Uint_1 := RM_Size (U_Ent);
Error_Msg_N
- ("stream size for elementary type must be a power of 2 "
- & "and at least ^", N);
+ ("stream size for elementary type must be 8, 16, 24, " &
+ "32 or 64 and at least ^", N);
end if;
Set_Has_Stream_Size_Clause (U_Ent);
@@ -6560,10 +7584,10 @@ package body Sem_Ch13 is
while Present (Decl) loop
DeclO := Original_Node (Decl);
if Comes_From_Source (DeclO)
- and not Nkind_In (DeclO, N_Pragma,
- N_Use_Package_Clause,
- N_Use_Type_Clause,
- N_Implicit_Label_Declaration)
+ and Nkind (DeclO) not in N_Pragma
+ | N_Use_Package_Clause
+ | N_Use_Type_Clause
+ | N_Implicit_Label_Declaration
then
Error_Msg_N
("this declaration not allowed in machine code subprogram",
@@ -6592,9 +7616,8 @@ package body Sem_Ch13 is
null;
elsif Comes_From_Source (StmtO)
- and then not Nkind_In (StmtO, N_Pragma,
- N_Label,
- N_Code_Statement)
+ and then Nkind (StmtO) not in
+ N_Pragma | N_Label | N_Code_Statement
then
Error_Msg_N
("this statement is not allowed in machine code subprogram",
@@ -7064,13 +8087,9 @@ package body Sem_Ch13 is
if Present (Mod_Clause (N)) then
declare
- Loc : constant Source_Ptr := Sloc (N);
- M : constant Node_Id := Mod_Clause (N);
- P : constant List_Id := Pragmas_Before (M);
- AtM_Nod : Node_Id;
-
- Mod_Val : Uint;
- pragma Warnings (Off, Mod_Val);
+ M : constant Node_Id := Mod_Clause (N);
+ P : constant List_Id := Pragmas_Before (M);
+ Ignore : Uint;
begin
Check_Restriction (No_Obsolescent_Features, Mod_Clause (N));
@@ -7086,31 +8105,9 @@ package body Sem_Ch13 is
Analyze_List (P);
end if;
- -- In ASIS_Mode mode, expansion is disabled, but we must convert
- -- the Mod clause into an alignment clause anyway, so that the
- -- back end can compute and back-annotate properly the size and
- -- alignment of types that may include this record.
-
- -- This seems dubious, this destroys the source tree in a manner
- -- not detectable by ASIS ???
+ -- Get the alignment value to perform error checking
- if Operating_Mode = Check_Semantics and then ASIS_Mode then
- AtM_Nod :=
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Occurrence_Of (Base_Type (Rectype), Loc),
- Chars => Name_Alignment,
- Expression => Relocate_Node (Expression (M)));
-
- Set_From_At_Mod (AtM_Nod);
- Insert_After (N, AtM_Nod);
- Mod_Val := Get_Alignment_Value (Expression (AtM_Nod));
- Set_Mod_Clause (N, Empty);
-
- else
- -- Get the alignment value to perform error checking
-
- Mod_Val := Get_Alignment_Value (Expression (M));
- end if;
+ Ignore := Get_Alignment_Value (Expression (M));
end;
end if;
@@ -7295,8 +8292,10 @@ package body Sem_Ch13 is
if Has_Size_Clause (Rectype)
and then RM_Size (Rectype) <= Lbit
then
- Error_Msg_N
- ("bit number out of range of specified size",
+ Error_Msg_Uint_1 := RM_Size (Rectype);
+ Error_Msg_Uint_2 := Lbit + 1;
+ Error_Msg_N ("bit number out of range of specified "
+ & "size (expected ^, got ^)",
Last_Bit (CC));
else
Set_Component_Clause (Comp, CC);
@@ -8113,6 +9112,25 @@ package body Sem_Ch13 is
return RList'(1 => REnt'(SLo, SHi));
end if;
+ -- Others case
+
+ elsif Nkind (N) = N_Others_Choice then
+ declare
+ Choices : constant List_Id := Others_Discrete_Choices (N);
+ Choice : Node_Id;
+ Range_List : RList (1 .. List_Length (Choices));
+
+ begin
+ Choice := First (Choices);
+
+ for J in Range_List'Range loop
+ Range_List (J) := REnt'(Lo_Val (Choice), Hi_Val (Choice));
+ Next (Choice);
+ end loop;
+
+ return Range_List;
+ end;
+
-- Static expression case
elsif Is_OK_Static_Expression (N) then
@@ -8121,7 +9139,7 @@ package body Sem_Ch13 is
-- Identifier (other than static expression) case
- else pragma Assert (Nkind (N) = N_Identifier);
+ else pragma Assert (Nkind (N) in N_Expanded_Name | N_Identifier);
-- Type case
@@ -8649,11 +9667,6 @@ package body Sem_Ch13 is
Set_Etype (N, Typ);
Set_Entity (N, Object_Entity);
-
- -- We want to treat the node as if it comes from source, so
- -- that ASIS will not ignore it.
-
- Set_Comes_From_Source (N, True);
end Replace_Type_Reference;
-- Local variables
@@ -8672,6 +9685,7 @@ package body Sem_Ch13 is
-- Extract the arguments of the pragma. The expression itself
-- is copied for use in the predicate function, to preserve the
-- original version for ASIS use.
+ -- Is this still needed???
Arg1 := First (Pragma_Argument_Associations (Prag));
Arg2 := Next (Arg1);
@@ -8837,6 +9851,9 @@ package body Sem_Ch13 is
-- Add predicates for ancestor if present. These must come before the
-- ones for the current type, as required by AI12-0071-1.
+ -- Looks like predicates aren't added for case of inheriting from
+ -- multiple progenitors???
+
declare
Atyp : Entity_Id;
begin
@@ -8928,12 +9945,6 @@ package body Sem_Ch13 is
Set_Ekind (SIdB, E_Function);
Set_Is_Predicate_Function (SIdB);
- -- The predicate function is shared between views of a type
-
- if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
- Set_Predicate_Function (Full_View (Typ), SId);
- end if;
-
-- Build function body
Spec :=
@@ -8987,11 +9998,10 @@ package body Sem_Ch13 is
-------------------------------------
function Reset_Quantified_Variable_Scope
- (N : Node_Id) return Traverse_Result
- is
+ (N : Node_Id) return Traverse_Result is
begin
- if Nkind_In (N, N_Iterator_Specification,
- N_Loop_Parameter_Specification)
+ if Nkind (N) in N_Iterator_Specification
+ | N_Loop_Parameter_Specification
then
Set_Scope (Defining_Identifier (N),
Predicate_Function (Typ));
@@ -9047,6 +10057,18 @@ package body Sem_Ch13 is
FDecl : Node_Id;
BTemp : Entity_Id;
+ CRec_Typ : Entity_Id;
+ -- The corresponding record type of Full_Typ
+
+ Full_Typ : Entity_Id;
+ -- The full view of Typ
+
+ Priv_Typ : Entity_Id;
+ -- The partial view of Typ
+
+ UFull_Typ : Entity_Id;
+ -- The underlying full view of Full_Typ
+
begin
-- Mark any raise expressions for special expansion
@@ -9058,11 +10080,16 @@ package body Sem_Ch13 is
Set_Is_Predicate_Function_M (SId);
Set_Predicate_Function_M (Typ, SId);
- -- The predicate function is shared between views of a type
+ -- Obtain all views of the input type
- if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
- Set_Predicate_Function_M (Full_View (Typ), SId);
- end if;
+ Get_Views (Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ);
+
+ -- Associate the predicate function with all views
+
+ Propagate_Predicate_Attributes (Priv_Typ, From_Typ => Typ);
+ Propagate_Predicate_Attributes (Full_Typ, From_Typ => Typ);
+ Propagate_Predicate_Attributes (UFull_Typ, From_Typ => Typ);
+ Propagate_Predicate_Attributes (CRec_Typ, From_Typ => Typ);
Spec :=
Make_Function_Specification (Loc,
@@ -9242,6 +10269,18 @@ package body Sem_Ch13 is
Func_Id : Entity_Id;
Spec : Node_Id;
+ CRec_Typ : Entity_Id;
+ -- The corresponding record type of Full_Typ
+
+ Full_Typ : Entity_Id;
+ -- The full view of Typ
+
+ Priv_Typ : Entity_Id;
+ -- The partial view of Typ
+
+ UFull_Typ : Entity_Id;
+ -- The underlying full view of Full_Typ
+
begin
-- The related type may be subject to pragma Ghost. Set the mode now to
-- ensure that the predicate functions are properly marked as Ghost.
@@ -9252,6 +10291,12 @@ package body Sem_Ch13 is
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "Predicate"));
+ Set_Ekind (Func_Id, E_Function);
+ Set_Etype (Func_Id, Standard_Boolean);
+ Set_Is_Internal (Func_Id);
+ Set_Is_Predicate_Function (Func_Id);
+ Set_Predicate_Function (Typ, Func_Id);
+
-- The predicate function requires debug info when the predicates are
-- subject to Source Coverage Obligations.
@@ -9259,6 +10304,17 @@ package body Sem_Ch13 is
Set_Debug_Info_Needed (Func_Id);
end if;
+ -- Obtain all views of the input type
+
+ Get_Views (Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ);
+
+ -- Associate the predicate function and various flags with all views
+
+ Propagate_Predicate_Attributes (Priv_Typ, From_Typ => Typ);
+ Propagate_Predicate_Attributes (Full_Typ, From_Typ => Typ);
+ Propagate_Predicate_Attributes (UFull_Typ, From_Typ => Typ);
+ Propagate_Predicate_Attributes (CRec_Typ, From_Typ => Typ);
+
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Id,
@@ -9271,12 +10327,6 @@ package body Sem_Ch13 is
Func_Decl := Make_Subprogram_Declaration (Loc, Specification => Spec);
- Set_Ekind (Func_Id, E_Function);
- Set_Etype (Func_Id, Standard_Boolean);
- Set_Is_Internal (Func_Id);
- Set_Is_Predicate_Function (Func_Id);
- Set_Predicate_Function (Typ, Func_Id);
-
Insert_After (Parent (Typ), Func_Decl);
Analyze (Func_Decl);
@@ -9376,16 +10426,16 @@ package body Sem_Ch13 is
elsif A_Id = Aspect_Synchronization then
return;
- -- Case of stream attributes, just have to compare entities. However,
- -- the expression is just a name (possibly overloaded), and there may
- -- be stream operations declared for unrelated types, so we just need
- -- to verify that one of these interpretations is the one available at
- -- at the freeze point.
+ -- Case of stream attributes and Put_Image, just have to compare
+ -- entities. However, the expression is just a possibly-overloaded
+ -- name, so we need to verify that one of these interpretations is
+ -- the one available at at the freeze point.
elsif A_Id = Aspect_Input or else
A_Id = Aspect_Output or else
A_Id = Aspect_Read or else
- A_Id = Aspect_Write
+ A_Id = Aspect_Write or else
+ A_Id = Aspect_Put_Image
then
Analyze (End_Decl_Expr);
Check_Overloaded_Name;
@@ -9393,7 +10443,10 @@ package body Sem_Ch13 is
elsif A_Id = Aspect_Variable_Indexing or else
A_Id = Aspect_Constant_Indexing or else
A_Id = Aspect_Default_Iterator or else
- A_Id = Aspect_Iterator_Element
+ A_Id = Aspect_Iterator_Element or else
+ A_Id = Aspect_Integer_Literal or else
+ A_Id = Aspect_Real_Literal or else
+ A_Id = Aspect_String_Literal
then
-- Make type unfrozen before analysis, to prevent spurious errors
-- about late attributes.
@@ -9484,6 +10537,8 @@ package body Sem_Ch13 is
Preanalyze_Spec_Expression (End_Decl_Expr, T);
Pop_Type (Ent);
+ elsif A_Id = Aspect_Predicate_Failure then
+ Preanalyze_Spec_Expression (End_Decl_Expr, Standard_String);
else
Preanalyze_Spec_Expression (End_Decl_Expr, T);
end if;
@@ -9514,6 +10569,9 @@ package body Sem_Ch13 is
Ident : constant Node_Id := Identifier (ASN);
-- Identifier (use Entity field to save expression)
+ Expr : constant Node_Id := Expression (ASN);
+ -- For cases where using Entity (Identifier) doesn't work
+
A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident));
T : Entity_Id := Empty;
@@ -9641,6 +10699,7 @@ package body Sem_Ch13 is
when Aspect_Input
| Aspect_Output
+ | Aspect_Put_Image
| Aspect_Read
| Aspect_Suppress
| Aspect_Unsuppress
@@ -9661,6 +10720,20 @@ package body Sem_Ch13 is
Analyze (Expression (ASN));
return;
+ -- Same for Literal aspects, where the expression is a function
+ -- name. Legality rules are checked separately. Use Expr to avoid
+ -- losing track of the previous resolution of Expression.
+
+ when Aspect_Integer_Literal
+ | Aspect_Real_Literal
+ | Aspect_String_Literal
+ =>
+ Set_Entity (Expression (ASN), Entity (Expr));
+ Set_Etype (Expression (ASN), Etype (Expr));
+ Set_Is_Overloaded (Expression (ASN), False);
+ Analyze (Expression (ASN));
+ return;
+
-- Ditto for Iterable, legality checks in Validate_Iterable_Aspect.
when Aspect_Iterable =>
@@ -9692,6 +10765,10 @@ package body Sem_Ch13 is
return;
+ when Aspect_Aggregate =>
+ Resolve_Aspect_Aggregate (Entity (ASN), Expr);
+ return;
+
-- Invariant/Predicate take boolean expressions
when Aspect_Dynamic_Predicate
@@ -9739,6 +10816,7 @@ package body Sem_Ch13 is
| Aspect_Refined_Global
| Aspect_Refined_Post
| Aspect_Refined_State
+ | Aspect_Relaxed_Initialization
| Aspect_SPARK_Mode
| Aspect_Test_Case
| Aspect_Unimplemented
@@ -9901,12 +10979,12 @@ package body Sem_Ch13 is
-- Otherwise look at the identifier and see if it is OK
- if Ekind_In (Ent, E_Named_Integer, E_Named_Real)
+ if Ekind (Ent) in E_Named_Integer | E_Named_Real
or else Is_Type (Ent)
then
return;
- elsif Ekind_In (Ent, E_Constant, E_In_Parameter) then
+ elsif Ekind (Ent) in E_Constant | E_In_Parameter then
-- This is the case where we must have Ent defined before
-- U_Ent. Clearly if they are in different units this
@@ -9988,10 +11066,10 @@ package body Sem_Ch13 is
Check_Expr_Constants (Prefix (Nod));
when N_Attribute_Reference =>
- if Nam_In (Attribute_Name (Nod), Name_Address,
- Name_Access,
- Name_Unchecked_Access,
- Name_Unrestricted_Access)
+ if Attribute_Name (Nod) in Name_Address
+ | Name_Access
+ | Name_Unchecked_Access
+ | Name_Unrestricted_Access
then
Check_At_Constant_Address (Prefix (Nod));
@@ -10136,8 +11214,8 @@ package body Sem_Ch13 is
Rectype : Entity_Id;
Fent : Entity_Id;
CC : Node_Id;
- Fbit : Uint;
- Lbit : Uint;
+ Fbit : Uint := No_Uint;
+ Lbit : Uint := No_Uint;
Hbit : Uint := Uint_0;
Comp : Entity_Id;
Pcomp : Entity_Id;
@@ -10210,7 +11288,7 @@ package body Sem_Ch13 is
-- record, both at location zero. This seems a bit strange, but
-- it seems to happen in some circumstances, perhaps on an error.
- if Nam_In (Chars (C1_Ent), Name_uTag, Name_uTag) then
+ if Chars (C1_Ent) = Name_uTag then
return;
end if;
@@ -10277,7 +11355,7 @@ package body Sem_Ch13 is
end if;
Prev_Bit_Offset := Component_Bit_Offset (Comp);
- Comp := Next_Component (Comp);
+ Next_Component (Comp);
end if;
Next (Clause);
@@ -10485,6 +11563,7 @@ package body Sem_Ch13 is
Nbit := Sbit;
for J in 1 .. Ncomps loop
CEnt := Comps (J);
+ pragma Annotate (CodePeer, Modified, CEnt);
declare
CBO : constant Uint := Component_Bit_Offset (CEnt);
@@ -10604,7 +11683,7 @@ package body Sem_Ch13 is
Parent_Last_Bit := UI_From_Int (System_Address_Size - 1);
Pcomp := First_Entity (Tagged_Parent);
while Present (Pcomp) loop
- if Ekind_In (Pcomp, E_Discriminant, E_Component) then
+ if Ekind (Pcomp) in E_Discriminant | E_Component then
if Component_Bit_Offset (Pcomp) /= No_Uint
and then Known_Static_Esize (Pcomp)
then
@@ -10686,8 +11765,10 @@ package body Sem_Ch13 is
if Has_Size_Clause (Rectype)
and then RM_Size (Rectype) <= Lbit
then
- Error_Msg_N
- ("bit number out of range of specified size",
+ Error_Msg_Uint_1 := RM_Size (Rectype);
+ Error_Msg_Uint_2 := Lbit + 1;
+ Error_Msg_N ("bit number out of range of specified "
+ & "size (expected ^, got ^)",
Last_Bit (CC));
-- Check for overlap with tag or parent component
@@ -10834,7 +11915,7 @@ package body Sem_Ch13 is
-- This latter test is repeated recursively up the variant tree.
Main_Component_Loop : while Present (C1_Ent) loop
- if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then
+ if Ekind (C1_Ent) not in E_Component | E_Discriminant then
goto Continue_Main_Component_Loop;
end if;
@@ -10862,15 +11943,19 @@ package body Sem_Ch13 is
end if;
-- Outer level of record definition, check discriminants
+ -- but be careful not to flag a non-girder discriminant
+ -- and the girder discriminant it renames as overlapping.
- if Nkind_In (Clist, N_Full_Type_Declaration,
- N_Private_Type_Declaration)
+ if Nkind (Clist) in N_Full_Type_Declaration
+ | N_Private_Type_Declaration
then
if Has_Discriminants (Defining_Identifier (Clist)) then
C2_Ent :=
First_Discriminant (Defining_Identifier (Clist));
while Present (C2_Ent) loop
- exit when C1_Ent = C2_Ent;
+ exit when
+ Original_Record_Component (C1_Ent) =
+ Original_Record_Component (C2_Ent);
Check_Component_Overlap (C1_Ent, C2_Ent);
Next_Discriminant (C2_Ent);
end loop;
@@ -11007,13 +12092,8 @@ package body Sem_Ch13 is
procedure Size_Too_Small_Error (Min_Siz : Uint) is
begin
- -- This error is suppressed in ASIS mode to allow for different ASIS
- -- back ends or ASIS-based tools to query the illegal clause.
-
- if not ASIS_Mode then
- Error_Msg_Uint_1 := Min_Siz;
- Error_Msg_NE (Size_Too_Small_Message, N, T);
- end if;
+ Error_Msg_Uint_1 := Min_Siz;
+ Error_Msg_NE (Size_Too_Small_Message, N, T);
end Size_Too_Small_Error;
-- Local variables
@@ -11222,7 +12302,7 @@ package body Sem_Ch13 is
-- The subprogram is inherited (implicitly declared), it does not
-- override and does not cover a primitive of an interface.
- if Ekind_In (Subp_Id, E_Function, E_Procedure)
+ if Ekind (Subp_Id) in E_Function | E_Procedure
and then Present (Alias (Subp_Id))
and then No (Interface_Alias (Subp_Id))
and then No (Overridden_Operation (Subp_Id))
@@ -11292,11 +12372,9 @@ package body Sem_Ch13 is
-- the primitives of the interfaces with the primitives that cover them.
-- Note: These entities were originally generated only when generating
-- code because their main purpose was to provide support to initialize
- -- the secondary dispatch tables. They are now generated also when
- -- compiling with no code generation to provide ASIS the relationship
- -- between interface primitives and tagged type primitives. They are
- -- also used to locate primitives covering interfaces when processing
- -- generics (see Derive_Subprograms).
+ -- the secondary dispatch tables. They are also used to locate
+ -- primitives covering interfaces when processing generics (see
+ -- Derive_Subprograms).
-- This is not needed in the generic case
@@ -11433,16 +12511,16 @@ package body Sem_Ch13 is
Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
-- If we have a type with predicates, build predicate function. This is
- -- not needed in the generic case, nor within TSS subprograms and other
- -- predefined primitives. For a derived type, ensure that the parent
- -- type is already frozen so that its predicate function has been
+ -- not needed in the generic case, nor within e.g. TSS subprograms and
+ -- other predefined primitives. For a derived type, ensure that the
+ -- parent type is already frozen so that its predicate function has been
-- constructed already. This is necessary if the parent is declared
-- in a nested package and its own freeze point has not been reached.
if Is_Type (E)
and then Nongeneric_Case
- and then not Within_Internal_Subprogram
and then Has_Predicates (E)
+ and then Predicate_Check_In_Scope (N)
then
declare
Atyp : constant Entity_Id := Nearest_Ancestor (E);
@@ -11578,7 +12656,7 @@ package body Sem_Ch13 is
-- for aggregates, requires the expanded list of choices.
-- If the expander is not active, then we can't just clobber
- -- the list since it would invalidate the ASIS -gnatct tree.
+ -- the list since it would invalidate the tree.
-- So we have to rewrite the variant part with a Rewrite
-- call that replaces it with a copy and clobber the copy.
@@ -11649,7 +12727,7 @@ package body Sem_Ch13 is
-- to the others choice (it's the list we're replacing).
-- We only want to do this if the expander is active, since
- -- we do not want to clobber the ASIS tree.
+ -- we do not want to clobber the tree.
if Expander_Active then
declare
@@ -11687,14 +12765,7 @@ package body Sem_Ch13 is
return No_Uint;
elsif Align < 0 then
-
- -- This error is suppressed in ASIS mode to allow for different ASIS
- -- back ends or ASIS-based tools to query the illegal clause.
-
- if not ASIS_Mode then
- Error_Msg_N ("alignment value must be positive", Expr);
- end if;
-
+ Error_Msg_N ("alignment value must be positive", Expr);
return No_Uint;
-- If Alignment is specified to be 0, we treat it the same as 1
@@ -11711,15 +12782,7 @@ package body Sem_Ch13 is
exit when M = Align;
if M > Align then
-
- -- This error is suppressed in ASIS mode to allow for
- -- different ASIS back ends or ASIS-based tools to query the
- -- illegal clause.
-
- if not ASIS_Mode then
- Error_Msg_N ("alignment value must be power of 2", Expr);
- end if;
-
+ Error_Msg_N ("alignment value must be power of 2", Expr);
return No_Uint;
end if;
end;
@@ -11729,6 +12792,234 @@ package body Sem_Ch13 is
end if;
end Get_Alignment_Value;
+ -----------------------------------
+ -- Has_Compatible_Representation --
+ -----------------------------------
+
+ function Has_Compatible_Representation
+ (Target_Type, Operand_Type : Entity_Id) return Boolean
+ is
+ T1 : constant Entity_Id := Underlying_Type (Target_Type);
+ T2 : constant Entity_Id := Underlying_Type (Operand_Type);
+
+ begin
+ -- A quick check, if base types are the same, then we definitely have
+ -- the same representation, because the subtype specific representation
+ -- attributes (Size and Alignment) do not affect representation from
+ -- the point of view of this test.
+
+ if Base_Type (T1) = Base_Type (T2) then
+ return True;
+
+ elsif Is_Private_Type (Base_Type (T2))
+ and then Base_Type (T1) = Full_View (Base_Type (T2))
+ then
+ return True;
+
+ -- If T2 is a generic actual it is declared as a subtype, so
+ -- check against its base type.
+
+ elsif Is_Generic_Actual_Type (T1)
+ and then Has_Compatible_Representation (Base_Type (T1), T2)
+ then
+ return True;
+ end if;
+
+ -- Tagged types always have the same representation, because it is not
+ -- possible to specify different representations for common fields.
+
+ if Is_Tagged_Type (T1) then
+ return True;
+ end if;
+
+ -- Representations are definitely different if conventions differ
+
+ if Convention (T1) /= Convention (T2) then
+ return False;
+ end if;
+
+ -- Representations are different if component alignments or scalar
+ -- storage orders differ.
+
+ if (Is_Record_Type (T1) or else Is_Array_Type (T1))
+ and then
+ (Is_Record_Type (T2) or else Is_Array_Type (T2))
+ and then
+ (Component_Alignment (T1) /= Component_Alignment (T2)
+ or else Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2))
+ then
+ return False;
+ end if;
+
+ -- For arrays, the only real issue is component size. If we know the
+ -- component size for both arrays, and it is the same, then that's
+ -- good enough to know we don't have a change of representation.
+
+ if Is_Array_Type (T1) then
+
+ -- In a view conversion, if the target type is an array type having
+ -- aliased components and the operand type is an array type having
+ -- unaliased components, then a new object is created (4.6(58.3/4)).
+
+ if Has_Aliased_Components (T1)
+ and then not Has_Aliased_Components (T2)
+ then
+ return False;
+ end if;
+
+ if Known_Component_Size (T1)
+ and then Known_Component_Size (T2)
+ and then Component_Size (T1) = Component_Size (T2)
+ then
+ return True;
+ end if;
+ end if;
+
+ -- For records, representations are different if reorderings differ
+
+ if Is_Record_Type (T1)
+ and then Is_Record_Type (T2)
+ and then No_Reordering (T1) /= No_Reordering (T2)
+ then
+ return False;
+ end if;
+
+ -- Types definitely have same representation if neither has non-standard
+ -- representation since default representations are always consistent.
+ -- If only one has non-standard representation, and the other does not,
+ -- then we consider that they do not have the same representation. They
+ -- might, but there is no way of telling early enough.
+
+ if Has_Non_Standard_Rep (T1) then
+ if not Has_Non_Standard_Rep (T2) then
+ return False;
+ end if;
+ else
+ return not Has_Non_Standard_Rep (T2);
+ end if;
+
+ -- Here the two types both have non-standard representation, and we need
+ -- to determine if they have the same non-standard representation.
+
+ -- For arrays, we simply need to test if the component sizes are the
+ -- same. Pragma Pack is reflected in modified component sizes, so this
+ -- check also deals with pragma Pack.
+
+ if Is_Array_Type (T1) then
+ return Component_Size (T1) = Component_Size (T2);
+
+ -- Case of record types
+
+ elsif Is_Record_Type (T1) then
+
+ -- Packed status must conform
+
+ if Is_Packed (T1) /= Is_Packed (T2) then
+ return False;
+
+ -- Otherwise we must check components. Typ2 maybe a constrained
+ -- subtype with fewer components, so we compare the components
+ -- of the base types.
+
+ else
+ Record_Case : declare
+ CD1, CD2 : Entity_Id;
+
+ function Same_Rep return Boolean;
+ -- CD1 and CD2 are either components or discriminants. This
+ -- function tests whether they have the same representation.
+
+ --------------
+ -- Same_Rep --
+ --------------
+
+ function Same_Rep return Boolean is
+ begin
+ if No (Component_Clause (CD1)) then
+ return No (Component_Clause (CD2));
+ else
+ -- Note: at this point, component clauses have been
+ -- normalized to the default bit order, so that the
+ -- comparison of Component_Bit_Offsets is meaningful.
+
+ return
+ Present (Component_Clause (CD2))
+ and then
+ Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2)
+ and then
+ Esize (CD1) = Esize (CD2);
+ end if;
+ end Same_Rep;
+
+ -- Start of processing for Record_Case
+
+ begin
+ if Has_Discriminants (T1) then
+
+ -- The number of discriminants may be different if the
+ -- derived type has fewer (constrained by values). The
+ -- invisible discriminants retain the representation of
+ -- the original, so the discrepancy does not per se
+ -- indicate a different representation.
+
+ CD1 := First_Discriminant (T1);
+ CD2 := First_Discriminant (T2);
+ while Present (CD1) and then Present (CD2) loop
+ if not Same_Rep then
+ return False;
+ else
+ Next_Discriminant (CD1);
+ Next_Discriminant (CD2);
+ end if;
+ end loop;
+ end if;
+
+ CD1 := First_Component (Underlying_Type (Base_Type (T1)));
+ CD2 := First_Component (Underlying_Type (Base_Type (T2)));
+ while Present (CD1) loop
+ if not Same_Rep then
+ return False;
+ else
+ Next_Component (CD1);
+ Next_Component (CD2);
+ end if;
+ end loop;
+
+ return True;
+ end Record_Case;
+ end if;
+
+ -- For enumeration types, we must check each literal to see if the
+ -- representation is the same. Note that we do not permit enumeration
+ -- representation clauses for Character and Wide_Character, so these
+ -- cases were already dealt with.
+
+ elsif Is_Enumeration_Type (T1) then
+ Enumeration_Case : declare
+ L1, L2 : Entity_Id;
+
+ begin
+ L1 := First_Literal (T1);
+ L2 := First_Literal (T2);
+ while Present (L1) loop
+ if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then
+ return False;
+ else
+ Next_Literal (L1);
+ Next_Literal (L2);
+ end if;
+ end loop;
+
+ return True;
+ end Enumeration_Case;
+
+ -- Any other types have the same representation for these purposes
+
+ else
+ return True;
+ end if;
+ end Has_Compatible_Representation;
+
-------------------------------------
-- Inherit_Aspects_At_Freeze_Point --
-------------------------------------
@@ -11767,9 +13058,8 @@ package body Sem_Ch13 is
return Entity (Rep_Item);
else
- pragma Assert (Nkind_In (Rep_Item,
- N_Attribute_Definition_Clause,
- N_Pragma));
+ pragma Assert
+ (Nkind (Rep_Item) in N_Attribute_Definition_Clause | N_Pragma);
return Entity (Name (Rep_Item));
end if;
end Rep_Item_Entity;
@@ -12086,22 +13376,6 @@ package body Sem_Ch13 is
-- the alternatives are static (have all static choices, and a static
-- expression).
- function All_Static_Choices (L : List_Id) return Boolean;
- -- Returns true if all elements of the list are OK static choices
- -- as defined below for Is_Static_Choice. Used for case expression
- -- alternatives and for the right operand of a membership test. An
- -- others_choice is static if the corresponding expression is static.
- -- The staticness of the bounds is checked separately.
-
- function Is_Static_Choice (N : Node_Id) return Boolean;
- -- Returns True if N represents a static choice (static subtype, or
- -- static subtype indication, or static expression, or static range).
- --
- -- Note that this is a bit more inclusive than we actually need
- -- (in particular membership tests do not allow the use of subtype
- -- indications). But that doesn't matter, we have already checked
- -- that the construct is legal to get this far.
-
function Is_Type_Ref (N : Node_Id) return Boolean;
pragma Inline (Is_Type_Ref);
-- Returns True if N is a reference to the type for the predicate in the
@@ -12137,41 +13411,6 @@ package body Sem_Ch13 is
return True;
end All_Static_Case_Alternatives;
- ------------------------
- -- All_Static_Choices --
- ------------------------
-
- function All_Static_Choices (L : List_Id) return Boolean is
- N : Node_Id;
-
- begin
- N := First (L);
- while Present (N) loop
- if not Is_Static_Choice (N) then
- return False;
- end if;
-
- Next (N);
- end loop;
-
- return True;
- end All_Static_Choices;
-
- ----------------------
- -- Is_Static_Choice --
- ----------------------
-
- function Is_Static_Choice (N : Node_Id) return Boolean is
- begin
- return Nkind (N) = N_Others_Choice
- or else Is_OK_Static_Expression (N)
- or else (Is_Entity_Name (N) and then Is_Type (Entity (N))
- and then Is_OK_Static_Subtype (Entity (N)))
- or else (Nkind (N) = N_Subtype_Indication
- and then Is_OK_Static_Subtype (Entity (N)))
- or else (Nkind (N) = N_Range and then Is_OK_Static_Range (N));
- end Is_Static_Choice;
-
-----------------
-- Is_Type_Ref --
-----------------
@@ -12200,11 +13439,7 @@ package body Sem_Ch13 is
-- for a static membership test.
elsif Nkind (Expr) in N_Membership_Test
- and then ((Present (Right_Opnd (Expr))
- and then Is_Static_Choice (Right_Opnd (Expr)))
- or else
- (Present (Alternatives (Expr))
- and then All_Static_Choices (Alternatives (Expr))))
+ and then All_Membership_Choices_Static (Expr)
then
return True;
@@ -12248,7 +13483,7 @@ package body Sem_Ch13 is
-- 20. A call to a predefined boolean logical operator, where each
-- operand is predicate-static.
- elsif (Nkind_In (Expr, N_Op_And, N_Op_Or, N_Op_Xor)
+ elsif (Nkind (Expr) in N_Op_And | N_Op_Or | N_Op_Xor
and then Is_Predicate_Static (Left_Opnd (Expr), Nam)
and then Is_Predicate_Static (Right_Opnd (Expr), Nam))
or else
@@ -12307,6 +13542,21 @@ package body Sem_Ch13 is
end if;
end Is_Predicate_Static;
+ ----------------------
+ -- Is_Static_Choice --
+ ----------------------
+
+ function Is_Static_Choice (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Others_Choice
+ or else Is_OK_Static_Expression (N)
+ or else (Is_Entity_Name (N) and then Is_Type (Entity (N))
+ and then Is_OK_Static_Subtype (Entity (N)))
+ or else (Nkind (N) = N_Subtype_Indication
+ and then Is_OK_Static_Subtype (Entity (N)))
+ or else (Nkind (N) = N_Range and then Is_OK_Static_Range (N));
+ end Is_Static_Choice;
+
------------------------------
-- Is_Type_Related_Rep_Item --
------------------------------
@@ -12369,13 +13619,13 @@ package body Sem_Ch13 is
pragma Assert (Ignore_Rep_Clauses);
-- Note: we use Replace rather than Rewrite, because we don't want
- -- ASIS to be able to use Original_Node to dig out the (undecorated)
+ -- tools to be able to use Original_Node to dig out the (undecorated)
-- rep clause that is being replaced.
Replace (N, Make_Null_Statement (Sloc (N)));
-- The null statement must be marked as not coming from source. This is
- -- so that ASIS ignores it, and also the back end does not expect bogus
+ -- so that tools ignore it, and also the back end does not expect bogus
-- "from source" null statements in weird places (e.g. in declarative
-- regions where such null statements are not allowed).
@@ -12601,6 +13851,138 @@ package body Sem_Ch13 is
return S;
end Minimum_Size;
+ ------------------------------
+ -- New_Put_Image_Subprogram --
+ ------------------------------
+
+ procedure New_Put_Image_Subprogram
+ (N : Node_Id;
+ Ent : Entity_Id;
+ Subp : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Sname : constant Name_Id :=
+ Make_TSS_Name (Base_Type (Ent), TSS_Put_Image);
+ Subp_Id : Entity_Id;
+ Subp_Decl : Node_Id;
+ F : Entity_Id;
+ Etyp : Entity_Id;
+
+ Defer_Declaration : constant Boolean :=
+ Is_Tagged_Type (Ent) or else Is_Private_Type (Ent);
+ -- For a tagged type, there is a declaration at the freeze point, and
+ -- we must generate only a completion of this declaration. We do the
+ -- same for private types, because the full view might be tagged.
+ -- Otherwise we generate a declaration at the point of the attribute
+ -- definition clause. If the attribute definition comes from an aspect
+ -- specification the declaration is part of the freeze actions of the
+ -- type.
+
+ function Build_Spec return Node_Id;
+ -- Used for declaration and renaming declaration, so that this is
+ -- treated as a renaming_as_body.
+
+ ----------------
+ -- Build_Spec --
+ ----------------
+
+ function Build_Spec return Node_Id is
+ Formals : List_Id;
+ Spec : Node_Id;
+ T_Ref : constant Node_Id := New_Occurrence_Of (Etyp, Loc);
+
+ begin
+ Subp_Id := Make_Defining_Identifier (Loc, Sname);
+
+ -- S : Sink'Class
+
+ Formals := New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_S),
+ In_Present => True,
+ Out_Present => True,
+ Parameter_Type =>
+ New_Occurrence_Of (Etype (F), Loc)));
+
+ -- V : T
+
+ Append_To (Formals,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
+ Parameter_Type => T_Ref));
+
+ Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Subp_Id,
+ Parameter_Specifications => Formals);
+
+ return Spec;
+ end Build_Spec;
+
+ -- Start of processing for New_Put_Image_Subprogram
+
+ begin
+ F := First_Formal (Subp);
+
+ Etyp := Etype (Next_Formal (F));
+
+ -- Prepare subprogram declaration and insert it as an action on the
+ -- clause node. The visibility for this entity is used to test for
+ -- visibility of the attribute definition clause (in the sense of
+ -- 8.3(23) as amended by AI-195).
+
+ if not Defer_Declaration then
+ Subp_Decl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification => Build_Spec);
+
+ -- For a tagged type, there is always a visible declaration for the
+ -- Put_Image TSS (it is a predefined primitive operation), and the
+ -- completion of this declaration occurs at the freeze point, which is
+ -- not always visible at places where the attribute definition clause is
+ -- visible. So, we create a dummy entity here for the purpose of
+ -- tracking the visibility of the attribute definition clause itself.
+
+ else
+ Subp_Id :=
+ Make_Defining_Identifier (Loc, New_External_Name (Sname, 'V'));
+ Subp_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Subp_Id,
+ Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc));
+ end if;
+
+ if not Defer_Declaration
+ and then From_Aspect_Specification (N)
+ and then Has_Delayed_Freeze (Ent)
+ then
+ Append_Freeze_Action (Ent, Subp_Decl);
+
+ else
+ Insert_Action (N, Subp_Decl);
+ Set_Entity (N, Subp_Id);
+ end if;
+
+ Subp_Decl :=
+ Make_Subprogram_Renaming_Declaration (Loc,
+ Specification => Build_Spec,
+ Name => New_Occurrence_Of (Subp, Loc));
+
+ if Defer_Declaration then
+ Set_TSS (Base_Type (Ent), Subp_Id);
+
+ else
+ if From_Aspect_Specification (N) then
+ Append_Freeze_Action (Ent, Subp_Decl);
+ else
+ Insert_Action (N, Subp_Decl);
+ end if;
+
+ Copy_TSS (Subp_Id, Base_Type (Ent));
+ end if;
+ end New_Put_Image_Subprogram;
+
---------------------------
-- New_Stream_Subprogram --
---------------------------
@@ -12748,6 +14130,15 @@ package body Sem_Ch13 is
end if;
end New_Stream_Subprogram;
+ ----------------------
+ -- No_Type_Rep_Item --
+ ----------------------
+
+ procedure No_Type_Rep_Item (N : Node_Id) is
+ begin
+ Error_Msg_N ("|type-related representation item not permitted!", N);
+ end No_Type_Rep_Item;
+
--------------
-- Pop_Type --
--------------
@@ -12818,7 +14209,7 @@ package body Sem_Ch13 is
function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean is
function Has_Generic_Parent (E : Entity_Id) return Boolean;
- -- Return True if any ancestor is a generic type
+ -- Return True if R or any ancestor is a generic type
------------------------
-- Has_Generic_Parent --
@@ -12828,6 +14219,10 @@ package body Sem_Ch13 is
Ancestor_Type : Entity_Id := Etype (E);
begin
+ if Is_Generic_Type (E) then
+ return True;
+ end if;
+
while Present (Ancestor_Type)
and then not Is_Generic_Type (Ancestor_Type)
and then Etype (Ancestor_Type) /= Ancestor_Type
@@ -12900,17 +14295,6 @@ package body Sem_Ch13 is
N : Node_Id;
FOnly : Boolean := False) return Boolean
is
- function Is_Derived_Type_With_Constraint return Boolean;
- -- Check whether T is a derived type with an explicit constraint, in
- -- which case the constraint has frozen the type and the item is too
- -- late. This compensates for the fact that for derived scalar types
- -- we freeze the base type unconditionally on account of a long-standing
- -- issue in gigi.
-
- procedure No_Type_Rep_Item;
- -- Output message indicating that no type-related aspects can be
- -- specified due to some property of the parent type.
-
procedure Too_Late;
-- Output message for an aspect being specified too late
@@ -12921,32 +14305,6 @@ package body Sem_Ch13 is
-- document the requirement in the spec of Rep_Item_Too_Late that
-- if True is returned, then the rep item must be completely ignored???
- --------------------------------------
- -- Is_Derived_Type_With_Constraint --
- --------------------------------------
-
- function Is_Derived_Type_With_Constraint return Boolean is
- Decl : constant Node_Id := Declaration_Node (T);
-
- begin
- return Is_Derived_Type (T)
- and then Is_Frozen (Base_Type (T))
- and then Is_Enumeration_Type (T)
- and then False
- and then Nkind (N) = N_Enumeration_Representation_Clause
- and then Nkind (Decl) = N_Subtype_Declaration
- and then not Is_Entity_Name (Subtype_Indication (Decl));
- end Is_Derived_Type_With_Constraint;
-
- ----------------------
- -- No_Type_Rep_Item --
- ----------------------
-
- procedure No_Type_Rep_Item is
- begin
- Error_Msg_N ("|type-related representation item not permitted!", N);
- end No_Type_Rep_Item;
-
--------------
-- Too_Late --
--------------
@@ -12972,9 +14330,7 @@ package body Sem_Ch13 is
begin
-- First make sure entity is not frozen (RM 13.1(9))
- if (Is_Frozen (T)
- or else (Is_Type (T)
- and then Is_Derived_Type_With_Constraint))
+ if Is_Frozen (T)
-- Exclude imported types, which may be frozen if they appear in a
-- representation clause for a local type.
@@ -12991,7 +14347,7 @@ package body Sem_Ch13 is
-- A self-referential aspect is illegal if it forces freezing the
-- entity before the corresponding pragma has been analyzed.
- if Nkind_In (N, N_Attribute_Definition_Clause, N_Pragma)
+ if Nkind (N) in N_Attribute_Definition_Clause | N_Pragma
and then From_Aspect_Specification (N)
then
Error_Msg_NE
@@ -13013,9 +14369,11 @@ package body Sem_Ch13 is
return True;
-- Check for case of untagged derived type whose parent either has
- -- primitive operations, or is a by reference type (RM 13.1(10)). In
- -- this case we do not output a Too_Late message, since there is no
- -- earlier point where the rep item could be placed to make it legal.
+ -- primitive operations (pre Ada 202x), or is a by-reference type (RM
+ -- 13.1(10)). In this case we do not output a Too_Late message, since
+ -- there is no earlier point where the rep item could be placed to make
+ -- it legal.
+ -- ??? Confirming representation clauses should be allowed here.
elsif Is_Type (T)
and then not FOnly
@@ -13024,24 +14382,22 @@ package body Sem_Ch13 is
then
Parent_Type := Etype (Base_Type (T));
- if Has_Primitive_Operations (Parent_Type) then
- No_Type_Rep_Item;
-
- if not Relaxed_RM_Semantics then
- Error_Msg_NE
- ("\parent type & has primitive operations!", N, Parent_Type);
- end if;
+ if Relaxed_RM_Semantics then
+ null;
+ elsif Ada_Version <= Ada_2012
+ and then Has_Primitive_Operations (Parent_Type)
+ then
+ Error_Msg_N
+ ("|representation item not permitted before Ada 202x!", N);
+ Error_Msg_NE
+ ("\parent type & has primitive operations!", N, Parent_Type);
return True;
elsif Is_By_Reference_Type (Parent_Type) then
- No_Type_Rep_Item;
-
- if not Relaxed_RM_Semantics then
- Error_Msg_NE
- ("\parent type & is a by reference type!", N, Parent_Type);
- end if;
-
+ No_Type_Rep_Item (N);
+ Error_Msg_NE
+ ("\parent type & is a by-reference type!", N, Parent_Type);
return True;
end if;
end if;
@@ -13117,8 +14473,8 @@ package body Sem_Ch13 is
declare
Pname : constant Name_Id := Pragma_Name (N);
begin
- if Nam_In (Pname, Name_Convention, Name_Import, Name_Export,
- Name_External, Name_Interface)
+ if Pname in Name_Convention | Name_Import | Name_Export
+ | Name_External | Name_Interface
then
return False;
end if;
@@ -13364,9 +14720,6 @@ package body Sem_Ch13 is
-- introduce a local identifier that would require proper expansion to
-- handle properly.
- -- In ASIS_Mode we preserve the entity in the source because there is
- -- no subsequent expansion to decorate the tree.
-
------------------
-- Resolve_Name --
------------------
@@ -13393,19 +14746,7 @@ package body Sem_Ch13 is
or else N /= Selector_Name (Parent (N)))
then
Find_Direct_Name (N);
-
- -- In ASIS mode we must analyze overloaded identifiers to ensure
- -- their correct decoration because expansion is disabled (and
- -- the expansion of freeze nodes takes care of resolving aspect
- -- expressions).
-
- if ASIS_Mode then
- if Is_Overloaded (N) then
- Analyze (Parent (N));
- end if;
- else
- Set_Entity (N, Empty);
- end if;
+ Set_Entity (N, Empty);
-- The name is component association needs no resolution.
@@ -13442,6 +14783,9 @@ package body Sem_Ch13 is
begin
case A_Id is
+ when Aspect_Aggregate =>
+ Resolve_Aspect_Aggregate (Entity (ASN), Expr);
+
-- For now we only deal with aspects that do not generate
-- subprograms, or that may mention current instances of
-- types. These will require special handling (???TBD).
@@ -13536,224 +14880,95 @@ package body Sem_Ch13 is
end;
end if;
- ASN := Next_Rep_Item (ASN);
+ Next_Rep_Item (ASN);
end loop;
end Resolve_Aspect_Expressions;
- -------------------------
- -- Same_Representation --
- -------------------------
+ ----------------------------
+ -- Parse_Aspect_Aggregate --
+ ----------------------------
- function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean is
- T1 : constant Entity_Id := Underlying_Type (Typ1);
- T2 : constant Entity_Id := Underlying_Type (Typ2);
+ procedure Parse_Aspect_Aggregate
+ (N : Node_Id;
+ Empty_Subp : in out Node_Id;
+ Add_Named_Subp : in out Node_Id;
+ Add_Unnamed_Subp : in out Node_Id;
+ New_Indexed_Subp : in out Node_Id;
+ Assign_Indexed_Subp : in out Node_Id)
+ is
+ Assoc : Node_Id := First (Component_Associations (N));
+ Op_Name : Name_Id;
+ Subp : Node_Id;
begin
- -- A quick check, if base types are the same, then we definitely have
- -- the same representation, because the subtype specific representation
- -- attributes (Size and Alignment) do not affect representation from
- -- the point of view of this test.
-
- if Base_Type (T1) = Base_Type (T2) then
- return True;
-
- elsif Is_Private_Type (Base_Type (T2))
- and then Base_Type (T1) = Full_View (Base_Type (T2))
- then
- return True;
-
- -- If T2 is a generic actual it is declared as a subtype, so
- -- check against its base type.
-
- elsif Is_Generic_Actual_Type (T1)
- and then Same_Representation (Base_Type (T1), T2)
- then
- return True;
- end if;
-
- -- Tagged types always have the same representation, because it is not
- -- possible to specify different representations for common fields.
+ while Present (Assoc) loop
+ Subp := Expression (Assoc);
+ Op_Name := Chars (First (Choices (Assoc)));
+ if Op_Name = Name_Empty then
+ Empty_Subp := Subp;
- if Is_Tagged_Type (T1) then
- return True;
- end if;
+ elsif Op_Name = Name_Add_Named then
+ Add_Named_Subp := Subp;
- -- Representations are definitely different if conventions differ
+ elsif Op_Name = Name_Add_Unnamed then
+ Add_Unnamed_Subp := Subp;
- if Convention (T1) /= Convention (T2) then
- return False;
- end if;
+ elsif Op_Name = Name_New_Indexed then
+ New_Indexed_Subp := Subp;
- -- Representations are different if component alignments or scalar
- -- storage orders differ.
+ elsif Op_Name = Name_Assign_Indexed then
+ Assign_Indexed_Subp := Subp;
+ end if;
- if (Is_Record_Type (T1) or else Is_Array_Type (T1))
- and then
- (Is_Record_Type (T2) or else Is_Array_Type (T2))
- and then
- (Component_Alignment (T1) /= Component_Alignment (T2)
- or else Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2))
- then
- return False;
- end if;
+ Next (Assoc);
+ end loop;
+ end Parse_Aspect_Aggregate;
- -- For arrays, the only real issue is component size. If we know the
- -- component size for both arrays, and it is the same, then that's
- -- good enough to know we don't have a change of representation.
+ -------------------------------
+ -- Validate_Aspect_Aggregate --
+ -------------------------------
- if Is_Array_Type (T1) then
- if Known_Component_Size (T1)
- and then Known_Component_Size (T2)
- and then Component_Size (T1) = Component_Size (T2)
- then
- return True;
- end if;
- end if;
+ procedure Validate_Aspect_Aggregate (N : Node_Id) is
+ Empty_Subp : Node_Id := Empty;
+ Add_Named_Subp : Node_Id := Empty;
+ Add_Unnamed_Subp : Node_Id := Empty;
+ New_Indexed_Subp : Node_Id := Empty;
+ Assign_Indexed_Subp : Node_Id := Empty;
- -- For records, representations are different if reorderings differ
+ begin
+ if Ada_Version < Ada_2020 then
+ Error_Msg_N ("Aspect Aggregate is an Ada_2020 feature", N);
- if Is_Record_Type (T1)
- and then Is_Record_Type (T2)
- and then No_Reordering (T1) /= No_Reordering (T2)
+ elsif Nkind (N) /= N_Aggregate
+ or else Present (Expressions (N))
+ or else No (Component_Associations (N))
then
- return False;
+ Error_Msg_N ("Aspect Aggregate requires an aggregate "
+ & "with component associations", N);
+ return;
end if;
- -- Types definitely have same representation if neither has non-standard
- -- representation since default representations are always consistent.
- -- If only one has non-standard representation, and the other does not,
- -- then we consider that they do not have the same representation. They
- -- might, but there is no way of telling early enough.
+ Parse_Aspect_Aggregate (N,
+ Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp,
+ New_Indexed_Subp, Assign_Indexed_Subp);
- if Has_Non_Standard_Rep (T1) then
- if not Has_Non_Standard_Rep (T2) then
- return False;
- end if;
- else
- return not Has_Non_Standard_Rep (T2);
+ if No (Empty_Subp) then
+ Error_Msg_N ("missing specification for Empty in aggregate", N);
end if;
- -- Here the two types both have non-standard representation, and we need
- -- to determine if they have the same non-standard representation.
-
- -- For arrays, we simply need to test if the component sizes are the
- -- same. Pragma Pack is reflected in modified component sizes, so this
- -- check also deals with pragma Pack.
-
- if Is_Array_Type (T1) then
- return Component_Size (T1) = Component_Size (T2);
-
- -- Case of record types
-
- elsif Is_Record_Type (T1) then
-
- -- Packed status must conform
-
- if Is_Packed (T1) /= Is_Packed (T2) then
- return False;
-
- -- Otherwise we must check components. Typ2 maybe a constrained
- -- subtype with fewer components, so we compare the components
- -- of the base types.
-
- else
- Record_Case : declare
- CD1, CD2 : Entity_Id;
-
- function Same_Rep return Boolean;
- -- CD1 and CD2 are either components or discriminants. This
- -- function tests whether they have the same representation.
-
- --------------
- -- Same_Rep --
- --------------
-
- function Same_Rep return Boolean is
- begin
- if No (Component_Clause (CD1)) then
- return No (Component_Clause (CD2));
- else
- -- Note: at this point, component clauses have been
- -- normalized to the default bit order, so that the
- -- comparison of Component_Bit_Offsets is meaningful.
-
- return
- Present (Component_Clause (CD2))
- and then
- Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2)
- and then
- Esize (CD1) = Esize (CD2);
- end if;
- end Same_Rep;
-
- -- Start of processing for Record_Case
-
- begin
- if Has_Discriminants (T1) then
-
- -- The number of discriminants may be different if the
- -- derived type has fewer (constrained by values). The
- -- invisible discriminants retain the representation of
- -- the original, so the discrepancy does not per se
- -- indicate a different representation.
-
- CD1 := First_Discriminant (T1);
- CD2 := First_Discriminant (T2);
- while Present (CD1) and then Present (CD2) loop
- if not Same_Rep then
- return False;
- else
- Next_Discriminant (CD1);
- Next_Discriminant (CD2);
- end if;
- end loop;
- end if;
-
- CD1 := First_Component (Underlying_Type (Base_Type (T1)));
- CD2 := First_Component (Underlying_Type (Base_Type (T2)));
- while Present (CD1) loop
- if not Same_Rep then
- return False;
- else
- Next_Component (CD1);
- Next_Component (CD2);
- end if;
- end loop;
-
- return True;
- end Record_Case;
+ if Present (Add_Named_Subp) then
+ if Present (Add_Unnamed_Subp)
+ or else Present (Assign_Indexed_Subp)
+ then
+ Error_Msg_N
+ ("conflicting operations for aggregate (RM 4.3.5)", N);
+ return;
end if;
- -- For enumeration types, we must check each literal to see if the
- -- representation is the same. Note that we do not permit enumeration
- -- representation clauses for Character and Wide_Character, so these
- -- cases were already dealt with.
-
- elsif Is_Enumeration_Type (T1) then
- Enumeration_Case : declare
- L1, L2 : Entity_Id;
-
- begin
- L1 := First_Literal (T1);
- L2 := First_Literal (T2);
- while Present (L1) loop
- if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then
- return False;
- else
- Next_Literal (L1);
- Next_Literal (L2);
- end if;
- end loop;
-
- return True;
- end Enumeration_Case;
-
- -- Any other types have the same representation for these purposes
-
- else
- return True;
+ elsif Present (New_Indexed_Subp) /= Present (Assign_Indexed_Subp) then
+ Error_Msg_N ("incomplete specification for indexed aggregate", N);
end if;
- end Same_Representation;
+ end Validate_Aspect_Aggregate;
--------------------------------
-- Resolve_Iterable_Operation --
@@ -13916,6 +15131,189 @@ package body Sem_Ch13 is
end if;
end Resolve_Iterable_Operation;
+ ------------------------------
+ -- Resolve_Aspect_Aggregate --
+ ------------------------------
+
+ procedure Resolve_Aspect_Aggregate
+ (Typ : Entity_Id;
+ Expr : Node_Id)
+ is
+ -- Predicates that establish the legality of each possible operation in
+ -- an Aggregate aspect.
+
+ function Valid_Empty (E : Entity_Id) return Boolean;
+ function Valid_Add_Named (E : Entity_Id) return Boolean;
+ function Valid_Add_Unnamed (E : Entity_Id) return Boolean;
+ function Valid_New_Indexed (E : Entity_Id) return Boolean;
+
+ -- Note: The legality rules for Assign_Indexed are the same as for
+ -- Add_Named.
+
+ generic
+ with function Pred (Id : Node_Id) return Boolean;
+ procedure Resolve_Operation (Subp_Id : Node_Id);
+ -- Common processing to resolve each aggregate operation.
+
+ -----------------
+ -- Valid_Emoty --
+ -----------------
+
+ function Valid_Empty (E : Entity_Id) return Boolean is
+ begin
+ if Etype (E) /= Typ or else Scope (E) /= Scope (Typ) then
+ return False;
+
+ elsif Ekind (E) = E_Constant then
+ return True;
+
+ elsif Ekind (E) = E_Function then
+ return No (First_Formal (E))
+ or else
+ (Is_Integer_Type (Etype (First_Formal (E)))
+ and then No (Next_Formal (First_Formal (E))));
+ else
+ return False;
+ end if;
+ end Valid_Empty;
+
+ ---------------------
+ -- Valid_Add_Named --
+ ---------------------
+
+ function Valid_Add_Named (E : Entity_Id) return Boolean is
+ F2, F3 : Entity_Id;
+ begin
+ if Ekind (E) = E_Procedure
+ and then Scope (E) = Scope (Typ)
+ and then Number_Formals (E) = 3
+ and then Etype (First_Formal (E)) = Typ
+ and then Ekind (First_Formal (E)) = E_In_Out_Parameter
+ then
+ F2 := Next_Formal (First_Formal (E));
+ F3 := Next_Formal (F2);
+ return Ekind (F2) = E_In_Parameter
+ and then Ekind (F3) = E_In_Parameter
+ and then not Is_Limited_Type (Etype (F2))
+ and then not Is_Limited_Type (Etype (F3));
+ else
+ return False;
+ end if;
+ end Valid_Add_Named;
+
+ -----------------------
+ -- Valid_Add_Unnamed --
+ -----------------------
+
+ function Valid_Add_Unnamed (E : Entity_Id) return Boolean is
+ begin
+ return Ekind (E) = E_Procedure
+ and then Scope (E) = Scope (Typ)
+ and then Number_Formals (E) = 2
+ and then Etype (First_Formal (E)) = Typ
+ and then Ekind (First_Formal (E)) = E_In_Out_Parameter
+ and then
+ not Is_Limited_Type (Etype (Next_Formal (First_Formal (E))));
+ end Valid_Add_Unnamed;
+
+ -----------------------
+ -- Valid_Nmw_Indexed --
+ -----------------------
+
+ function Valid_New_Indexed (E : Entity_Id) return Boolean is
+ begin
+ return Ekind (E) = E_Function
+ and then Scope (E) = Scope (Typ)
+ and then Etype (E) = Typ
+ and then Number_Formals (E) = 2
+ and then Is_Discrete_Type (Etype (First_Formal (E)))
+ and then Etype (First_Formal (E)) =
+ Etype (Next_Formal (First_Formal (E)));
+ end Valid_New_Indexed;
+
+ -----------------------
+ -- Resolve_Operation --
+ -----------------------
+
+ procedure Resolve_Operation (Subp_Id : Node_Id) is
+ Subp : Entity_Id;
+
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ if not Is_Overloaded (Subp_Id) then
+ Subp := Entity (Subp_Id);
+ if not Pred (Subp) then
+ Error_Msg_NE
+ ("improper aggregate operation for&", Subp_Id, Typ);
+ end if;
+
+ else
+ Set_Entity (Subp_Id, Empty);
+ Get_First_Interp (Subp_Id, I, It);
+ while Present (It.Nam) loop
+ if Pred (It.Nam) then
+ Set_Is_Overloaded (Subp_Id, False);
+ Set_Entity (Subp_Id, It.Nam);
+ exit;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if No (Entity (Subp_Id)) then
+ Error_Msg_NE
+ ("improper aggregate operation for&", Subp_Id, Typ);
+ end if;
+ end if;
+ end Resolve_Operation;
+
+ Assoc : Node_Id;
+ Op_Name : Name_Id;
+ Subp_Id : Node_Id;
+
+ procedure Resolve_Empty is new Resolve_Operation (Valid_Empty);
+ procedure Resolve_Unnamed is new Resolve_Operation (Valid_Add_Unnamed);
+ procedure Resolve_Named is new Resolve_Operation (Valid_Add_Named);
+ procedure Resolve_Indexed is new Resolve_Operation (Valid_New_Indexed);
+ procedure Resolve_Assign_Indexed
+ is new Resolve_Operation (Valid_Add_Named);
+ begin
+ Assoc := First (Component_Associations (Expr));
+
+ while Present (Assoc) loop
+ Op_Name := Chars (First (Choices (Assoc)));
+
+ -- When verifying the consistency of aspects between the freeze point
+ -- and the end of declarqtions, we use a copy which is not analyzed
+ -- yet, so do it now.
+
+ Subp_Id := Expression (Assoc);
+ if No (Etype (Subp_Id)) then
+ Analyze (Subp_Id);
+ end if;
+
+ if Op_Name = Name_Empty then
+ Resolve_Empty (Subp_Id);
+
+ elsif Op_Name = Name_Add_Named then
+ Resolve_Named (Subp_Id);
+
+ elsif Op_Name = Name_Add_Unnamed then
+ Resolve_Unnamed (Subp_Id);
+
+ elsif Op_Name = Name_New_Indexed then
+ Resolve_Indexed (Subp_Id);
+
+ elsif Op_Name = Name_Assign_Indexed then
+ Resolve_Assign_Indexed (Subp_Id);
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end Resolve_Aspect_Aggregate;
+
----------------
-- Set_Biased --
----------------
@@ -14611,6 +16009,125 @@ package body Sem_Ch13 is
end if;
end Validate_Iterable_Aspect;
+ ------------------------------
+ -- Validate_Literal_Aspect --
+ ------------------------------
+
+ procedure Validate_Literal_Aspect (Typ : Entity_Id; ASN : Node_Id) is
+ A_Id : constant Aspect_Id := Get_Aspect_Id (ASN);
+ pragma Assert ((A_Id = Aspect_Integer_Literal) or
+ (A_Id = Aspect_Real_Literal) or
+ (A_Id = Aspect_String_Literal));
+ Func_Name : constant Node_Id := Expression (ASN);
+ Overloaded : Boolean := Is_Overloaded (Func_Name);
+
+ I : Interp_Index;
+ It : Interp;
+ Param_Type : Entity_Id;
+ Match_Found : Boolean := False;
+ Is_Match : Boolean;
+ Match : Interp;
+
+ begin
+ if not Is_Type (Typ) then
+ Error_Msg_N ("aspect can only be specified for a type", ASN);
+ return;
+
+ elsif not Is_First_Subtype (Typ) then
+ Error_Msg_N ("aspect cannot be specified for a subtype", ASN);
+ return;
+ end if;
+
+ if A_Id = Aspect_String_Literal then
+ if Is_String_Type (Typ) then
+ Error_Msg_N ("aspect cannot be specified for a string type", ASN);
+ return;
+ end if;
+
+ Param_Type := Standard_Wide_Wide_String;
+
+ else
+ if Is_Numeric_Type (Typ) then
+ Error_Msg_N ("aspect cannot be specified for a numeric type", ASN);
+ return;
+ end if;
+
+ Param_Type := Standard_String;
+ end if;
+
+ if not Overloaded and then not Present (Entity (Func_Name)) then
+ Analyze (Func_Name);
+ Overloaded := Is_Overloaded (Func_Name);
+ end if;
+
+ if Overloaded then
+ Get_First_Interp (Func_Name, I => I, It => It);
+ else
+ -- only one possible interpretation
+ It.Nam := Entity (Func_Name);
+ pragma Assert (Present (It.Nam));
+ end if;
+
+ while It.Nam /= Empty loop
+ Is_Match := False;
+
+ if Ekind (It.Nam) = E_Function
+ and then Base_Type (Etype (It.Nam)) = Typ
+ then
+ declare
+ Params : constant List_Id :=
+ Parameter_Specifications (Parent (It.Nam));
+ Param_Spec : Node_Id;
+ Param_Id : Entity_Id;
+
+ begin
+ if List_Length (Params) = 1 then
+ Param_Spec := First (Params);
+
+ if not More_Ids (Param_Spec) then
+ Param_Id := Defining_Identifier (Param_Spec);
+
+ if Base_Type (Etype (Param_Id)) = Param_Type
+ and then Ekind (Param_Id) = E_In_Parameter
+ and then not Is_Aliased (Param_Id)
+ then
+ Is_Match := True;
+ end if;
+ end if;
+ end if;
+ end;
+ end if;
+
+ if Is_Match then
+ if Match_Found then
+ Error_Msg_N ("aspect specification is ambiguous", ASN);
+ return;
+ end if;
+
+ Match_Found := True;
+ Match := It;
+ end if;
+
+ exit when not Overloaded;
+
+ if not Is_Match then
+ Remove_Interp (I => I);
+ end if;
+
+ Get_Next_Interp (I => I, It => It);
+ end loop;
+
+ if not Match_Found then
+ Error_Msg_N
+ ("function name in aspect specification cannot be resolved", ASN);
+ return;
+ end if;
+
+ Set_Entity (Func_Name, Match.Nam);
+ Set_Etype (Func_Name, Etype (Match.Nam));
+ Set_Is_Overloaded (Func_Name, False);
+ end Validate_Literal_Aspect;
+
-----------------------------------
-- Validate_Unchecked_Conversion --
-----------------------------------
diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads
index eb95e2b..3d24c04 100644
--- a/gcc/ada/sem_ch13.ads
+++ b/gcc/ada/sem_ch13.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -28,6 +28,9 @@ with Types; use Types;
with Uintp; use Uintp;
package Sem_Ch13 is
+ function All_Membership_Choices_Static (Expr : Node_Id) return Boolean;
+ -- Given a membership test, returns True iff all choices are static.
+
procedure Analyze_At_Clause (N : Node_Id);
procedure Analyze_Attribute_Definition_Clause (N : Node_Id);
procedure Analyze_Enumeration_Representation_Clause (N : Node_Id);
@@ -125,6 +128,25 @@ package Sem_Ch13 is
-- If the size is too small, and an error message is given, then both
-- Esize and RM_Size are reset to the allowed minimum value in T.
+ function Has_Compatible_Representation
+ (Target_Type, Operand_Type : Entity_Id) return Boolean;
+ -- Given two types, where the two types are related by possible derivation,
+ -- determines if the two types have compatible representation, or different
+ -- representations, requiring the special processing for representation
+ -- change. A False result is possible only for array, enumeration or
+ -- record types.
+
+ procedure Parse_Aspect_Aggregate
+ (N : Node_Id;
+ Empty_Subp : in out Node_Id;
+ Add_Named_Subp : in out Node_Id;
+ Add_Unnamed_Subp : in out Node_Id;
+ New_Indexed_Subp : in out Node_Id;
+ Assign_Indexed_Subp : in out Node_Id);
+ -- Utility to unpack the subprograms in an occurrence of aspect Aggregate;
+ -- used to verify the structure of the aspect, and resolve and expand an
+ -- aggregate for a container type that carries the aspect.
+
function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean;
-- Called at start of processing a representation clause/pragma. Used to
-- check that the representation item is not being applied to an incomplete
@@ -182,13 +204,6 @@ package Sem_Ch13 is
-- because such clauses are linked on to the Rep_Item chain in procedure
-- Sem_Ch13.Analyze_Aspect_Specifications. See that procedure for details.
- function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean;
- -- Given two types, where the two types are related by possible derivation,
- -- determines if the two types have the same representation, or different
- -- representations, requiring the special processing for representation
- -- change. A False result is possible only for array, enumeration or
- -- record types.
-
procedure Validate_Unchecked_Conversion
(N : Node_Id;
Act_Unit : Entity_Id);
@@ -342,6 +357,10 @@ package Sem_Ch13 is
-- for First, Next, and Has_Element. Optionally an Element primitive may
-- also be defined.
+ procedure Validate_Literal_Aspect (Typ : Entity_Id; ASN : Node_Id);
+ -- Check legality of Integer_Literal, Real_Literal, and String_Literal
+ -- aspect specifications.
+
procedure Install_Discriminants (E : Entity_Id);
-- Make visible the discriminants of type entity E
diff --git a/gcc/ada/sem_ch2.adb b/gcc/ada/sem_ch2.adb
index 378269f..d57941f 100644
--- a/gcc/ada/sem_ch2.adb
+++ b/gcc/ada/sem_ch2.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_ch2.ads b/gcc/ada/sem_ch2.ads
index afa5632..a28d85f 100644
--- a/gcc/ada/sem_ch2.ads
+++ b/gcc/ada/sem_ch2.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 956c92d..a5690d6 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -45,6 +45,7 @@ with Layout; use Layout;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
+with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
@@ -91,6 +92,11 @@ package body Sem_Ch3 is
-- abstract interface types implemented by a record type or a derived
-- record type.
+ procedure Build_Access_Subprogram_Wrapper (Decl : Node_Id);
+ -- When an access-to-subprogram type has pre/postconditions, we build a
+ -- subprogram that includes these contracts and is invoked by an indirect
+ -- call through the corresponding access type.
+
procedure Build_Derived_Type
(N : Node_Id;
Parent_Type : Entity_Id;
@@ -253,6 +259,11 @@ package body Sem_Ch3 is
-- circularity issues in Gigi. We create an incomplete type for the record
-- declaration, which is the designated type of the anonymous access.
+ procedure Check_Constraining_Discriminant (New_Disc, Old_Disc : Entity_Id);
+ -- Check that, if a new discriminant is used in a constraint defining the
+ -- parent subtype of a derivation, its subtype is statically compatible
+ -- with the subtype of the corresponding parent discriminant (RM 3.7(15)).
+
procedure Check_Delta_Expression (E : Node_Id);
-- Check that the expression represented by E is suitable for use as a
-- delta expression, i.e. it is of real type and is static.
@@ -562,16 +573,18 @@ package body Sem_Ch3 is
-- copying the record declaration for the derived base. In the tagged case
-- the value returned is irrelevant.
- procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id);
- -- Propagate static and dynamic predicate flags from a parent to the
- -- subtype in a subtype declaration with and without constraints.
-
function Is_EVF_Procedure (Subp : Entity_Id) return Boolean;
-- Subsidiary to Check_Abstract_Overriding and Derive_Subprogram.
-- Determine whether subprogram Subp is a procedure subject to pragma
-- Extensions_Visible with value False and has at least one controlling
-- parameter of mode OUT.
+ function Is_Private_Primitive (Prim : Entity_Id) return Boolean;
+ -- Subsidiary to Check_Abstract_Overriding and Derive_Subprogram.
+ -- When applied to a primitive subprogram Prim, returns True if Prim is
+ -- declared as a private operation within a package or generic package,
+ -- and returns False otherwise.
+
function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind;
Constraint_Kind : Node_Kind) return Boolean;
@@ -657,14 +670,22 @@ package body Sem_Ch3 is
-- declaration, Prev_T is the original incomplete type, whose full view is
-- the record type.
- procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id);
- -- Subsidiary to Build_Derived_Record_Type. For untagged records, we
- -- build a copy of the declaration tree of the parent, and we create
- -- independently the list of components for the derived type. Semantic
- -- information uses the component entities, but record representation
- -- clauses are validated on the declaration tree. This procedure replaces
- -- discriminants and components in the declaration with those that have
- -- been created by Inherit_Components.
+ procedure Replace_Discriminants (Typ : Entity_Id; Decl : Node_Id);
+ -- Subsidiary to Build_Derived_Record_Type. For untagged record types, we
+ -- first create the list of components for the derived type from that of
+ -- the parent by means of Inherit_Components and then build a copy of the
+ -- declaration tree of the parent with the help of the mapping returned by
+ -- Inherit_Components, which will for example be used to validate record
+ -- representation clauses given for the derived type. If the parent type
+ -- is private and has discriminants, the ancestor discriminants used in the
+ -- inheritance are that of the private declaration, whereas the ancestor
+ -- discriminants present in the declaration tree of the parent are that of
+ -- the full declaration; as a consequence, the remapping done during the
+ -- copy will leave the references to the ancestor discriminants unchanged
+ -- in the declaration tree and they need to be fixed up. If the derived
+ -- type has a known discriminant part, then the remapping done during the
+ -- copy will only create references to the girder discriminants and they
+ -- need to be replaced with references to the non-girder discriminants.
procedure Set_Fixed_Range
(E : Entity_Id;
@@ -716,8 +737,6 @@ package body Sem_Ch3 is
Enclosing_Prot_Type : Entity_Id := Empty;
begin
- Check_SPARK_05_Restriction ("access type is not allowed", N);
-
if Is_Entry (Current_Scope)
and then Is_Task_Type (Etype (Scope (Current_Scope)))
then
@@ -732,8 +751,8 @@ package body Sem_Ch3 is
-- function, scope is the current one, because it is the one of the
-- current type declaration, except for the pathological case below.
- if Nkind_In (Related_Nod, N_Object_Declaration,
- N_Access_Function_Definition)
+ if Nkind (Related_Nod) in
+ N_Object_Declaration | N_Access_Function_Definition
then
Anon_Scope := Current_Scope;
@@ -746,8 +765,8 @@ package body Sem_Ch3 is
begin
Par := Related_Nod;
- while Nkind_In (Par, N_Access_Function_Definition,
- N_Access_Definition)
+ while Nkind (Par) in
+ N_Access_Function_Definition | N_Access_Definition
loop
Par := Parent (Par);
end loop;
@@ -773,7 +792,7 @@ package body Sem_Ch3 is
-- be available in the scope that encloses the protected declaration.
-- Otherwise the type is in the scope enclosing the subprogram.
- -- If the function has formals, The return type of a subprogram
+ -- If the function has formals, the return type of a subprogram
-- declaration is analyzed in the scope of the subprogram (see
-- Process_Formals) and thus the protected type, if present, is
-- the scope of the current function scope.
@@ -921,7 +940,6 @@ package body Sem_Ch3 is
then
if Is_Limited_Record (Desig_Type)
and then Is_Class_Wide_Type (Desig_Type)
- and then Tasking_Allowed
then
Build_Class_Wide_Master (Anon_Type);
@@ -1029,7 +1047,7 @@ package body Sem_Ch3 is
Param := First (Parameter_Specifications (Def));
while Present (Param) loop
Check_For_Premature_Usage (Parameter_Type (Param));
- Param := Next (Param);
+ Next (Param);
end loop;
end if;
@@ -1050,8 +1068,6 @@ package body Sem_Ch3 is
-- Start of processing for Access_Subprogram_Declaration
begin
- Check_SPARK_05_Restriction ("access type is not allowed", T_Def);
-
-- Associate the Itype node with the inner full-type declaration or
-- subprogram spec or entry body. This is required to handle nested
-- anonymous declarations. For example:
@@ -1062,20 +1078,18 @@ package body Sem_Ch3 is
-- (Z : access T)))
D_Ityp := Associated_Node_For_Itype (Desig_Type);
- while not (Nkind_In (D_Ityp, N_Full_Type_Declaration,
- N_Private_Type_Declaration,
- N_Private_Extension_Declaration,
- N_Procedure_Specification,
- N_Function_Specification,
- N_Entry_Body)
-
- or else
- Nkind_In (D_Ityp, N_Object_Declaration,
- N_Object_Renaming_Declaration,
- N_Formal_Object_Declaration,
- N_Formal_Type_Declaration,
- N_Task_Type_Declaration,
- N_Protected_Type_Declaration))
+ while Nkind (D_Ityp) not in N_Full_Type_Declaration
+ | N_Private_Type_Declaration
+ | N_Private_Extension_Declaration
+ | N_Procedure_Specification
+ | N_Function_Specification
+ | N_Entry_Body
+ | N_Object_Declaration
+ | N_Object_Renaming_Declaration
+ | N_Formal_Object_Declaration
+ | N_Formal_Type_Declaration
+ | N_Task_Type_Declaration
+ | N_Protected_Type_Declaration
loop
D_Ityp := Parent (D_Ityp);
pragma Assert (D_Ityp /= Empty);
@@ -1083,15 +1097,14 @@ package body Sem_Ch3 is
Set_Associated_Node_For_Itype (Desig_Type, D_Ityp);
- if Nkind_In (D_Ityp, N_Procedure_Specification,
- N_Function_Specification)
+ if Nkind (D_Ityp) in N_Procedure_Specification | N_Function_Specification
then
Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp)));
- elsif Nkind_In (D_Ityp, N_Full_Type_Declaration,
- N_Object_Declaration,
- N_Object_Renaming_Declaration,
- N_Formal_Type_Declaration)
+ elsif Nkind (D_Ityp) in N_Full_Type_Declaration
+ | N_Object_Declaration
+ | N_Object_Renaming_Declaration
+ | N_Formal_Type_Declaration
then
Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp)));
end if;
@@ -1198,22 +1211,6 @@ package body Sem_Ch3 is
begin
F := First (Formals);
- -- In ASIS mode, the access_to_subprogram may be analyzed twice,
- -- when it is part of an unconstrained type and subtype expansion
- -- is disabled. To avoid back-end problems with shared profiles,
- -- use previous subprogram type as the designated type, and then
- -- remove scope added above.
-
- if ASIS_Mode and then Present (Scope (Defining_Identifier (F)))
- then
- Set_Etype (T_Name, T_Name);
- Init_Size_Align (T_Name);
- Set_Directly_Designated_Type (T_Name,
- Scope (Defining_Identifier (F)));
- End_Scope;
- return;
- end if;
-
while Present (F) loop
if No (Parent (Defining_Identifier (F))) then
Set_Parent (Defining_Identifier (F), F);
@@ -1327,8 +1324,6 @@ package body Sem_Ch3 is
Full_Desig : Entity_Id;
begin
- Check_SPARK_05_Restriction ("access type is not allowed", Def);
-
-- Check for permissible use of incomplete type
if Nkind (S) /= N_Subtype_Indication then
@@ -1415,6 +1410,26 @@ package body Sem_Ch3 is
Set_Is_Tagged_Type (T, False);
end if;
+ -- For SPARK, check that the designated type is compatible with
+ -- respect to volatility with the access type.
+
+ if SPARK_Mode /= Off
+ and then Comes_From_Source (T)
+ then
+ -- ??? UNIMPLEMENTED
+ -- In the case where the designated type is incomplete at this point,
+ -- performing this check here is harmless but the check will need to
+ -- be repeated when the designated type is complete.
+
+ -- The preceding call to Comes_From_Source is needed because the
+ -- FE sometimes introduces implicitly declared access types. See,
+ -- for example, the expansion of nested_po.ads in OA28-015.
+
+ Check_Volatility_Compatibility
+ (Full_Desig, T, "designated type", "access type",
+ Srcpos_Bearer => T);
+ end if;
+
Set_Etype (T, T);
-- If the type has appeared already in a with_type clause, it is frozen
@@ -1800,13 +1815,9 @@ package body Sem_Ch3 is
-- of locally defined tagged types (or compiling with static
-- dispatch tables generation disabled) the corresponding
-- entry of the secondary dispatch table is filled when such
- -- an entity is frozen. This is an expansion activity that must
- -- be suppressed for ASIS because it leads to gigi elaboration
- -- issues in annotate mode.
+ -- an entity is frozen.
- if not ASIS_Mode then
- Set_Has_Delayed_Freeze (New_Subp);
- end if;
+ Set_Has_Delayed_Freeze (New_Subp);
end if;
<<Continue>>
@@ -1943,10 +1954,6 @@ package body Sem_Ch3 is
T := Find_Type_Of_Object
(Subtype_Indication (Component_Definition (N)), N);
- if not Nkind_In (Typ, N_Identifier, N_Expanded_Name) then
- Check_SPARK_05_Restriction ("subtype mark required", Typ);
- end if;
-
-- Ada 2005 (AI-230): Access Definition case
else
@@ -1997,7 +2004,6 @@ package body Sem_Ch3 is
-- package Sem).
if Present (E) then
- Check_SPARK_05_Restriction ("default expression is not allowed", E);
Preanalyze_Default_Expression (E, T);
Check_Initialization (T, E);
@@ -2340,9 +2346,9 @@ package body Sem_Ch3 is
-- because they have already been resolved.
elsif Decls = Visible_Declarations (Context)
- and then Ekind_In (Typ, E_Limited_Private_Type,
- E_Private_Type,
- E_Record_Type_With_Private)
+ and then Ekind (Typ) in E_Limited_Private_Type
+ | E_Private_Type
+ | E_Record_Type_With_Private
and then Has_Own_Invariants (Typ)
then
Build_Invariant_Procedure_Body
@@ -2354,7 +2360,8 @@ package body Sem_Ch3 is
-- potential errors.
elsif Decls = Private_Declarations (Context)
- and then not Is_Private_Type (Typ)
+ and then (not Is_Private_Type (Typ)
+ or else Present (Underlying_Full_View (Typ)))
and then Has_Private_Declaration (Typ)
and then Has_Invariants (Typ)
then
@@ -2460,7 +2467,7 @@ package body Sem_Ch3 is
end if;
exit when Last_Entity (Current_Scope) = Curr;
- Curr := Next_Entity (Curr);
+ Next_Entity (Curr);
end loop;
end if;
@@ -2486,9 +2493,9 @@ package body Sem_Ch3 is
-- controlled primitives.
if Nkind (Body_Spec) /= N_Procedure_Specification
- or else not Nam_In (Chars (Body_Id), Name_Adjust,
- Name_Finalize,
- Name_Initialize)
+ or else Chars (Body_Id) not in Name_Adjust
+ | Name_Finalize
+ | Name_Initialize
then
return;
@@ -2523,7 +2530,7 @@ package body Sem_Ch3 is
Spec_Id := Current_Entity (Body_Id);
while Present (Spec_Id) loop
- if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure)
+ if Ekind (Spec_Id) in E_Procedure | E_Generic_Procedure
and then Scope (Spec_Id) = Current_Scope
and then Present (First_Formal (Spec_Id))
and then No (Next_Formal (First_Formal (Spec_Id)))
@@ -2613,32 +2620,16 @@ package body Sem_Ch3 is
-- Local variables
Context : Node_Id := Empty;
+ Ctrl_Typ : Entity_Id := Empty;
Freeze_From : Entity_Id := Empty;
Next_Decl : Node_Id;
- Body_Seen : Boolean := False;
- -- Flag set when the first body [stub] is encountered
-
-- Start of processing for Analyze_Declarations
begin
- if Restriction_Check_Required (SPARK_05) then
- Check_Later_Vs_Basic_Declarations (L, During_Parsing => False);
- end if;
-
Decl := First (L);
while Present (Decl) loop
- -- Package spec cannot contain a package declaration in SPARK
-
- if Nkind (Decl) = N_Package_Declaration
- and then Nkind (Parent (L)) = N_Package_Specification
- then
- Check_SPARK_05_Restriction
- ("package specification cannot contain a package declaration",
- Decl);
- end if;
-
-- Complete analysis of declaration
Analyze (Decl);
@@ -2648,6 +2639,16 @@ package body Sem_Ch3 is
Freeze_From := First_Entity (Current_Scope);
end if;
+ -- Remember if the declaration we just processed is the full type
+ -- declaration of a controlled type (to handle late overriding of
+ -- initialize, adjust or finalize).
+
+ if Nkind (Decl) = N_Full_Type_Declaration
+ and then Is_Controlled (Defining_Identifier (Decl))
+ then
+ Ctrl_Typ := Defining_Identifier (Decl);
+ end if;
+
-- At the end of a declarative part, freeze remaining entities
-- declared in it. The end of the visible declarations of package
-- specification is not the end of a declarative part if private
@@ -2668,8 +2669,8 @@ package body Sem_Ch3 is
if Nkind (Parent (L)) = N_Component_List then
null;
- elsif Nkind_In (Parent (L), N_Protected_Definition,
- N_Task_Definition)
+ elsif Nkind (Parent (L)) in
+ N_Protected_Definition | N_Task_Definition
then
Check_Entry_Contracts;
@@ -2695,7 +2696,7 @@ package body Sem_Ch3 is
and then Present (First_Entity (Current_Scope))
then
while Is_Generic_Formal (Freeze_From) loop
- Freeze_From := Next_Entity (Freeze_From);
+ Next_Entity (Freeze_From);
end loop;
Freeze_All (Freeze_From, Decl);
@@ -2703,14 +2704,7 @@ package body Sem_Ch3 is
else
-- For declarations in a subprogram body there is no issue
- -- with name resolution in aspect specifications, but in
- -- ASIS mode we need to preanalyze aspect specifications
- -- that may otherwise only be analyzed during expansion
- -- (e.g. during generation of a related subprogram).
-
- if ASIS_Mode then
- Resolve_Aspects;
- end if;
+ -- with name resolution in aspect specifications.
Freeze_All (First_Entity (Current_Scope), Decl);
Freeze_From := Last_Entity (Current_Scope);
@@ -2736,16 +2730,6 @@ package body Sem_Ch3 is
-- End of a package declaration
- -- In compilation mode the expansion of freeze node takes care
- -- of resolving expressions of all aspects in the list. In ASIS
- -- mode this must be done explicitly.
-
- if ASIS_Mode
- and then Scope (Current_Scope) = Standard_Standard
- then
- Resolve_Aspects;
- end if;
-
-- This is a freeze point because it is the end of a
-- compilation unit.
@@ -2807,29 +2791,20 @@ package body Sem_Ch3 is
-- to examine Next_Decl as the late primitive idiom can only apply
-- to the first encountered body.
- -- The spec of the late primitive is not generated in ASIS mode to
- -- ensure a consistent list of primitives that indicates the true
- -- semantic structure of the program (which is not relevant when
- -- generating executable code).
-
-- ??? A cleaner approach may be possible and/or this solution
-- could be extended to general-purpose late primitives, TBD.
- if not ASIS_Mode
- and then not Body_Seen
- and then not Is_Body (Decl)
- then
- Body_Seen := True;
+ if Present (Ctrl_Typ) then
- if Nkind (Next_Decl) = N_Subprogram_Body then
- Handle_Late_Controlled_Primitive (Next_Decl);
- end if;
+ -- No need to continue searching for late body overriding if
+ -- the controlled type is already frozen.
- else
- -- In ASIS mode, if the next declaration is a body, complete
- -- the analysis of declarations so far.
+ if Is_Frozen (Ctrl_Typ) then
+ Ctrl_Typ := Empty;
- Resolve_Aspects;
+ elsif Nkind (Next_Decl) = N_Subprogram_Body then
+ Handle_Late_Controlled_Primitive (Next_Decl);
+ end if;
end if;
Adjust_Decl;
@@ -2851,7 +2826,7 @@ package body Sem_Ch3 is
if Present (L) then
Context := Parent (L);
- -- Certain contract annocations have forward visibility semantics and
+ -- Certain contract annotations have forward visibility semantics and
-- must be analyzed after all declarative items have been processed.
-- This timing ensures that entities referenced by such contracts are
-- visible.
@@ -3126,16 +3101,10 @@ package body Sem_Ch3 is
when N_Derived_Type_Definition =>
null;
- -- For record types, discriminants are allowed, unless we are in
- -- SPARK.
+ -- For record types, discriminants are allowed.
when N_Record_Definition =>
- if Present (Discriminant_Specifications (N)) then
- Check_SPARK_05_Restriction
- ("discriminant type is not allowed",
- Defining_Identifier
- (First (Discriminant_Specifications (N))));
- end if;
+ null;
when others =>
if Present (Discriminant_Specifications (N)) then
@@ -3175,6 +3144,17 @@ package body Sem_Ch3 is
Validate_Access_Type_Declaration (T, N);
+ -- If the type has contracts, we create the corresponding
+ -- wrapper at once, before analyzing the aspect specifications,
+ -- so that pre/postconditions can be handled directly on the
+ -- generated wrapper.
+
+ if Ada_Version >= Ada_2020
+ and then Present (Aspect_Specifications (N))
+ then
+ Build_Access_Subprogram_Wrapper (N);
+ end if;
+
when N_Access_To_Object_Definition =>
Access_Type_Declaration (T, Def);
@@ -3246,12 +3226,6 @@ package body Sem_Ch3 is
return;
end if;
- -- Controlled type is not allowed in SPARK
-
- if Is_Visibly_Controlled (T) then
- Check_SPARK_05_Restriction ("controlled type is not allowed", N);
- end if;
-
-- Some common processing for all types
Set_Depends_On_Private (T, Has_Private_Component (T));
@@ -3393,8 +3367,6 @@ package body Sem_Ch3 is
T : Entity_Id;
begin
- Check_SPARK_05_Restriction ("incomplete type is not allowed", N);
-
Generate_Definition (Defining_Identifier (N));
-- Process an incomplete declaration. The identifier must not have been
@@ -3638,7 +3610,7 @@ package body Sem_Ch3 is
return;
end if;
- if Nkind_In (E, N_Integer_Literal, N_Real_Literal) then
+ if Nkind (E) in N_Integer_Literal | N_Real_Literal then
Set_Etype (E, Etype (Id));
end if;
@@ -3699,7 +3671,7 @@ package body Sem_Ch3 is
-- has aspects that require delayed analysis, the resolution of the
-- aggregate must be deferred to the freeze point of the object. This
-- special processing was created for address clauses, but it must
- -- also apply to Alignment. This must be done before the aspect
+ -- also apply to address aspects. This must be done before the aspect
-- specifications are analyzed because we must handle the aggregate
-- before the analysis of the object declaration is complete.
@@ -3847,7 +3819,7 @@ package body Sem_Ch3 is
while Present (Comp) loop
Check_Component (Etype (Comp), Parent (Comp));
- Comp := Next_Component (Comp);
+ Next_Component (Comp);
end loop;
end if;
end Check_Component;
@@ -3922,10 +3894,12 @@ package body Sem_Ch3 is
begin
if Present (Aspect_Specifications (N)) then
- A := First (Aspect_Specifications (N));
- A_Id := Get_Aspect_Id (Chars (Identifier (A)));
+ A := First (Aspect_Specifications (N));
+
while Present (A) loop
- if A_Id = Aspect_Alignment or else A_Id = Aspect_Address then
+ A_Id := Get_Aspect_Id (Chars (Identifier (A)));
+
+ if A_Id = Aspect_Address then
-- Set flag on object entity, for later processing at
-- the freeze point.
@@ -4078,7 +4052,7 @@ package body Sem_Ch3 is
then
null;
- else
+ elsif Comes_From_Source (Id) then
declare
Save_Typ : constant Entity_Id := Etype (Id);
begin
@@ -4205,38 +4179,10 @@ package body Sem_Ch3 is
Act_T := T;
- -- These checks should be performed before the initialization expression
- -- is considered, so that the Object_Definition node is still the same
- -- as in source code.
-
- -- In SPARK, the nominal subtype is always given by a subtype mark
- -- and must not be unconstrained. (The only exception to this is the
- -- acceptance of declarations of constants of type String.)
-
- if not Nkind_In (Object_Definition (N), N_Expanded_Name, N_Identifier)
- then
- Check_SPARK_05_Restriction
- ("subtype mark required", Object_Definition (N));
-
- elsif Is_Array_Type (T)
- and then not Is_Constrained (T)
- and then T /= Standard_String
- then
- Check_SPARK_05_Restriction
- ("subtype mark of constrained type expected",
- Object_Definition (N));
- end if;
-
if Is_Library_Level_Entity (Id) then
Check_Dynamic_Object (T);
end if;
- -- There are no aliased objects in SPARK
-
- if Aliased_Present (N) then
- Check_SPARK_05_Restriction ("aliased object is not allowed", N);
- end if;
-
-- Process initialization expression if present and not in error
if Present (E) and then E /= Error then
@@ -4263,7 +4209,7 @@ package body Sem_Ch3 is
Analyze (E);
-- In case of errors detected in the analysis of the expression,
- -- decorate it with the expected type to avoid cascaded errors
+ -- decorate it with the expected type to avoid cascaded errors.
if No (Etype (E)) then
Set_Etype (E, T);
@@ -4310,7 +4256,11 @@ package body Sem_Ch3 is
-- If the aggregate is limited it will be built in place, and its
-- expansion is deferred until the object declaration is expanded.
- if Is_Limited_Type (T) then
+ -- This is also required when generating C code to ensure that an
+ -- object with an alignment or address clause can be initialized
+ -- by means of component by component assignments.
+
+ if Is_Limited_Type (T) or else Modify_Tree_For_C then
Set_Expansion_Delayed (E);
end if;
@@ -4427,18 +4377,6 @@ package body Sem_Ch3 is
Apply_Scalar_Range_Check (E, T);
Apply_Static_Length_Check (E, T);
- if Nkind (Original_Node (N)) = N_Object_Declaration
- and then Comes_From_Source (Original_Node (N))
-
- -- Only call test if needed
-
- and then Restriction_Check_Required (SPARK_05)
- and then not Is_SPARK_05_Initialization_Expr (Original_Node (E))
- then
- Check_SPARK_05_Restriction
- ("initialization expression is not appropriate", E);
- end if;
-
-- A formal parameter of a specific tagged type whose related
-- subprogram is subject to pragma Extensions_Visible with value
-- "False" cannot be implicitly converted to a class-wide type by
@@ -4476,15 +4414,16 @@ package body Sem_Ch3 is
-- We need a predicate check if the type has predicates that are not
-- ignored, and if either there is an initializing expression, or for
-- default initialization when we have at least one case of an explicit
- -- default initial value and then this is not an internal declaration
- -- whose initialization comes later (as for an aggregate expansion).
+ -- default initial value (including via a Default_Value or
+ -- Default_Component_Value aspect, see AI12-0301) and then this is not
+ -- an internal declaration whose initialization comes later (as for an
+ -- aggregate expansion).
-- If expression is an aggregate it may be expanded into assignments
-- and the declaration itself is marked with No_Initialization, but
-- the predicate still applies.
if not Suppress_Assignment_Checks (N)
- and then Present (Predicate_Function (T))
- and then not Predicates_Ignored (T)
+ and then Predicate_Enabled (T)
and then
(not No_Initialization (N)
or else (Present (E) and then Nkind (E) = N_Aggregate))
@@ -4536,14 +4475,6 @@ package body Sem_Ch3 is
if not Is_Definite_Subtype (T) then
- -- In SPARK, a declaration of unconstrained type is allowed
- -- only for constants of type string.
-
- if Is_String_Type (T) and then not Constant_Present (N) then
- Check_SPARK_05_Restriction
- ("declaration of object of unconstrained type not allowed", N);
- end if;
-
-- Nothing to do in deferred constant case
if Constant_Present (N) and then No (E) then
@@ -4637,16 +4568,26 @@ package body Sem_Ch3 is
Set_Ekind (Id, E_Variable);
end if;
- Rewrite (N,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Id,
- Subtype_Mark => New_Occurrence_Of (T, Loc),
- Name => E));
+ -- If the expression is an aggregate it contains the required
+ -- discriminant values but it has not been resolved yet, so do
+ -- it now, and treat it as the initial expression of an object
+ -- declaration, rather than a renaming.
- Set_Renamed_Object (Id, E);
- Freeze_Before (N, T);
- Set_Is_Frozen (Id);
- goto Leave;
+ if Nkind (E) = N_Aggregate then
+ Analyze_And_Resolve (E, T);
+
+ else
+ Rewrite (N,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Id,
+ Subtype_Mark => New_Occurrence_Of (T, Loc),
+ Name => E));
+
+ Set_Renamed_Object (Id, E);
+ Freeze_Before (N, T);
+ Set_Is_Frozen (Id);
+ goto Leave;
+ end if;
else
-- Ensure that the generated subtype has a unique external name
@@ -5142,7 +5083,7 @@ package body Sem_Ch3 is
("parent of type extension must be a tagged type ", Indic);
goto Leave;
- elsif Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then
+ elsif Ekind (Parent_Type) in E_Void | E_Incomplete_Type then
Error_Msg_N ("premature derivation of incomplete type", Indic);
goto Leave;
@@ -5339,7 +5280,6 @@ package body Sem_Ch3 is
Skip : Boolean := False)
is
Id : constant Entity_Id := Defining_Identifier (N);
- R_Checks : Check_Result;
T : Entity_Id;
begin
@@ -5441,58 +5381,6 @@ package body Sem_Ch3 is
end if;
end if;
- -- Subtype of Boolean cannot have a constraint in SPARK
-
- if Is_Boolean_Type (T)
- and then Nkind (Subtype_Indication (N)) = N_Subtype_Indication
- then
- Check_SPARK_05_Restriction
- ("subtype of Boolean cannot have constraint", N);
- end if;
-
- if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
- declare
- Cstr : constant Node_Id := Constraint (Subtype_Indication (N));
- One_Cstr : Node_Id;
- Low : Node_Id;
- High : Node_Id;
-
- begin
- if Nkind (Cstr) = N_Index_Or_Discriminant_Constraint then
- One_Cstr := First (Constraints (Cstr));
- while Present (One_Cstr) loop
-
- -- Index or discriminant constraint in SPARK must be a
- -- subtype mark.
-
- if not
- Nkind_In (One_Cstr, N_Identifier, N_Expanded_Name)
- then
- Check_SPARK_05_Restriction
- ("subtype mark required", One_Cstr);
-
- -- String subtype must have a lower bound of 1 in SPARK.
- -- Note that we do not need to test for the nonstatic case
- -- here, since that was already taken care of in
- -- Process_Range_Expr_In_Decl.
-
- elsif Base_Type (T) = Standard_String then
- Get_Index_Bounds (One_Cstr, Low, High);
-
- if Is_OK_Static_Expression (Low)
- and then Expr_Value (Low) /= 1
- then
- Check_SPARK_05_Restriction
- ("String subtype must have lower bound of 1", N);
- end if;
- end if;
-
- Next (One_Cstr);
- end loop;
- end if;
- end;
- end if;
-
-- In the case where there is no constraint given in the subtype
-- indication, Process_Subtype just returns the Subtype_Mark, so its
-- semantic attributes must be established here.
@@ -5500,14 +5388,6 @@ package body Sem_Ch3 is
if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
Set_Etype (Id, Base_Type (T));
- -- Subtype of unconstrained array without constraint is not allowed
- -- in SPARK.
-
- if Is_Array_Type (T) and then not Is_Constrained (T) then
- Check_SPARK_05_Restriction
- ("subtype of unconstrained array must have constraint", N);
- end if;
-
case Ekind (T) is
when Array_Kind =>
Set_Ekind (Id, E_Array_Subtype);
@@ -5571,6 +5451,7 @@ package body Sem_Ch3 is
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
Set_Cloned_Subtype (Id, T);
Set_Is_Tagged_Type (Id, True);
+ Set_Is_Limited_Record (Id, Is_Limited_Record (T));
Set_Has_Unknown_Discriminants
(Id, True);
Set_No_Tagged_Streams_Pragma
@@ -5835,6 +5716,17 @@ package body Sem_Ch3 is
end if;
end if;
+ -- If the base type is a scalar type, or else if there is no
+ -- constraint, the atomic flag is inherited by the subtype.
+ -- Ditto for the Independent aspect.
+
+ if Is_Scalar_Type (Id)
+ or else Is_Entity_Name (Subtype_Indication (N))
+ then
+ Set_Is_Atomic (Id, Is_Atomic (T));
+ Set_Is_Independent (Id, Is_Independent (T));
+ end if;
+
-- Remaining processing depends on characteristics of base type
T := Etype (Id);
@@ -5845,6 +5737,7 @@ package body Sem_Ch3 is
if Is_Interface (T) then
Set_Is_Interface (Id);
+ Set_Is_Limited_Interface (Id, Is_Limited_Interface (T));
end if;
if Present (Generic_Parent_Type (N))
@@ -5913,33 +5806,28 @@ package body Sem_Ch3 is
-- Check that Constraint_Error is raised for a scalar subtype indication
-- when the lower or upper bound of a non-null range lies outside the
- -- range of the type mark.
+ -- range of the type mark. Likewise for an array subtype, but check the
+ -- compatibility for each index.
if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
- if Is_Scalar_Type (Etype (Id))
- and then Scalar_Range (Id) /=
- Scalar_Range
- (Etype (Subtype_Mark (Subtype_Indication (N))))
- then
- Apply_Range_Check
- (Scalar_Range (Id),
- Etype (Subtype_Mark (Subtype_Indication (N))));
-
- -- In the array case, check compatibility for each index
+ declare
+ Indic_Typ : constant Entity_Id :=
+ Etype (Subtype_Mark (Subtype_Indication (N)));
+ Subt_Index : Node_Id;
+ Target_Index : Node_Id;
- elsif Is_Array_Type (Etype (Id)) and then Present (First_Index (Id))
- then
- -- This really should be a subprogram that finds the indications
- -- to check???
+ begin
+ if Is_Scalar_Type (Etype (Id))
+ and then Scalar_Range (Id) /= Scalar_Range (Indic_Typ)
+ then
+ Apply_Range_Check (Scalar_Range (Id), Indic_Typ);
- declare
- Subt_Index : Node_Id := First_Index (Id);
- Target_Index : Node_Id :=
- First_Index (Etype
- (Subtype_Mark (Subtype_Indication (N))));
- Has_Dyn_Chk : Boolean := Has_Dynamic_Range_Check (N);
+ elsif Is_Array_Type (Etype (Id))
+ and then Present (First_Index (Id))
+ then
+ Subt_Index := First_Index (Id);
+ Target_Index := First_Index (Indic_Typ);
- begin
while Present (Subt_Index) loop
if ((Nkind (Subt_Index) = N_Identifier
and then Ekind (Entity (Subt_Index)) in Scalar_Kind)
@@ -5947,47 +5835,17 @@ package body Sem_Ch3 is
and then
Nkind (Scalar_Range (Etype (Subt_Index))) = N_Range
then
- declare
- Target_Typ : constant Entity_Id :=
- Etype (Target_Index);
- begin
- R_Checks :=
- Get_Range_Checks
- (Scalar_Range (Etype (Subt_Index)),
- Target_Typ,
- Etype (Subt_Index),
- Defining_Identifier (N));
-
- -- Reset Has_Dynamic_Range_Check on the subtype to
- -- prevent elision of the index check due to a dynamic
- -- check generated for a preceding index (needed since
- -- Insert_Range_Checks tries to avoid generating
- -- redundant checks on a given declaration).
-
- Set_Has_Dynamic_Range_Check (N, False);
-
- Insert_Range_Checks
- (R_Checks,
- N,
- Target_Typ,
- Sloc (Defining_Identifier (N)));
-
- -- Record whether this index involved a dynamic check
-
- Has_Dyn_Chk :=
- Has_Dyn_Chk or else Has_Dynamic_Range_Check (N);
- end;
+ Apply_Range_Check
+ (Scalar_Range (Etype (Subt_Index)),
+ Etype (Target_Index),
+ Insert_Node => N);
end if;
Next_Index (Subt_Index);
Next_Index (Target_Index);
end loop;
-
- -- Finally, mark whether the subtype involves dynamic checks
-
- Set_Has_Dynamic_Range_Check (N, Has_Dyn_Chk);
- end;
- end if;
+ end if;
+ end;
end if;
Set_Optimize_Alignment_Flags (Id);
@@ -6162,14 +6020,8 @@ package body Sem_Ch3 is
Set_Etype (Index, Standard_Boolean);
end if;
- -- Check SPARK restriction requiring a subtype mark
-
- if not Nkind_In (Index, N_Identifier, N_Expanded_Name) then
- Check_SPARK_05_Restriction ("subtype mark required", Index);
- end if;
-
-- Add a subtype declaration for each index of private array type
- -- declaration whose etype is also private. For example:
+ -- declaration whose type is also private. For example:
-- package Pkg is
-- type Index is private;
@@ -6179,11 +6031,14 @@ package body Sem_Ch3 is
-- This is currently required by the expander for the internally
-- generated equality subprogram of records with variant parts in
- -- which the etype of some component is such private type.
+ -- which the type of some component is such a private type. And it
+ -- also helps semantic analysis in peculiar cases where the array
+ -- type is referenced from an instance but not the index directly.
- if Ekind (Current_Scope) = E_Package
+ if Is_Package_Or_Generic_Package (Current_Scope)
and then In_Private_Part (Current_Scope)
and then Has_Private_Declaration (Etype (Index))
+ and then Scope (Etype (Index)) = Current_Scope
then
declare
Loc : constant Source_Ptr := Sloc (Def);
@@ -6240,14 +6095,8 @@ package body Sem_Ch3 is
if Present (Component_Typ) then
Element_Type := Process_Subtype (Component_Typ, P, Related_Id, 'C');
-
Set_Etype (Component_Typ, Element_Type);
- if not Nkind_In (Component_Typ, N_Identifier, N_Expanded_Name) then
- Check_SPARK_05_Restriction
- ("subtype mark required", Component_Typ);
- end if;
-
-- Ada 2005 (AI-230): Access Definition case
else pragma Assert (Present (Access_Definition (Component_Def)));
@@ -6358,8 +6207,6 @@ package body Sem_Ch3 is
Set_Packed_Array_Impl_Type (T, Empty);
if Aliased_Present (Component_Definition (Def)) then
- Check_SPARK_05_Restriction
- ("aliased is not allowed", Component_Definition (Def));
Set_Has_Aliased_Components (Etype (T));
-- AI12-001: All aliased objects are considered to be specified as
@@ -6529,61 +6376,6 @@ package body Sem_Ch3 is
Mark_Rewrite_Insertion (Decl);
- -- In ASIS mode, analyze the profile on the original node, because
- -- the separate copy does not provide enough links to recover the
- -- original tree. Analysis is limited to type annotations, within
- -- a temporary scope that serves as an anonymous subprogram to collect
- -- otherwise useless temporaries and itypes.
-
- if ASIS_Mode then
- declare
- Typ : constant Entity_Id := Make_Temporary (Loc, 'S');
-
- begin
- if Nkind (Spec) = N_Access_Function_Definition then
- Set_Ekind (Typ, E_Function);
- else
- Set_Ekind (Typ, E_Procedure);
- end if;
-
- Set_Parent (Typ, N);
- Set_Scope (Typ, Current_Scope);
- Push_Scope (Typ);
-
- -- Nothing to do if procedure is parameterless
-
- if Present (Parameter_Specifications (Spec)) then
- Process_Formals (Parameter_Specifications (Spec), Spec);
- end if;
-
- if Nkind (Spec) = N_Access_Function_Definition then
- declare
- Def : constant Node_Id := Result_Definition (Spec);
-
- begin
- -- The result might itself be an anonymous access type, so
- -- have to recurse.
-
- if Nkind (Def) = N_Access_Definition then
- if Present (Access_To_Subprogram_Definition (Def)) then
- Set_Etype
- (Def,
- Replace_Anonymous_Access_To_Protected_Subprogram
- (Spec));
- else
- Find_Type (Subtype_Mark (Def));
- end if;
-
- else
- Find_Type (Def);
- end if;
- end;
- end if;
-
- End_Scope;
- end;
- end if;
-
-- Insert the new declaration in the nearest enclosing scope. If the
-- parent is a body and N is its return type, the declaration belongs
-- in the enclosing scope. Likewise if N is the type of a parameter.
@@ -6643,7 +6435,7 @@ package body Sem_Ch3 is
Mark_Rewrite_Insertion (Comp);
- if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition)
+ if Nkind (N) in N_Object_Declaration | N_Access_Function_Definition
or else (Nkind (Parent (N)) = N_Full_Type_Declaration
and then not Is_Type (Current_Scope))
then
@@ -6669,6 +6461,144 @@ package body Sem_Ch3 is
return Anon;
end Replace_Anonymous_Access_To_Protected_Subprogram;
+ -------------------------------------
+ -- Build_Access_Subprogram_Wrapper --
+ -------------------------------------
+
+ procedure Build_Access_Subprogram_Wrapper (Decl : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Id : constant Entity_Id := Defining_Identifier (Decl);
+ Type_Def : constant Node_Id := Type_Definition (Decl);
+ Specs : constant List_Id :=
+ Parameter_Specifications (Type_Def);
+ Profile : constant List_Id := New_List;
+ Subp : constant Entity_Id := Make_Temporary (Loc, 'A');
+
+ Contracts : constant List_Id := New_List;
+ Form_P : Node_Id;
+ New_P : Node_Id;
+ New_Decl : Node_Id;
+ Spec : Node_Id;
+
+ procedure Replace_Type_Name (Expr : Node_Id);
+ -- In the expressions for contract aspects, replace occurrences of the
+ -- access type with the name of the subprogram entity, as needed, e.g.
+ -- for 'Result. Aspects that are not contracts, e.g. Size or Alignment)
+ -- remain on the original access type declaration. What about expanded
+ -- names denoting formals, whose prefix in source is the type name ???
+
+ -----------------------
+ -- Replace_Type_Name --
+ -----------------------
+
+ procedure Replace_Type_Name (Expr : Node_Id) is
+ function Process (N : Node_Id) return Traverse_Result;
+ function Process (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (N))
+ and then Chars (Prefix (N)) = Chars (Id)
+ then
+ Set_Prefix (N, Make_Identifier (Sloc (N), Chars (Subp)));
+ end if;
+
+ return OK;
+ end Process;
+
+ procedure Traverse is new Traverse_Proc (Process);
+ begin
+ Traverse (Expr);
+ end Replace_Type_Name;
+
+ begin
+ if Ekind (Id) in E_Access_Subprogram_Type
+ | E_Access_Protected_Subprogram_Type
+ | E_Anonymous_Access_Protected_Subprogram_Type
+ | E_Anonymous_Access_Subprogram_Type
+ then
+ null;
+
+ else
+ Error_Msg_N
+ ("illegal pre/postcondition on access type", Decl);
+ return;
+ end if;
+
+ declare
+ Asp : Node_Id;
+ A_Id : Aspect_Id;
+ Cond : Node_Id;
+ Expr : Node_Id;
+
+ begin
+ Asp := First (Aspect_Specifications (Decl));
+ while Present (Asp) loop
+ A_Id := Get_Aspect_Id (Chars (Identifier (Asp)));
+ if A_Id = Aspect_Pre or else A_Id = Aspect_Post then
+ Cond := Asp;
+ Expr := Expression (Cond);
+ Replace_Type_Name (Expr);
+ Next (Asp);
+
+ Remove (Cond);
+ Append (Cond, Contracts);
+
+ else
+ Next (Asp);
+ end if;
+ end loop;
+ end;
+
+ -- If there are no contract aspects, no need for a wrapper.
+
+ if Is_Empty_List (Contracts) then
+ return;
+ end if;
+
+ Form_P := First (Specs);
+
+ while Present (Form_P) loop
+ New_P := New_Copy_Tree (Form_P);
+ Set_Defining_Identifier (New_P,
+ Make_Defining_Identifier
+ (Loc, Chars (Defining_Identifier (Form_P))));
+ Append (New_P, Profile);
+ Next (Form_P);
+ end loop;
+
+ -- Add to parameter specifications the access parameter that is passed
+ -- in from an indirect call.
+
+ Append (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'P'),
+ Parameter_Type => New_Occurrence_Of (Id, Loc)),
+ Profile);
+
+ if Nkind (Type_Def) = N_Access_Procedure_Definition then
+ Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Subp,
+ Parameter_Specifications => Profile);
+ else
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Subp,
+ Parameter_Specifications => Profile,
+ Result_Definition =>
+ New_Copy_Tree
+ (Result_Definition (Type_Definition (Decl))));
+ end if;
+
+ New_Decl :=
+ Make_Subprogram_Declaration (Loc, Specification => Spec);
+ Set_Aspect_Specifications (New_Decl, Contracts);
+
+ Insert_After (Decl, New_Decl);
+ Set_Access_Subprogram_Wrapper (Designated_Type (Id), Subp);
+ Build_Access_Subprogram_Wrapper_Body (Decl, New_Decl);
+ end Build_Access_Subprogram_Wrapper;
+
-------------------------------
-- Build_Derived_Access_Type --
-------------------------------
@@ -7133,14 +7063,13 @@ package body Sem_Ch3 is
Error_Msg_NE
("new discriminant& must constrain old one", N, New_Disc);
- elsif not
- Subtypes_Statically_Compatible
- (Etype (New_Disc),
- Etype (Corresponding_Discriminant (New_Disc)))
- then
- Error_Msg_NE
- ("& not statically compatible with parent discriminant",
- N, New_Disc);
+ -- If a new discriminant is used in the constraint, then its
+ -- subtype must be statically compatible with the subtype of
+ -- the parent discriminant (RM 3.7(15)).
+
+ else
+ Check_Constraining_Discriminant
+ (New_Disc, Corresponding_Discriminant (New_Disc));
end if;
Next_Discriminant (New_Disc);
@@ -7513,6 +7442,7 @@ package body Sem_Ch3 is
Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base));
Set_Parent (Implicit_Base, Parent (Derived_Type));
Set_Is_Known_Valid (Implicit_Base, Is_Known_Valid (Parent_Base));
+ Set_Is_Volatile (Implicit_Base, Is_Volatile (Parent_Base));
-- Set RM Size for discrete type or decimal fixed-point type
-- Ordinary fixed-point is excluded, why???
@@ -7696,6 +7626,10 @@ package body Sem_Ch3 is
Full_Der : Entity_Id := New_Copy (Derived_Type);
Full_P : Entity_Id;
+ function Available_Full_View (Typ : Entity_Id) return Entity_Id;
+ -- Return the Full_View or Underlying_Full_View of Typ, whichever is
+ -- present (they cannot be both present for the same type), or Empty.
+
procedure Build_Full_Derivation;
-- Build full derivation, i.e. derive from the full view
@@ -7703,6 +7637,32 @@ package body Sem_Ch3 is
-- Copy derived type declaration, replace parent with its full view,
-- and build derivation
+ -------------------------
+ -- Available_Full_View --
+ -------------------------
+
+ function Available_Full_View (Typ : Entity_Id) return Entity_Id is
+ begin
+ if Present (Full_View (Typ)) then
+ return Full_View (Typ);
+
+ elsif Present (Underlying_Full_View (Typ)) then
+
+ -- We should be called on a type with an underlying full view
+ -- only by means of the recursive call made in Copy_And_Build
+ -- through the first call to Build_Derived_Type, or else if
+ -- the parent scope is being analyzed because we are deriving
+ -- a completion.
+
+ pragma Assert (Is_Completion or else In_Private_Part (Par_Scope));
+
+ return Underlying_Full_View (Typ);
+
+ else
+ return Empty;
+ end if;
+ end Available_Full_View;
+
---------------------------
-- Build_Full_Derivation --
---------------------------
@@ -7722,7 +7682,9 @@ package body Sem_Ch3 is
-- part of a child unit. In that case retrieve the full view of
-- the parent momentarily.
- elsif not In_Same_Source_Unit (N, Parent_Type) then
+ elsif not In_Same_Source_Unit (N, Parent_Type)
+ and then Present (Full_View (Parent_Type))
+ then
Full_P := Full_View (Parent_Type);
Exchange_Declarations (Parent_Type);
Copy_And_Build;
@@ -7753,19 +7715,28 @@ package body Sem_Ch3 is
Full_Parent := Full_View (Full_Parent);
end if;
- -- And its underlying full view if necessary
+ -- If the full view is itself derived from another private type
+ -- and has got an underlying full view, and this is done for a
+ -- completion, i.e. to build the underlying full view of the type,
+ -- then use this underlying full view. We cannot do that if this
+ -- is not a completion, i.e. to build the full view of the type,
+ -- because this would break the privacy of the parent type, except
+ -- if the parent scope is being analyzed because we are deriving a
+ -- completion.
if Is_Private_Type (Full_Parent)
and then Present (Underlying_Full_View (Full_Parent))
+ and then (Is_Completion or else In_Private_Part (Par_Scope))
then
Full_Parent := Underlying_Full_View (Full_Parent);
end if;
- -- For record, concurrent, access and most enumeration types, the
- -- derivation from full view requires a fully-fledged declaration.
- -- In the other cases, just use an itype.
+ -- For private, record, concurrent, access and almost all enumeration
+ -- types, the derivation from the full view requires a fully-fledged
+ -- declaration. In the other cases, just use an itype.
- if Is_Record_Type (Full_Parent)
+ if Is_Private_Type (Full_Parent)
+ or else Is_Record_Type (Full_Parent)
or else Is_Concurrent_Type (Full_Parent)
or else Is_Access_Type (Full_Parent)
or else
@@ -7812,9 +7783,13 @@ package body Sem_Ch3 is
end if;
else
+ -- If the parent type is private, this is not a completion and
+ -- we build the full derivation recursively as a completion.
+
Build_Derived_Type
(Full_N, Full_Parent, Full_Der,
- Is_Completion => False, Derive_Subps => False);
+ Is_Completion => Is_Private_Type (Full_Parent),
+ Derive_Subps => False);
end if;
-- The full declaration has been introduced into the tree and
@@ -8002,7 +7977,7 @@ package body Sem_Ch3 is
-- case (see point 5. of its head comment) since we build it for the
-- derived subtype.
- if Present (Full_View (Parent_Type))
+ if Present (Available_Full_View (Parent_Type))
and then not Is_Itype (Derived_Type)
then
declare
@@ -8054,8 +8029,8 @@ package body Sem_Ch3 is
end;
end if;
- elsif Present (Full_View (Parent_Type))
- and then Has_Discriminants (Full_View (Parent_Type))
+ elsif Present (Available_Full_View (Parent_Type))
+ and then Has_Discriminants (Available_Full_View (Parent_Type))
then
if Has_Unknown_Discriminants (Parent_Type)
and then Nkind (Subtype_Indication (Type_Definition (N))) =
@@ -8092,7 +8067,7 @@ package body Sem_Ch3 is
Set_Stored_Constraint (Derived_Type, No_Elist);
Set_Is_Constrained
- (Derived_Type, Is_Constrained (Full_View (Parent_Type)));
+ (Derived_Type, Is_Constrained (Available_Full_View (Parent_Type)));
else
-- Untagged type, No discriminants on either view
@@ -8105,8 +8080,8 @@ package body Sem_Ch3 is
end if;
if Present (Discriminant_Specifications (N))
- and then Present (Full_View (Parent_Type))
- and then not Is_Tagged_Type (Full_View (Parent_Type))
+ and then Present (Available_Full_View (Parent_Type))
+ and then not Is_Tagged_Type (Available_Full_View (Parent_Type))
then
Error_Msg_N ("cannot add discriminants to untagged type", N);
end if;
@@ -8131,18 +8106,26 @@ package body Sem_Ch3 is
end if;
-- If this is not a completion, construct the implicit full view by
- -- deriving from the full view of the parent type.
+ -- deriving from the full view of the parent type. But if this is a
+ -- completion, the derived private type being built is a full view
+ -- and the full derivation can only be its underlying full view.
- -- ??? If the parent is untagged private and its completion is
+ -- ??? If the parent type is untagged private and its completion is
-- tagged, this mechanism will not work because we cannot derive from
-- the tagged full view unless we have an extension.
- if Present (Full_View (Parent_Type))
- and then not Is_Tagged_Type (Full_View (Parent_Type))
- and then not Is_Completion
+ if Present (Available_Full_View (Parent_Type))
+ and then not Is_Tagged_Type (Available_Full_View (Parent_Type))
+ and then not Error_Posted (N)
then
Build_Full_Derivation;
- Set_Full_View (Derived_Type, Full_Der);
+
+ if not Is_Completion then
+ Set_Full_View (Derived_Type, Full_Der);
+ else
+ Set_Underlying_Full_View (Derived_Type, Full_Der);
+ Set_Is_Underlying_Full_View (Full_Der);
+ end if;
end if;
end if;
@@ -9260,41 +9243,13 @@ package body Sem_Ch3 is
end if;
-- If a new discriminant is used in the constraint, then its
- -- subtype must be statically compatible with the parent
- -- discriminant's subtype (3.7(15)).
-
- -- However, if the record contains an array constrained by
- -- the discriminant but with some different bound, the compiler
- -- tries to create a smaller range for the discriminant type.
- -- (See exp_ch3.Adjust_Discriminants). In this case, where
- -- the discriminant type is a scalar type, the check must use
- -- the original discriminant type in the parent declaration.
-
- declare
- Corr_Disc : constant Entity_Id :=
- Corresponding_Discriminant (Discrim);
- Disc_Type : constant Entity_Id := Etype (Discrim);
- Corr_Type : Entity_Id;
-
- begin
- if Present (Corr_Disc) then
- if Is_Scalar_Type (Disc_Type) then
- Corr_Type :=
- Entity (Discriminant_Type (Parent (Corr_Disc)));
- else
- Corr_Type := Etype (Corr_Disc);
- end if;
+ -- subtype must be statically compatible with the subtype of
+ -- the parent discriminant (RM 3.7(15)).
- if not
- Subtypes_Statically_Compatible (Disc_Type, Corr_Type)
- then
- Error_Msg_N
- ("subtype must be compatible "
- & "with parent discriminant",
- Discrim);
- end if;
- end if;
- end;
+ if Present (Corresponding_Discriminant (Discrim)) then
+ Check_Constraining_Discriminant
+ (Discrim, Corresponding_Discriminant (Discrim));
+ end if;
Next_Discriminant (Discrim);
end loop;
@@ -9628,7 +9583,7 @@ package body Sem_Ch3 is
Set_Stored_Constraint
(Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs));
- Replace_Components (Derived_Type, New_Decl);
+ Replace_Discriminants (Derived_Type, New_Decl);
end if;
-- Insert the new derived type declaration
@@ -9650,10 +9605,6 @@ package body Sem_Ch3 is
elsif not Private_Extension then
Expand_Record_Extension (Derived_Type, Type_Def);
- -- Note : previously in ASIS mode we set the Parent_Subtype of the
- -- derived type to propagate some semantic information. This led
- -- to other ASIS failures and has been removed.
-
-- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
-- implemented interfaces if we are in expansion mode
@@ -10526,9 +10477,9 @@ package body Sem_Ch3 is
-- build-in-place library function, child unit or not.
if (Nkind (Nod) in N_Entity and then Is_Compilation_Unit (Nod))
- or else (Nkind_In (Nod, N_Defining_Program_Unit_Name,
- N_Subprogram_Declaration)
- and then Is_Compilation_Unit (Defining_Entity (Nod)))
+ or else (Nkind (Nod) in
+ N_Defining_Program_Unit_Name | N_Subprogram_Declaration
+ and then Is_Compilation_Unit (Defining_Entity (Nod)))
then
Add_Global_Declaration (IR);
else
@@ -10558,7 +10509,7 @@ package body Sem_Ch3 is
Analyze_And_Resolve (Bound, Base_Type (Par_T));
- if Nkind_In (Bound, N_Integer_Literal, N_Real_Literal) then
+ if Nkind (Bound) in N_Integer_Literal | N_Real_Literal then
New_Bound := New_Copy (Bound);
Set_Etype (New_Bound, Der_T);
Set_Analyzed (New_Bound);
@@ -10808,6 +10759,26 @@ package body Sem_Ch3 is
elsif Present (Interface_Alias (Subp)) then
null;
+ -- AI12-0042: Test for rule in 7.3.2(6.1/4), that requires overriding
+ -- of a visible private primitive inherited from an ancestor with
+ -- the aspect Type_Invariant'Class, unless the inherited primitive
+ -- is abstract.
+
+ elsif not Is_Abstract_Subprogram (Subp)
+ and then not Comes_From_Source (Subp) -- An inherited subprogram
+ and then Requires_Overriding (Subp)
+ and then Present (Alias_Subp)
+ and then Has_Invariants (Etype (T))
+ and then Present (Get_Pragma (Etype (T), Pragma_Invariant))
+ and then Class_Present (Get_Pragma (Etype (T), Pragma_Invariant))
+ and then Is_Private_Primitive (Alias_Subp)
+ then
+ Error_Msg_NE
+ ("inherited private primitive & must be overridden", T, Subp);
+ Error_Msg_N
+ ("\because ancestor type has 'Type_'Invariant''Class " &
+ "(RM 7.3.2(6.1))", T);
+
elsif (Is_Abstract_Subprogram (Subp)
or else Requires_Overriding (Subp)
or else
@@ -11046,6 +11017,20 @@ package body Sem_Ch3 is
end if;
end if;
+ -- Ada 2005 (AI95-0414) and Ada 2020 (AI12-0269): Diagnose failure to
+ -- match No_Return in parent, but do it unconditionally in Ada 95 too
+ -- for procedures, since this is our pragma.
+
+ if Present (Overridden_Operation (Subp))
+ and then No_Return (Overridden_Operation (Subp))
+ and then not No_Return (Subp)
+ then
+ Error_Msg_N ("overriding subprogram & must be No_Return", Subp);
+ Error_Msg_N
+ ("\since overridden subprogram is No_Return (RM 6.5.1(6/2))",
+ Subp);
+ end if;
+
-- If the operation is a wrapper for a synchronized primitive, it
-- may be called indirectly through a dispatching select. We assume
-- that it will be referenced elsewhere indirectly, and suppress
@@ -11482,28 +11467,6 @@ package body Sem_Ch3 is
if Present (Acc_Def) then
Create_Extra_Formals (Designated_Type (Anon_Access));
-
- -- If an access to object, preserve entity of designated type,
- -- for ASIS use, before rewriting the component definition.
-
- else
- declare
- Desig : Entity_Id;
-
- begin
- Desig := Entity (Subtype_Indication (Type_Def));
-
- -- If the access definition is to the current record,
- -- the visible entity at this point is an incomplete
- -- type. Retrieve the full view to simplify ASIS queries
-
- if Ekind (Desig) = E_Incomplete_Type then
- Desig := Full_View (Desig);
- end if;
-
- Set_Entity
- (Subtype_Mark (Access_Definition (Comp_Def)), Desig);
- end;
end if;
Rewrite (Comp_Def,
@@ -11577,7 +11540,7 @@ package body Sem_Ch3 is
begin
if not Comes_From_Source (E) then
- if Ekind_In (E, E_Task_Type, E_Protected_Type) then
+ if Ekind (E) in E_Task_Type | E_Protected_Type then
-- It may be an anonymous protected type created for a
-- single variable. Post error on variable, if present.
@@ -11707,10 +11670,10 @@ package body Sem_Ch3 is
-- this kind is reserved for predefined operators, that are
-- intrinsic and do not need completion.
- elsif Ekind_In (E, E_Function,
- E_Procedure,
- E_Generic_Function,
- E_Generic_Procedure)
+ elsif Ekind (E) in E_Function
+ | E_Procedure
+ | E_Generic_Function
+ | E_Generic_Procedure
then
if Has_Completion (E) then
null;
@@ -11740,9 +11703,8 @@ package body Sem_Ch3 is
end if;
elsif Is_Entry (E) then
- if not Has_Completion (E) and then
- (Ekind (Scope (E)) = E_Protected_Object
- or else Ekind (Scope (E)) = E_Protected_Type)
+ if not Has_Completion (E)
+ and then Ekind (Scope (E)) = E_Protected_Type
then
Post_Error;
end if;
@@ -11763,33 +11725,30 @@ package body Sem_Ch3 is
-- A formal incomplete type (Ada 2012) does not require a completion;
-- other incomplete type declarations do.
- elsif Ekind (E) = E_Incomplete_Type
- and then No (Underlying_Type (E))
- and then not Is_Generic_Type (E)
- then
- Post_Error;
+ elsif Ekind (E) = E_Incomplete_Type then
+ if No (Underlying_Type (E))
+ and then not Is_Generic_Type (E)
+ then
+ Post_Error;
+ end if;
- elsif Ekind_In (E, E_Task_Type, E_Protected_Type)
- and then not Has_Completion (E)
- then
- Post_Error;
+ elsif Ekind (E) in E_Task_Type | E_Protected_Type then
+ if not Has_Completion (E) then
+ Post_Error;
+ end if;
-- A single task declared in the current scope is a constant, verify
-- that the body of its anonymous type is in the same scope. If the
-- task is defined elsewhere, this may be a renaming declaration for
-- which no completion is needed.
- elsif Ekind (E) = E_Constant
- and then Ekind (Etype (E)) = E_Task_Type
- and then not Has_Completion (Etype (E))
- and then Scope (Etype (E)) = Current_Scope
- then
- Post_Error;
-
- elsif Ekind (E) = E_Protected_Object
- and then not Has_Completion (Etype (E))
- then
- Post_Error;
+ elsif Ekind (E) = E_Constant then
+ if Ekind (Etype (E)) = E_Task_Type
+ and then not Has_Completion (Etype (E))
+ and then Scope (Etype (E)) = Current_Scope
+ then
+ Post_Error;
+ end if;
elsif Ekind (E) = E_Record_Type then
if Is_Tagged_Type (E) then
@@ -11808,6 +11767,41 @@ package body Sem_Ch3 is
end loop;
end Check_Completion;
+ -------------------------------------
+ -- Check_Constraining_Discriminant --
+ -------------------------------------
+
+ procedure Check_Constraining_Discriminant (New_Disc, Old_Disc : Entity_Id)
+ is
+ New_Type : constant Entity_Id := Etype (New_Disc);
+ Old_Type : Entity_Id;
+
+ begin
+ -- If the record type contains an array constrained by the discriminant
+ -- but with some different bound, the compiler tries to create a smaller
+ -- range for the discriminant type (see exp_ch3.Adjust_Discriminants).
+ -- In this case, where the discriminant type is a scalar type, the check
+ -- must use the original discriminant type in the parent declaration.
+
+ if Is_Scalar_Type (New_Type) then
+ Old_Type := Entity (Discriminant_Type (Parent (Old_Disc)));
+ else
+ Old_Type := Etype (Old_Disc);
+ end if;
+
+ if not Subtypes_Statically_Compatible (New_Type, Old_Type) then
+ Error_Msg_N
+ ("subtype must be statically compatible with parent discriminant",
+ New_Disc);
+
+ if not Predicates_Compatible (New_Type, Old_Type) then
+ Error_Msg_N
+ ("\subtype predicate is not compatible with parent discriminant",
+ New_Disc);
+ end if;
+ end if;
+ end Check_Constraining_Discriminant;
+
------------------------------------
-- Check_CPP_Type_Has_No_Defaults --
------------------------------------
@@ -11978,7 +11972,7 @@ package body Sem_Ch3 is
-- In gnatc or gnatprove mode, make sure set Do_Range_Check flag gets
-- set unless we can be sure that no range check is required.
- if (GNATprove_Mode or not Expander_Active)
+ if not Expander_Active
and then Is_Scalar_Type (T)
and then not Is_In_Range (Exp, T, Assume_Valid => True)
then
@@ -12544,18 +12538,11 @@ package body Sem_Ch3 is
-- Show Full is simply a renaming of Full_Base
Set_Cloned_Subtype (Full, Full_Base);
+ Set_Is_Limited_Record (Full, Is_Limited_Record (Full_Base));
-- Propagate predicates
- if Has_Predicates (Full_Base) then
- Set_Has_Predicates (Full);
-
- if Present (Predicate_Function (Full_Base))
- and then No (Predicate_Function (Full))
- then
- Set_Predicate_Function (Full, Predicate_Function (Full_Base));
- end if;
- end if;
+ Propagate_Predicate_Attributes (Full, Full_Base);
end if;
-- It is unsafe to share the bounds of a scalar type, because the Itype
@@ -12587,11 +12574,18 @@ package body Sem_Ch3 is
if Is_Tagged_Type (Full_Base) then
Set_Is_Tagged_Type (Full);
+ Set_Is_Limited_Record (Full, Is_Limited_Record (Full_Base));
+
Set_Direct_Primitive_Operations
(Full, Direct_Primitive_Operations (Full_Base));
Set_No_Tagged_Streams_Pragma
(Full, No_Tagged_Streams_Pragma (Full_Base));
+ if Is_Interface (Full_Base) then
+ Set_Is_Interface (Full);
+ Set_Is_Limited_Interface (Full, Is_Limited_Interface (Full_Base));
+ end if;
+
-- Inherit class_wide type of full_base in case the partial view was
-- not tagged. Otherwise it has already been created when the private
-- subtype was analyzed.
@@ -12700,15 +12694,7 @@ package body Sem_Ch3 is
-- of the type or at the end of the visible part, and we must avoid
-- generating them twice.
- if Has_Predicates (Priv) then
- Set_Has_Predicates (Full);
-
- if Present (Predicate_Function (Priv))
- and then No (Predicate_Function (Full))
- then
- Set_Predicate_Function (Full, Predicate_Function (Priv));
- end if;
- end if;
+ Propagate_Predicate_Attributes (Full, Priv);
if Has_Delayed_Aspects (Priv) then
Set_Has_Delayed_Aspects (Full);
@@ -13311,15 +13297,11 @@ package body Sem_Ch3 is
-- Ditto for access types. Makes use of previous two functions, to
-- constrain designated type.
- function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id;
- -- T is an array or discriminated type, C is a list of constraints
- -- that apply to T. This routine builds the constrained subtype.
-
function Is_Discriminant (Expr : Node_Id) return Boolean;
-- Returns True if Expr is a discriminant
- function Get_Discr_Value (Discrim : Entity_Id) return Node_Id;
- -- Find the value of discriminant Discrim in Constraint
+ function Get_Discr_Value (Discr_Expr : Node_Id) return Node_Id;
+ -- Find the value of a discriminant named by Discr_Expr in Constraints
-----------------------------------
-- Build_Constrained_Access_Type --
@@ -13334,7 +13316,7 @@ package body Sem_Ch3 is
Scop : Entity_Id;
begin
- -- if the original access type was not embedded in the enclosing
+ -- If the original access type was not embedded in the enclosing
-- type definition, there is no need to produce a new access
-- subtype. In fact every access type with an explicit constraint
-- generates an itype whose scope is the enclosing record.
@@ -13433,6 +13415,7 @@ package body Sem_Ch3 is
Is_Discriminant (Hi_Expr)
then
Need_To_Create_Itype := True;
+ exit;
end if;
Next_Index (Old_Index);
@@ -13462,7 +13445,7 @@ package body Sem_Ch3 is
Next_Index (Old_Index);
end loop;
- return Build_Subtype (Old_Type, Constr_List);
+ return Build_Subtype (Related_Node, Loc, Old_Type, Constr_List);
else
return Old_Type;
@@ -13489,6 +13472,7 @@ package body Sem_Ch3 is
if Is_Discriminant (Expr) then
Need_To_Create_Itype := True;
+ exit;
-- After expansion of discriminated task types, the value
-- of the discriminant may be converted to a run-time type
@@ -13500,6 +13484,7 @@ package body Sem_Ch3 is
and then Is_Discriminant (Expression (Expr))
then
Need_To_Create_Itype := True;
+ exit;
end if;
Next_Elmt (Old_Constraint);
@@ -13527,86 +13512,22 @@ package body Sem_Ch3 is
Next_Elmt (Old_Constraint);
end loop;
- return Build_Subtype (Old_Type, Constr_List);
+ return Build_Subtype (Related_Node, Loc, Old_Type, Constr_List);
else
return Old_Type;
end if;
end Build_Constrained_Discriminated_Type;
- -------------------
- -- Build_Subtype --
- -------------------
-
- function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is
- Indic : Node_Id;
- Subtyp_Decl : Node_Id;
- Def_Id : Entity_Id;
- Btyp : Entity_Id := Base_Type (T);
-
- begin
- -- The Related_Node better be here or else we won't be able to
- -- attach new itypes to a node in the tree.
-
- pragma Assert (Present (Related_Node));
-
- -- If the view of the component's type is incomplete or private
- -- with unknown discriminants, then the constraint must be applied
- -- to the full type.
-
- if Has_Unknown_Discriminants (Btyp)
- and then Present (Underlying_Type (Btyp))
- then
- Btyp := Underlying_Type (Btyp);
- end if;
-
- Indic :=
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
- Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C));
-
- Def_Id := Create_Itype (Ekind (T), Related_Node);
-
- Subtyp_Decl :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Subtype_Indication => Indic);
-
- Set_Parent (Subtyp_Decl, Parent (Related_Node));
-
- -- Itypes must be analyzed with checks off (see package Itypes)
-
- Analyze (Subtyp_Decl, Suppress => All_Checks);
-
- if Is_Itype (Def_Id) and then Has_Predicates (T) then
- Inherit_Predicate_Flags (Def_Id, T);
-
- -- Indicate where the predicate function may be found
-
- if Is_Itype (T) then
- if Present (Predicate_Function (Def_Id)) then
- null;
-
- elsif Present (Predicate_Function (T)) then
- Set_Predicate_Function (Def_Id, Predicate_Function (T));
-
- else
- Set_Predicated_Parent (Def_Id, Predicated_Parent (T));
- end if;
-
- elsif No (Predicate_Function (Def_Id)) then
- Set_Predicated_Parent (Def_Id, T);
- end if;
- end if;
-
- return Def_Id;
- end Build_Subtype;
-
---------------------
-- Get_Discr_Value --
---------------------
- function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is
+ function Get_Discr_Value (Discr_Expr : Node_Id) return Node_Id is
+ Discr_Id : constant Entity_Id := Entity (Discr_Expr);
+ -- Entity of a discriminant that appear as a standalone expression in
+ -- the constraint of a component.
+
D : Entity_Id;
E : Elmt_Id;
@@ -13622,9 +13543,9 @@ package body Sem_Ch3 is
E := First_Elmt (Constraints);
while Present (D) loop
- if D = Entity (Discrim)
- or else D = CR_Discriminant (Entity (Discrim))
- or else Corresponding_Discriminant (D) = Entity (Discrim)
+ if D = Discr_Id
+ or else D = CR_Discriminant (Discr_Id)
+ or else Corresponding_Discriminant (D) = Discr_Id
then
return Node (E);
end if;
@@ -13644,12 +13565,12 @@ package body Sem_Ch3 is
-- be present when the component is a discriminated task type?
if Is_Derived_Type (Typ)
- and then Scope (Entity (Discrim)) = Etype (Typ)
+ and then Scope (Discr_Id) = Etype (Typ)
then
D := First_Discriminant (Etype (Typ));
E := First_Elmt (Constraints);
while Present (D) loop
- if D = Entity (Discrim) then
+ if D = Discr_Id then
return Node (E);
end if;
@@ -13879,8 +13800,6 @@ package body Sem_Ch3 is
else
pragma Assert (Nkind (C) = N_Digits_Constraint);
- Check_SPARK_05_Restriction ("digits constraint is not allowed", S);
-
Digits_Expr := Digits_Expression (C);
Analyze_And_Resolve (Digits_Expr, Any_Integer);
@@ -14122,8 +14041,6 @@ package body Sem_Ch3 is
-- Digits constraint present
if Nkind (C) = N_Digits_Constraint then
-
- Check_SPARK_05_Restriction ("digits constraint is not allowed", S);
Check_Restriction (No_Obsolescent_Features, C);
if Warn_On_Obsolescent_Feature then
@@ -14356,8 +14273,6 @@ package body Sem_Ch3 is
-- Delta constraint present
if Nkind (C) = N_Delta_Constraint then
-
- Check_SPARK_05_Restriction ("delta constraint is not allowed", S);
Check_Restriction (No_Obsolescent_Features, C);
if Warn_On_Obsolescent_Feature then
@@ -14699,7 +14614,7 @@ package body Sem_Ch3 is
if Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
Old_C := First_Component (Typ);
while Present (Old_C) loop
- if Nam_In (Chars (Old_C), Name_uTag, Name_uParent) then
+ if Chars (Old_C) in Name_uTag | Name_uParent then
Append_Elmt (Old_C, Comp_List);
end if;
@@ -15003,8 +14918,6 @@ package body Sem_Ch3 is
Bound_Val : Ureal;
begin
- Check_SPARK_05_Restriction
- ("decimal fixed point type is not allowed", Def);
Check_Restriction (No_Fixed_Point, Def);
-- Create implicit base type
@@ -15546,9 +15459,9 @@ package body Sem_Ch3 is
or else Is_Private_Overriding
or else Is_Internal_Name (Chars (Parent_Subp))
or else (Is_Controlled (Parent_Type)
- and then Nam_In (Chars (Parent_Subp), Name_Adjust,
- Name_Finalize,
- Name_Initialize))
+ and then Chars (Parent_Subp) in Name_Adjust
+ | Name_Finalize
+ | Name_Initialize)
then
Set_Derived_Name;
@@ -15640,6 +15553,15 @@ package body Sem_Ch3 is
while Present (Formal) loop
New_Formal := New_Copy (Formal);
+ -- Extra formals are not inherited from a limited interface parent
+ -- since limitedness is not inherited in such case (AI-419) and this
+ -- affects the extra formals.
+
+ if Is_Limited_Interface (Parent_Type) then
+ Set_Extra_Formal (New_Formal, Empty);
+ Set_Extra_Accessibility (New_Formal, Empty);
+ end if;
+
-- Normally we do not go copying parents, but in the case of
-- formals, we need to link up to the declaration (which is the
-- parameter specification), and it is fine to link up to the
@@ -15658,6 +15580,22 @@ package body Sem_Ch3 is
Next_Formal (Formal);
end loop;
+ -- Extra formals are shared between the parent subprogram and the
+ -- derived subprogram (implicit in the above copy of formals), unless
+ -- the parent type is a limited interface type; hence we must inherit
+ -- also the reference to the first extra formal. When the parent type is
+ -- an interface the extra formals will be added when the subprogram is
+ -- frozen (see Freeze.Freeze_Subprogram).
+
+ if not Is_Limited_Interface (Parent_Type) then
+ Set_Extra_Formals (New_Subp, Extra_Formals (Parent_Subp));
+
+ if Ekind (New_Subp) = E_Function then
+ Set_Extra_Accessibility_Of_Result (New_Subp,
+ Extra_Accessibility_Of_Result (Parent_Subp));
+ end if;
+ end if;
+
-- If this derivation corresponds to a tagged generic actual, then
-- primitive operations rename those of the actual. Otherwise the
-- primitive operations rename those of the parent type, If the parent
@@ -15722,9 +15660,9 @@ package body Sem_Ch3 is
-- set on both views of the type.
if Is_Controlled (Parent_Type)
- and then Nam_In (Chars (Parent_Subp), Name_Initialize,
- Name_Adjust,
- Name_Finalize)
+ and then Chars (Parent_Subp) in Name_Initialize
+ | Name_Adjust
+ | Name_Finalize
and then Is_Hidden (Parent_Subp)
and then not Is_Visibly_Controlled (Parent_Type)
then
@@ -15743,9 +15681,9 @@ package body Sem_Ch3 is
end if;
-- No_Return must be inherited properly. If this is overridden in the
- -- case of a dispatching operation, then a check is made in Sem_Disp
- -- that the overriding operation is also No_Return (no such check is
- -- required for the case of non-dispatching operation.
+ -- case of a dispatching operation, then the check is made later in
+ -- Check_Abstract_Overriding that the overriding operation is also
+ -- No_Return (no such check is required for the nondispatching case).
Set_No_Return (New_Subp, No_Return (Parent_Subp));
@@ -15763,6 +15701,9 @@ package body Sem_Ch3 is
-- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract"
-- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2).
+ -- Ada 202x (AI12-0042): Similarly, set those properties for
+ -- implementing the rule of RM 7.3.2(6.1/4).
+
-- A subprogram subject to pragma Extensions_Visible with value False
-- requires overriding if the subprogram has at least one controlling
-- OUT parameter (SPARK RM 6.1.7(6)).
@@ -15779,7 +15720,26 @@ package body Sem_Ch3 is
Derived_Type
and then not Is_Null_Extension (Derived_Type))
or else (Comes_From_Source (Alias (New_Subp))
- and then Is_EVF_Procedure (Alias (New_Subp))))
+ and then Is_EVF_Procedure (Alias (New_Subp)))
+
+ -- AI12-0042: Set Requires_Overriding when a type extension
+ -- inherits a private operation that is visible at the
+ -- point of extension (Has_Private_Ancestor is False) from
+ -- an ancestor that has Type_Invariant'Class, and when the
+ -- type extension is in a visible part (the latter as
+ -- clarified by AI12-0382).
+
+ or else
+ (not Has_Private_Ancestor (Derived_Type)
+ and then Has_Invariants (Parent_Type)
+ and then
+ Present (Get_Pragma (Parent_Type, Pragma_Invariant))
+ and then
+ Class_Present
+ (Get_Pragma (Parent_Type, Pragma_Invariant))
+ and then Is_Private_Primitive (Parent_Subp)
+ and then In_Visible_Part (Scope (Derived_Type))))
+
and then No (Actual_Subp)
then
if not Is_Tagged_Type (Derived_Type)
@@ -15898,6 +15858,17 @@ package body Sem_Ch3 is
if Ekind (New_Subp) = E_Function then
Set_Mechanism (New_Subp, Mechanism (Parent_Subp));
end if;
+
+ -- Ada 2020 (AI12-0279): If a Yield aspect is specified True for a
+ -- primitive subprogram S of a type T, then the aspect is inherited
+ -- by the corresponding primitive subprogram of each descendant of T.
+
+ if Is_Tagged_Type (Derived_Type)
+ and then Is_Dispatching_Operation (New_Subp)
+ and then Has_Yield_Aspect (Alias (New_Subp))
+ then
+ Set_Has_Yield_Aspect (New_Subp, Has_Yield_Aspect (Alias (New_Subp)));
+ end if;
end Derive_Subprogram;
------------------------
@@ -15955,7 +15926,7 @@ package body Sem_Ch3 is
return True;
end if;
- E := Next_Entity (E);
+ Next_Entity (E);
end loop;
List := Collect_Primitive_Operations (Derived_Type);
@@ -16646,8 +16617,6 @@ package body Sem_Ch3 is
-- parent is also an interface.
if Interface_Present (Def) then
- Check_SPARK_05_Restriction ("interface is not allowed", Def);
-
if not Is_Interface (Parent_Type) then
Diagnose_Interface (Indic, Parent_Type);
@@ -16893,11 +16862,6 @@ package body Sem_Ch3 is
if Is_Type (T) then
Set_Has_Discriminants (T, False);
end if;
-
- -- The type is allowed to have discriminants
-
- else
- Check_SPARK_05_Restriction ("discriminant type is not allowed", N);
end if;
end if;
@@ -16917,7 +16881,7 @@ package body Sem_Ch3 is
-- Check for early use of incomplete or private type
- if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then
+ if Ekind (Parent_Type) in E_Void | E_Incomplete_Type then
Error_Msg_N ("premature derivation of incomplete type", Indic);
return;
@@ -17084,14 +17048,6 @@ package body Sem_Ch3 is
end if;
end if;
end if;
-
- -- In SPARK, there are no derived type definitions other than type
- -- extensions of tagged record types.
-
- if No (Extension) then
- Check_SPARK_05_Restriction
- ("derived type is not allowed", Original_Node (N));
- end if;
end Derived_Type_Declaration;
------------------------
@@ -17462,14 +17418,14 @@ package body Sem_Ch3 is
-- Check invalid completion of private or incomplete type
- elsif not Nkind_In (N, N_Full_Type_Declaration,
- N_Task_Type_Declaration,
- N_Protected_Type_Declaration)
+ elsif Nkind (N) not in N_Full_Type_Declaration
+ | N_Task_Type_Declaration
+ | N_Protected_Type_Declaration
and then
(Ada_Version < Ada_2012
or else not Is_Incomplete_Type (Prev)
- or else not Nkind_In (N, N_Private_Type_Declaration,
- N_Private_Extension_Declaration))
+ or else Nkind (N) not in N_Private_Type_Declaration
+ | N_Private_Extension_Declaration)
then
-- Completion must be a full type declarations (RM 7.3(4))
@@ -17546,9 +17502,8 @@ package body Sem_Ch3 is
end if;
if Nkind (N) = N_Full_Type_Declaration
- and then Nkind_In
- (Type_Definition (N), N_Record_Definition,
- N_Derived_Type_Definition)
+ and then Nkind (Type_Definition (N)) in
+ N_Record_Definition | N_Derived_Type_Definition
and then Interface_Present (Type_Definition (N))
then
Error_Msg_N
@@ -17565,15 +17520,15 @@ package body Sem_Ch3 is
New_Id := Id;
elsif Ekind (Prev) = E_Private_Type
- and then Nkind_In (N, N_Task_Type_Declaration,
- N_Protected_Type_Declaration)
+ and then Nkind (N) in N_Task_Type_Declaration
+ | N_Protected_Type_Declaration
then
Error_Msg_N
("completion of nonlimited type cannot be limited", N);
elsif Ekind (Prev) = E_Record_Type_With_Private
- and then Nkind_In (N, N_Task_Type_Declaration,
- N_Protected_Type_Declaration)
+ and then Nkind (N) in N_Task_Type_Declaration
+ | N_Protected_Type_Declaration
then
if not Is_Limited_Record (Prev) then
Error_Msg_N
@@ -17590,8 +17545,8 @@ package body Sem_Ch3 is
-- type or a protected type. This case arises when covering
-- interface types.
- elsif Nkind_In (N, N_Task_Type_Declaration,
- N_Protected_Type_Declaration)
+ elsif Nkind (N) in N_Task_Type_Declaration
+ | N_Protected_Type_Declaration
then
null;
@@ -17688,8 +17643,8 @@ package body Sem_Ch3 is
if Ada_Version >= Ada_2012
and then Is_Incomplete_Type (Prev)
- and then Nkind_In (N, N_Private_Type_Declaration,
- N_Private_Extension_Declaration)
+ and then Nkind (N) in N_Private_Type_Declaration
+ | N_Private_Extension_Declaration
then
-- No need to check private extensions since they are tagged
@@ -17703,8 +17658,8 @@ package body Sem_Ch3 is
-- a synchronized type that implements interfaces) or a
-- type extension, otherwise this is an error.
- elsif Nkind_In (N, N_Task_Type_Declaration,
- N_Protected_Type_Declaration)
+ elsif Nkind (N) in N_Task_Type_Declaration
+ | N_Protected_Type_Declaration
then
if No (Interface_List (N)) and then not Error_Posted (N) then
Tag_Mismatch;
@@ -17772,8 +17727,8 @@ package body Sem_Ch3 is
-- Case of an anonymous array subtype
- if Nkind_In (Def_Kind, N_Constrained_Array_Definition,
- N_Unconstrained_Array_Definition)
+ if Def_Kind in
+ N_Constrained_Array_Definition | N_Unconstrained_Array_Definition
then
T := Empty;
Array_Type_Declaration (T, Obj_Def);
@@ -17840,19 +17795,6 @@ package body Sem_Ch3 is
else
T := Process_Subtype (Obj_Def, Related_Nod);
-
- -- If expansion is disabled an object definition that is an aggregate
- -- will not get expanded and may lead to scoping problems in the back
- -- end, if the object is referenced in an inner scope. In that case
- -- create an itype reference for the object definition now. This
- -- may be redundant in some cases, but harmless.
-
- if Is_Itype (T)
- and then Nkind (Related_Nod) = N_Object_Declaration
- and then ASIS_Mode
- then
- Build_Itype_Reference (T, Related_Nod);
- end if;
end if;
return T;
@@ -18725,8 +18667,7 @@ package body Sem_Ch3 is
then
null;
- elsif Ekind_In (Derived_Base, E_Private_Type,
- E_Limited_Private_Type)
+ elsif Ekind (Derived_Base) in E_Private_Type | E_Limited_Private_Type
then
null;
@@ -18752,38 +18693,6 @@ package body Sem_Ch3 is
return Assoc_List;
end Inherit_Components;
- -----------------------------
- -- Inherit_Predicate_Flags --
- -----------------------------
-
- procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is
- begin
- if Present (Predicate_Function (Subt)) then
- return;
- end if;
-
- Set_Has_Predicates (Subt, Has_Predicates (Par));
- Set_Has_Static_Predicate_Aspect
- (Subt, Has_Static_Predicate_Aspect (Par));
- Set_Has_Dynamic_Predicate_Aspect
- (Subt, Has_Dynamic_Predicate_Aspect (Par));
-
- -- A named subtype does not inherit the predicate function of its
- -- parent but an itype declared for a loop index needs the discrete
- -- predicate information of its parent to execute the loop properly.
- -- A non-discrete type may has a static predicate (for example True)
- -- but has no static_discrete_predicate.
-
- if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then
- Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par));
-
- if Has_Static_Predicate (Par) and then Is_Discrete_Type (Par) then
- Set_Static_Discrete_Predicate
- (Subt, Static_Discrete_Predicate (Par));
- end if;
- end if;
- end Inherit_Predicate_Flags;
-
----------------------
-- Is_EVF_Procedure --
----------------------
@@ -18863,6 +18772,29 @@ package body Sem_Ch3 is
end if;
end Is_Null_Extension;
+ --------------------------
+ -- Is_Private_Primitive --
+ --------------------------
+
+ function Is_Private_Primitive (Prim : Entity_Id) return Boolean is
+ Prim_Scope : constant Entity_Id := Scope (Prim);
+ Priv_Entity : Entity_Id;
+ begin
+ if Is_Package_Or_Generic_Package (Prim_Scope) then
+ Priv_Entity := First_Private_Entity (Prim_Scope);
+
+ while Present (Priv_Entity) loop
+ if Priv_Entity = Prim then
+ return True;
+ end if;
+
+ Next_Entity (Priv_Entity);
+ end loop;
+ end if;
+
+ return False;
+ end Is_Private_Primitive;
+
------------------------------
-- Is_Valid_Constraint_Kind --
------------------------------
@@ -18879,16 +18811,13 @@ package body Sem_Ch3 is
return Constraint_Kind = N_Range_Constraint;
when Decimal_Fixed_Point_Kind =>
- return Nkind_In (Constraint_Kind, N_Digits_Constraint,
- N_Range_Constraint);
+ return Constraint_Kind in N_Digits_Constraint | N_Range_Constraint;
when Ordinary_Fixed_Point_Kind =>
- return Nkind_In (Constraint_Kind, N_Delta_Constraint,
- N_Range_Constraint);
+ return Constraint_Kind in N_Delta_Constraint | N_Range_Constraint;
when Float_Kind =>
- return Nkind_In (Constraint_Kind, N_Digits_Constraint,
- N_Range_Constraint);
+ return Constraint_Kind in N_Digits_Constraint | N_Range_Constraint;
when Access_Kind
| Array_Kind
@@ -18948,7 +18877,7 @@ package body Sem_Ch3 is
-- Start of processing for Is_Visible_Component
begin
- if Ekind_In (C, E_Component, E_Discriminant) then
+ if Ekind (C) in E_Component | E_Discriminant then
Original_Comp := Original_Record_Component (C);
end if;
@@ -18999,39 +18928,6 @@ package body Sem_Ch3 is
then
return True;
- -- In the body of an instantiation, check the visibility of a component
- -- in case it has a homograph that is a primitive operation of a private
- -- type which was not visible in the generic unit.
-
- -- Should Is_Prefixed_Call be propagated from template to instance???
-
- elsif In_Instance_Body then
- if not Is_Tagged_Type (Original_Type)
- or else not Is_Private_Type (Original_Type)
- then
- return True;
-
- else
- declare
- Subp_Elmt : Elmt_Id;
-
- begin
- Subp_Elmt := First_Elmt (Primitive_Operations (Original_Type));
- while Present (Subp_Elmt) loop
-
- -- The component is hidden by a primitive operation
-
- if Chars (Node (Subp_Elmt)) = Chars (C) then
- return False;
- end if;
-
- Next_Elmt (Subp_Elmt);
- end loop;
-
- return True;
- end;
- end if;
-
-- If the component has been declared in an ancestor which is currently
-- a private type, then it is not visible. The same applies if the
-- component's containing type is not in an open scope and the original
@@ -19040,7 +18936,9 @@ package body Sem_Ch3 is
-- a component in a sibling package that is inherited from a visible
-- component of a type in an ancestor package; the component in the
-- sibling package should not be visible even though the component it
- -- inherited from is visible). This does not apply however in the case
+ -- inherited from is visible), but instance bodies are not subject to
+ -- this second case since they have the Has_Private_View mechanism to
+ -- ensure proper visibility. This does not apply however in the case
-- where the scope of the type is a private child unit, or when the
-- parent comes from a local package in which the ancestor is currently
-- visible. The latter suppression of visibility is needed for cases
@@ -19050,7 +18948,8 @@ package body Sem_Ch3 is
or else
(not Is_Private_Descendant (Type_Scope)
and then not In_Open_Scopes (Type_Scope)
- and then Has_Private_Declaration (Original_Type))
+ and then Has_Private_Declaration (Original_Type)
+ and then not In_Instance_Body)
then
-- If the type derives from an entity in a formal package, there
-- are no additional visible components.
@@ -19221,8 +19120,7 @@ package body Sem_Ch3 is
(N : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty;
- Suffix_Index : Nat := 1;
- In_Iter_Schm : Boolean := False)
+ Suffix_Index : Nat := 1)
is
R : Node_Id;
T : Entity_Id;
@@ -19334,7 +19232,7 @@ package body Sem_Ch3 is
end if;
R := N;
- Process_Range_Expr_In_Decl (R, T, In_Iter_Schm => In_Iter_Schm);
+ Process_Range_Expr_In_Decl (R, T);
elsif Nkind (N) = N_Subtype_Indication then
@@ -19351,8 +19249,7 @@ package body Sem_Ch3 is
R := Range_Expression (Constraint (N));
Resolve (R, T);
- Process_Range_Expr_In_Decl
- (R, Entity (Subtype_Mark (N)), In_Iter_Schm => In_Iter_Schm);
+ Process_Range_Expr_In_Decl (R, Entity (Subtype_Mark (N)));
elsif Nkind (N) = N_Attribute_Reference then
@@ -19613,7 +19510,6 @@ package body Sem_Ch3 is
-- Nonbinary case
elsif M_Val < 2 ** Bits then
- Check_SPARK_05_Restriction ("modulus should be a power of 2", T);
Set_Non_Binary_Modulus (T);
if Bits > System_Max_Nonbinary_Modulus_Power then
@@ -20201,10 +20097,10 @@ package body Sem_Ch3 is
(Defining_Identifier (Discr), Expression (Discr));
end if;
- -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag
+ -- In gnatc or GNATprove mode, make sure set Do_Range_Check flag
-- gets set unless we can be sure that no range check is required.
- if (GNATprove_Mode or not Expander_Active)
+ if not Expander_Active
and then not
Is_In_Range
(Expression (Discr), Discr_Type, Assume_Valid => True)
@@ -20296,10 +20192,13 @@ package body Sem_Ch3 is
-- A discriminant cannot be effectively volatile (SPARK RM 7.1.3(4)).
-- This check is relevant only when SPARK_Mode is on as it is not a
- -- standard Ada legality rule.
+ -- standard Ada legality rule. The only way for a discriminant to be
+ -- effectively volatile is to have an effectively volatile type, so
+ -- we check this directly, because the Ekind of Discr might not be
+ -- set yet (to help preventing cascaded errors on derived types).
if SPARK_Mode = On
- and then Is_Effectively_Volatile (Defining_Identifier (Discr))
+ and then Is_Effectively_Volatile (Discr_Type)
then
Error_Msg_N ("discriminant cannot be volatile", Discr);
end if;
@@ -20621,15 +20520,6 @@ package body Sem_Ch3 is
-- ELSE.
else
- -- In formal mode, when completing a private extension the type
- -- named in the private part must be exactly the same as that
- -- named in the visible part.
-
- if Priv_Parent /= Full_Parent then
- Error_Msg_Name_1 := Chars (Priv_Parent);
- Check_SPARK_05_Restriction ("% expected", Full_Indic);
- end if;
-
-- Check the rules of 7.3(10): if the private extension inherits
-- known discriminants, then the full type must also inherit those
-- discriminants from the same (ancestor) type, and the parent
@@ -20813,9 +20703,9 @@ package body Sem_Ch3 is
Priv := Node (Priv_Elmt);
Priv_Scop := Scope (Priv);
- if Ekind_In (Priv, E_Private_Subtype,
- E_Limited_Private_Subtype,
- E_Record_Subtype_With_Private)
+ if Ekind (Priv) in E_Private_Subtype
+ | E_Limited_Private_Subtype
+ | E_Record_Subtype_With_Private
then
Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv));
Set_Is_Itype (Full);
@@ -20986,7 +20876,7 @@ package body Sem_Ch3 is
Prim := Next_Entity (Full_T);
while Present (Prim) and then Prim /= Priv_T loop
- if Ekind_In (Prim, E_Procedure, E_Function) then
+ if Ekind (Prim) in E_Procedure | E_Function then
Disp_Typ := Find_Dispatching_Type (Prim);
if Disp_Typ = Full_T
@@ -21083,16 +20973,32 @@ package body Sem_Ch3 is
end if;
-- Propagate Default_Initial_Condition-related attributes from the
- -- partial view to the full view and its base type.
+ -- partial view to the full view.
Propagate_DIC_Attributes (Full_T, From_Typ => Priv_T);
- Propagate_DIC_Attributes (Base_Type (Full_T), From_Typ => Priv_T);
+
+ -- And to the underlying full view, if any
+
+ if Is_Private_Type (Full_T)
+ and then Present (Underlying_Full_View (Full_T))
+ then
+ Propagate_DIC_Attributes
+ (Underlying_Full_View (Full_T), From_Typ => Priv_T);
+ end if;
-- Propagate invariant-related attributes from the partial view to the
- -- full view and its base type.
+ -- full view.
Propagate_Invariant_Attributes (Full_T, From_Typ => Priv_T);
- Propagate_Invariant_Attributes (Base_Type (Full_T), From_Typ => Priv_T);
+
+ -- And to the underlying full view, if any
+
+ if Is_Private_Type (Full_T)
+ and then Present (Underlying_Full_View (Full_T))
+ then
+ Propagate_Invariant_Attributes
+ (Underlying_Full_View (Full_T), From_Typ => Priv_T);
+ end if;
-- AI12-0041: Detect an attempt to inherit a class-wide type invariant
-- in the full view without advertising the inheritance in the partial
@@ -21123,12 +21029,13 @@ package body Sem_Ch3 is
-- view cannot be frozen yet, and the predicate function has not been
-- built. Still it is a cheap check and seems safer to make it.
- if Has_Predicates (Priv_T) then
- Set_Has_Predicates (Full_T);
+ Propagate_Predicate_Attributes (Full_T, Priv_T);
- if Present (Predicate_Function (Priv_T)) then
- Set_Predicate_Function (Full_T, Predicate_Function (Priv_T));
- end if;
+ if Is_Private_Type (Full_T)
+ and then Present (Underlying_Full_View (Full_T))
+ then
+ Propagate_Predicate_Attributes
+ (Underlying_Full_View (Full_T), Priv_T);
end if;
<<Leave>>
@@ -21261,9 +21168,8 @@ package body Sem_Ch3 is
(R : Node_Id;
T : Entity_Id;
Subtyp : Entity_Id := Empty;
- Check_List : List_Id := Empty_List;
- R_Check_Off : Boolean := False;
- In_Iter_Schm : Boolean := False)
+ Check_List : List_Id := No_List;
+ R_Check_Off : Boolean := False)
is
Lo, Hi : Node_Id;
R_Checks : Check_Result;
@@ -21274,16 +21180,6 @@ package body Sem_Ch3 is
Analyze_And_Resolve (R, Base_Type (T));
if Nkind (R) = N_Range then
-
- -- In SPARK, all ranges should be static, with the exception of the
- -- discrete type definition of a loop parameter specification.
-
- if not In_Iter_Schm
- and then not Is_OK_Static_Range (R)
- then
- Check_SPARK_05_Restriction ("range should be static", R);
- end if;
-
Lo := Low_Bound (R);
Hi := High_Bound (R);
@@ -21434,17 +21330,16 @@ package body Sem_Ch3 is
exit when
Nkind (Insert_Node) in N_Declaration
and then
- not Nkind_In
- (Insert_Node, N_Component_Declaration,
- N_Loop_Parameter_Specification,
- N_Function_Specification,
- N_Procedure_Specification);
-
- exit when Nkind (Insert_Node) in N_Later_Decl_Item
- or else Nkind (Insert_Node) in
- N_Statement_Other_Than_Procedure_Call
- or else Nkind_In (Insert_Node, N_Procedure_Call_Statement,
- N_Pragma);
+ Nkind (Insert_Node) not in N_Component_Declaration
+ | N_Loop_Parameter_Specification
+ | N_Function_Specification
+ | N_Procedure_Specification;
+
+ exit when Nkind (Insert_Node) in
+ N_Later_Decl_Item |
+ N_Statement_Other_Than_Procedure_Call |
+ N_Procedure_Call_Statement |
+ N_Pragma;
Insert_Node := Parent (Insert_Node);
end loop;
@@ -21477,14 +21372,17 @@ package body Sem_Ch3 is
Insert_Node,
Def_Id,
Sloc (Insert_Node),
- R,
Do_Before => True);
end if;
end;
- -- Insertion before a declaration. If the declaration
- -- includes discriminants, the list of applicable checks
- -- is given by the caller.
+ -- Case of declarations. If the declaration is for a type
+ -- and involves discriminants, the checks are premature at
+ -- the declaration point and need to wait for the expansion
+ -- of the initialization procedure, which will pass in the
+ -- list to put them on; otherwise, the checks are done at
+ -- the declaration point and there is no need to do them
+ -- again in the initialization procedure.
elsif Nkind (Insert_Node) in N_Declaration then
Def_Id := Defining_Identifier (Insert_Node);
@@ -21495,19 +21393,22 @@ package body Sem_Ch3 is
(Ekind (Def_Id) = E_Protected_Type
and then Has_Discriminants (Def_Id))
then
- Append_Range_Checks
- (R_Checks,
- Check_List, Def_Id, Sloc (Insert_Node), R);
+ if Present (Check_List) then
+ Append_Range_Checks
+ (R_Checks,
+ Check_List, Def_Id, Sloc (Insert_Node));
+ end if;
else
- Insert_Range_Checks
- (R_Checks,
- Insert_Node, Def_Id, Sloc (Insert_Node), R);
-
+ if No (Check_List) then
+ Insert_Range_Checks
+ (R_Checks,
+ Insert_Node, Def_Id, Sloc (Insert_Node));
+ end if;
end if;
- -- Insertion before a statement. Range appears in the
- -- context of a quantified expression. Insertion will
+ -- Case of statements. Drop the checks, as the range appears
+ -- in the context of a quantified expression. Insertion will
-- take place when expression is expanded.
else
@@ -21652,20 +21553,19 @@ package body Sem_Ch3 is
-- The following is ugly, can't we have a range or even a flag???
May_Have_Null_Exclusion :=
- Nkind_In (P, N_Access_Definition,
- N_Access_Function_Definition,
- N_Access_Procedure_Definition,
- N_Access_To_Object_Definition,
- N_Allocator,
- N_Component_Definition)
- or else
- Nkind_In (P, N_Derived_Type_Definition,
- N_Discriminant_Specification,
- N_Formal_Object_Declaration,
- N_Object_Declaration,
- N_Object_Renaming_Declaration,
- N_Parameter_Specification,
- N_Subtype_Declaration);
+ Nkind (P) in N_Access_Definition
+ | N_Access_Function_Definition
+ | N_Access_Procedure_Definition
+ | N_Access_To_Object_Definition
+ | N_Allocator
+ | N_Component_Definition
+ | N_Derived_Type_Definition
+ | N_Discriminant_Specification
+ | N_Formal_Object_Declaration
+ | N_Object_Declaration
+ | N_Object_Renaming_Declaration
+ | N_Parameter_Specification
+ | N_Subtype_Declaration;
-- Create an Itype that is a duplicate of Entity (S) but with the
-- null-exclusion attribute.
@@ -21997,14 +21897,6 @@ package body Sem_Ch3 is
-- Normal case
if Ada_Version < Ada_2005 or else not Interface_Present (Def) then
- if Limited_Present (Def) then
- Check_SPARK_05_Restriction ("limited is not allowed", N);
- end if;
-
- if Abstract_Present (Def) then
- Check_SPARK_05_Restriction ("abstract is not allowed", N);
- end if;
-
-- The flag Is_Tagged_Type might have already been set by
-- Find_Type_Name if it detected an error for declaration T. This
-- arises in the case of private tagged types where the full view
@@ -22028,8 +21920,6 @@ package body Sem_Ch3 is
or else Abstract_Present (Def));
else
- Check_SPARK_05_Restriction ("interface is not allowed", N);
-
Is_Tagged := True;
Analyze_Interface_Declaration (T, Def);
@@ -22171,40 +22061,6 @@ package body Sem_Ch3 is
T := Prev_T;
end if;
- -- In SPARK, tagged types and type extensions may only be declared in
- -- the specification of library unit packages.
-
- if Present (Def) and then Is_Tagged_Type (T) then
- declare
- Typ : Node_Id;
- Ctxt : Node_Id;
-
- begin
- if Nkind (Parent (Def)) = N_Full_Type_Declaration then
- Typ := Parent (Def);
- else
- pragma Assert
- (Nkind (Parent (Def)) = N_Derived_Type_Definition);
- Typ := Parent (Parent (Def));
- end if;
-
- Ctxt := Parent (Typ);
-
- if Nkind (Ctxt) = N_Package_Body
- and then Nkind (Parent (Ctxt)) = N_Compilation_Unit
- then
- Check_SPARK_05_Restriction
- ("type should be defined in package specification", Typ);
-
- elsif Nkind (Ctxt) /= N_Package_Specification
- or else Nkind (Parent (Parent (Ctxt))) /= N_Compilation_Unit
- then
- Check_SPARK_05_Restriction
- ("type should be defined in library unit package", Typ);
- end if;
- end;
- end if;
-
Final_Storage_Only := not Is_Controlled (T);
-- Ada 2005: Check whether an explicit Limited is present in a derived
@@ -22223,19 +22079,13 @@ package body Sem_Ch3 is
-- record extension, in which case the current scope may have inherited
-- components.
- if No (Def)
- or else No (Component_List (Def))
- or else Null_Present (Component_List (Def))
+ if Present (Def)
+ and then Present (Component_List (Def))
+ and then not Null_Present (Component_List (Def))
then
- if not Is_Tagged_Type (T) then
- Check_SPARK_05_Restriction ("untagged record cannot be null", Def);
- end if;
-
- else
Analyze_Declarations (Component_Items (Component_List (Def)));
if Present (Variant_Part (Component_List (Def))) then
- Check_SPARK_05_Restriction ("variant part is not allowed", Def);
Analyze (Variant_Part (Component_List (Def)));
end if;
end if;
@@ -22292,11 +22142,11 @@ package body Sem_Ch3 is
end if;
end Record_Type_Definition;
- ------------------------
- -- Replace_Components --
- ------------------------
+ ---------------------------
+ -- Replace_Discriminants --
+ ---------------------------
- procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id) is
+ procedure Replace_Discriminants (Typ : Entity_Id; Decl : Node_Id) is
function Process (N : Node_Id) return Traverse_Result;
-------------
@@ -22310,7 +22160,9 @@ package body Sem_Ch3 is
if Nkind (N) = N_Discriminant_Specification then
Comp := First_Discriminant (Typ);
while Present (Comp) loop
- if Chars (Comp) = Chars (Defining_Identifier (N)) then
+ if Original_Record_Component (Comp) = Defining_Identifier (N)
+ or else Chars (Comp) = Chars (Defining_Identifier (N))
+ then
Set_Defining_Identifier (N, Comp);
exit;
end if;
@@ -22321,23 +22173,25 @@ package body Sem_Ch3 is
elsif Nkind (N) = N_Variant_Part then
Comp := First_Discriminant (Typ);
while Present (Comp) loop
- if Chars (Comp) = Chars (Name (N)) then
- Set_Entity (Name (N), Comp);
- exit;
- end if;
-
- Next_Discriminant (Comp);
- end loop;
+ if Original_Record_Component (Comp) = Entity (Name (N))
+ or else Chars (Comp) = Chars (Name (N))
+ then
+ -- Make sure to preserve the type coming from the parent on
+ -- the Name, even if the subtype of the discriminant can be
+ -- constrained, so that discrete choices inherited from the
+ -- parent in the variant part are not flagged as violating
+ -- the constraints of the subtype.
- elsif Nkind (N) = N_Component_Declaration then
- Comp := First_Component (Typ);
- while Present (Comp) loop
- if Chars (Comp) = Chars (Defining_Identifier (N)) then
- Set_Defining_Identifier (N, Comp);
+ declare
+ Typ : constant Entity_Id := Etype (Name (N));
+ begin
+ Rewrite (Name (N), New_Occurrence_Of (Comp, Sloc (N)));
+ Set_Etype (Name (N), Typ);
+ end;
exit;
end if;
- Next_Component (Comp);
+ Next_Discriminant (Comp);
end loop;
end if;
@@ -22346,11 +22200,11 @@ package body Sem_Ch3 is
procedure Replace is new Traverse_Proc (Process);
- -- Start of processing for Replace_Components
+ -- Start of processing for Replace_Discriminants
begin
Replace (Decl);
- end Replace_Components;
+ end Replace_Discriminants;
-------------------------------
-- Set_Completion_Referenced --
@@ -22549,18 +22403,10 @@ package body Sem_Ch3 is
("non-static expression used for integer type bound!", Expr);
Errs := True;
- -- The bounds are folded into literals, and we set their type to be
- -- universal, to avoid typing difficulties: we cannot set the type
- -- of the literal to the new type, because this would be a forward
- -- reference for the back end, and if the original type is user-
- -- defined this can lead to spurious semantic errors (e.g. 2928-003).
-
- else
- if Is_Entity_Name (Expr) then
- Fold_Uint (Expr, Expr_Value (Expr), True);
- end if;
+ -- Otherwise the bounds are folded into literals
- Set_Etype (Expr, Universal_Integer);
+ elsif Is_Entity_Name (Expr) then
+ Fold_Uint (Expr, Expr_Value (Expr), True);
end if;
end Check_Bound;
@@ -22582,6 +22428,7 @@ package body Sem_Ch3 is
if Hi = Error or else Lo = Error then
Base_Typ := Any_Integer;
Set_Error_Posted (T, True);
+ Errs := True;
-- Here both bounds are OK expressions
@@ -22626,6 +22473,17 @@ package body Sem_Ch3 is
end if;
end if;
+ -- Set the type of the bounds to the implicit base: we cannot set it to
+ -- the new type, because this would be a forward reference for the code
+ -- generator and, if the original type is user-defined, this could even
+ -- lead to spurious semantic errors. Furthermore we do not set it to be
+ -- universal, because this could make it much larger than needed here.
+
+ if not Errs then
+ Set_Etype (Lo, Implicit_Base);
+ Set_Etype (Hi, Implicit_Base);
+ end if;
+
-- Complete both implicit base and declared first subtype entities. The
-- inheritance of the rep item chain ensures that SPARK-related pragmas
-- are not clobbered when the signed integer type acts as a full view of
diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads
index 0afc6c0..bb29904 100644
--- a/gcc/ada/sem_ch3.ads
+++ b/gcc/ada/sem_ch3.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -23,7 +23,6 @@
-- --
------------------------------------------------------------------------------
-with Nlists; use Nlists;
with Types; use Types;
package Sem_Ch3 is
@@ -196,8 +195,7 @@ package Sem_Ch3 is
(N : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty;
- Suffix_Index : Nat := 1;
- In_Iter_Schm : Boolean := False);
+ Suffix_Index : Nat := 1);
-- Process an index that is given in an array declaration, an entry
-- family declaration or a loop iteration. The index is given by an index
-- declaration (a 'box'), or by a discrete range. The later can be the name
@@ -205,8 +203,7 @@ package Sem_Ch3 is
--
-- Related_Nod is the node where the potential generated implicit types
-- will be inserted. The next last parameters are used for creating the
- -- name. In_Iter_Schm is True if Make_Index is called on the discrete
- -- subtype definition in an iteration scheme.
+ -- name.
procedure Make_Class_Wide_Type (T : Entity_Id);
-- A Class_Wide_Type is created for each tagged type definition. The
@@ -244,7 +241,7 @@ package Sem_Ch3 is
-- Default and per object expressions do not freeze their components, and
-- must be analyzed and resolved accordingly. The analysis is done by
-- calling the Preanalyze_And_Resolve routine and setting the global
- -- In_Default_Expression flag. See the documentation section entitled
+ -- In_Spec_Expression flag. See the documentation section entitled
-- "Handling of Default and Per-Object Expressions" in sem.ads for full
-- details. N is the expression to be analyzed, T is the expected type.
-- This mechanism is also used for aspect specifications that have an
@@ -265,9 +262,8 @@ package Sem_Ch3 is
(R : Node_Id;
T : Entity_Id;
Subtyp : Entity_Id := Empty;
- Check_List : List_Id := Empty_List;
- R_Check_Off : Boolean := False;
- In_Iter_Schm : Boolean := False);
+ Check_List : List_Id := No_List;
+ R_Check_Off : Boolean := False);
-- Process a range expression that appears in a declaration context. The
-- range is analyzed and resolved with the base type of the given type, and
-- an appropriate check for expressions in non-static contexts made on the
@@ -278,8 +274,7 @@ package Sem_Ch3 is
-- when the subprogram is called from Build_Record_Init_Proc and is used to
-- return a set of constraint checking statements generated by the Checks
-- package. R_Check_Off is set to True when the call to Range_Check is to
- -- be skipped. In_Iter_Schm is True if Process_Range_Expr_In_Decl is called
- -- on the discrete subtype definition in an iteration scheme.
+ -- be skipped.
--
-- If Subtyp is given, then the range is for the named subtype Subtyp, and
-- in this case the bounds are captured if necessary using this name.
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 5910112..c92fb06 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -171,6 +171,7 @@ package body Sem_Ch4 is
-- being called. The caller will have verified that the object is legal
-- for the call. If the remaining parameters match, the first parameter
-- will rewritten as a dereference if needed, prior to completing analysis.
+
procedure Check_Misspelled_Selector
(Prefix : Entity_Id;
Sel : Node_Id);
@@ -276,20 +277,6 @@ package body Sem_Ch4 is
-- type is not directly visible. The routine uses this type to emit a more
-- informative message.
- function Process_Implicit_Dereference_Prefix
- (E : Entity_Id;
- P : Node_Id) return Entity_Id;
- -- Called when P is the prefix of an implicit dereference, denoting an
- -- object E. The function returns the designated type of the prefix, taking
- -- into account that the designated type of an anonymous access type may be
- -- a limited view, when the nonlimited view is visible.
- --
- -- If in semantics only mode (-gnatc or generic), the function also records
- -- that the prefix is a reference to E, if any. Normally, such a reference
- -- is generated only when the implicit dereference is expanded into an
- -- explicit one, but for consistency we must generate the reference when
- -- expansion is disabled as well.
-
procedure Remove_Abstract_Operations (N : Node_Id);
-- Ada 2005: implementation of AI-310. An abstract non-dispatching
-- operation is not a candidate interpretation.
@@ -299,6 +286,7 @@ package body Sem_Ch4 is
Prefix : Node_Id;
Exprs : List_Id) return Boolean;
-- AI05-0139: Generalized indexing to support iterators over containers
+ -- ??? Need to provide a more detailed spec of what this function does
function Try_Indexed_Call
(N : Node_Id;
@@ -392,7 +380,7 @@ package body Sem_Ch4 is
if Nkind (N) in N_Membership_Test then
Error_Msg_N ("ambiguous operands for membership", N);
- elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) then
+ elsif Nkind (N) in N_Op_Eq | N_Op_Ne then
Error_Msg_N ("ambiguous operands for equality", N);
else
@@ -469,8 +457,6 @@ package body Sem_Ch4 is
Onode : Node_Id;
begin
- Check_SPARK_05_Restriction ("allocator is not allowed", N);
-
-- Deal with allocator restrictions
-- In accordance with H.4(7), the No_Allocators restriction only applies
@@ -680,7 +666,7 @@ package body Sem_Ch4 is
-- that outside of spec expressions, otherwise the declaration
-- cannot be inserted and analyzed. In such a case, GNATprove
-- later rejects the allocator as it is not used here in
- -- a non-interfering context (SPARK 4.8(2) and 7.1.3(12)).
+ -- a non-interfering context (SPARK 4.8(2) and 7.1.3(10)).
if Expander_Active
or else (GNATprove_Mode and then not In_Spec_Expression)
@@ -935,16 +921,8 @@ package body Sem_Ch4 is
if Present (Op_Id) then
if Ekind (Op_Id) = E_Operator then
-
- if Nkind_In (N, N_Op_Divide, N_Op_Mod, N_Op_Multiply, N_Op_Rem)
- and then Treat_Fixed_As_Integer (N)
- then
- null;
- else
- Set_Etype (N, Any_Type);
- Find_Arithmetic_Types (L, R, Op_Id, N);
- end if;
-
+ Set_Etype (N, Any_Type);
+ Find_Arithmetic_Types (L, R, Op_Id, N);
else
Set_Etype (N, Any_Type);
Add_One_Interp (N, Op_Id, Etype (Op_Id));
@@ -1005,10 +983,6 @@ package body Sem_Ch4 is
-- Flag indicates whether an interpretation of the prefix is a
-- parameterless call that returns an access_to_subprogram.
- procedure Check_Mixed_Parameter_And_Named_Associations;
- -- Check that parameter and named associations are not mixed. This is
- -- a restriction in SPARK mode.
-
procedure Check_Writable_Actuals (N : Node_Id);
-- If the call has out or in-out parameters then mark its outermost
-- enclosing construct as a node on which the writable actuals check
@@ -1024,36 +998,6 @@ package body Sem_Ch4 is
procedure No_Interpretation;
-- Output error message when no valid interpretation exists
- --------------------------------------------------
- -- Check_Mixed_Parameter_And_Named_Associations --
- --------------------------------------------------
-
- procedure Check_Mixed_Parameter_And_Named_Associations is
- Actual : Node_Id;
- Named_Seen : Boolean;
-
- begin
- Named_Seen := False;
-
- Actual := First (Actuals);
- while Present (Actual) loop
- case Nkind (Actual) is
- when N_Parameter_Association =>
- if Named_Seen then
- Check_SPARK_05_Restriction
- ("named association cannot follow positional one",
- Actual);
- exit;
- end if;
-
- when others =>
- Named_Seen := True;
- end case;
-
- Next (Actual);
- end loop;
- end Check_Mixed_Parameter_And_Named_Associations;
-
----------------------------
-- Check_Writable_Actuals --
----------------------------
@@ -1119,8 +1063,8 @@ package body Sem_Ch4 is
-- performing the writable actuals check.
if Has_Arbitrary_Evaluation_Order (Nkind (P))
- and then not Nkind_In (P, N_Assignment_Statement,
- N_Object_Declaration)
+ and then Nkind (P) not in
+ N_Assignment_Statement | N_Object_Declaration
then
Outermost := P;
end if;
@@ -1129,8 +1073,8 @@ package body Sem_Ch4 is
exit when Stop_Subtree_Climbing (Nkind (P))
or else (Nkind (P) = N_Range
- and then not
- Nkind_In (Parent (P), N_In, N_Not_In));
+ and then
+ Nkind (Parent (P)) not in N_In | N_Not_In);
P := Parent (P);
end loop;
@@ -1180,8 +1124,7 @@ package body Sem_Ch4 is
-- Check for tasking cases where only an entry call will do
elsif not L
- and then Nkind_In (K, N_Entry_Call_Alternative,
- N_Triggering_Alternative)
+ and then K in N_Entry_Call_Alternative | N_Triggering_Alternative
then
Error_Msg_N ("entry name expected", Nam);
@@ -1195,10 +1138,6 @@ package body Sem_Ch4 is
-- Start of processing for Analyze_Call
begin
- if Restriction_Check_Required (SPARK_05) then
- Check_Mixed_Parameter_And_Named_Associations;
- end if;
-
-- Initialize the type of the result of the call to the error type,
-- which will be reset if the type is successfully resolved.
@@ -1224,8 +1163,7 @@ package body Sem_Ch4 is
-- type is an array, F (X) cannot be interpreted as an indirect call
-- through the result of the call to F.
- elsif Is_Access_Type (Etype (Nam))
- and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type
+ elsif Is_Access_Subprogram_Type (Base_Type (Etype (Nam)))
and then
(not Name_Denotes_Function
or else Nkind (N) = N_Procedure_Call_Statement
@@ -1246,10 +1184,10 @@ package body Sem_Ch4 is
elsif Nkind (Nam) = N_Selected_Component then
Nam_Ent := Entity (Selector_Name (Nam));
- if not Ekind_In (Nam_Ent, E_Entry,
- E_Entry_Family,
- E_Function,
- E_Procedure)
+ if Ekind (Nam_Ent) not in E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Procedure
then
Error_Msg_N ("name in call is not a callable entity", Nam);
Set_Etype (N, Any_Type);
@@ -1424,7 +1362,7 @@ package body Sem_Ch4 is
Set_Etype (Nam, It.Typ);
end if;
- elsif Nkind_In (Name (N), N_Function_Call, N_Selected_Component)
+ elsif Nkind (Name (N)) in N_Function_Call | N_Selected_Component
then
Remove_Interp (X);
end if;
@@ -2100,13 +2038,6 @@ package body Sem_Ch4 is
-- Start of processing for Analyze_Explicit_Dereference
begin
- -- If source node, check SPARK restriction. We guard this with the
- -- source node check, because ???
-
- if Comes_From_Source (N) then
- Check_SPARK_05_Restriction ("explicit dereference is not allowed", N);
- end if;
-
-- In formal verification mode, keep track of all reads and writes
-- through explicit dereferences.
@@ -2286,17 +2217,91 @@ package body Sem_Ch4 is
-------------------------------------
procedure Analyze_Expression_With_Actions (N : Node_Id) is
+
+ procedure Check_Action_OK (A : Node_Id);
+ -- Check that the action is something that is allows as a declare_item
+ -- of a declare_expression, except the checks are suppressed for
+ -- generated code.
+
+ procedure Check_Action_OK (A : Node_Id) is
+ begin
+ if not Comes_From_Source (N) or else not Comes_From_Source (A) then
+ return; -- Allow anything in generated code
+ end if;
+
+ case Nkind (A) is
+ when N_Object_Declaration =>
+ if Nkind (Object_Definition (A)) = N_Access_Definition then
+ Error_Msg_N
+ ("anonymous access type not allowed in declare_expression",
+ Object_Definition (A));
+ end if;
+
+ if Aliased_Present (A) then
+ Error_Msg_N ("aliased not allowed in declare_expression", A);
+ end if;
+
+ if Constant_Present (A)
+ and then not Is_Limited_Type (Etype (Defining_Identifier (A)))
+ then
+ return; -- nonlimited constants are OK
+ end if;
+
+ when N_Object_Renaming_Declaration =>
+ if Present (Access_Definition (A)) then
+ Error_Msg_N
+ ("anonymous access type not allowed in declare_expression",
+ Access_Definition (A));
+ end if;
+
+ if not Is_Limited_Type (Etype (Defining_Identifier (A))) then
+ return; -- ???For now; the RM rule is a bit more complicated
+ end if;
+
+ when others =>
+ null; -- Nothing else allowed, not even pragmas
+ end case;
+
+ Error_Msg_N ("object renaming or constant declaration expected", A);
+ end Check_Action_OK;
+
A : Node_Id;
+ EWA_Scop : Entity_Id;
+
+ -- Start of processing for Analyze_Expression_With_Actions
begin
+ -- Create a scope, which is needed to provide proper visibility of the
+ -- declare_items.
+
+ EWA_Scop := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
+ Set_Etype (EWA_Scop, Standard_Void_Type);
+ Set_Scope (EWA_Scop, Current_Scope);
+ Set_Parent (EWA_Scop, N);
+ Push_Scope (EWA_Scop);
+
+ -- If this Expression_With_Actions node comes from source, then it
+ -- represents a declare_expression; increment the counter to take note
+ -- of that.
+
+ if Comes_From_Source (N) then
+ In_Declare_Expr := In_Declare_Expr + 1;
+ end if;
+
A := First (Actions (N));
while Present (A) loop
Analyze (A);
+ Check_Action_OK (A);
Next (A);
end loop;
Analyze_Expression (Expression (N));
Set_Etype (N, Etype (Expression (N)));
+ End_Scope;
+
+ if Comes_From_Source (N) then
+ In_Declare_Expr := In_Declare_Expr - 1;
+ end if;
end Analyze_Expression_With_Actions;
---------------------------
@@ -2326,10 +2331,6 @@ package body Sem_Ch4 is
Else_Expr := Next (Then_Expr);
if Comes_From_Source (N) then
- Check_SPARK_05_Restriction ("if expression is not allowed", N);
- end if;
-
- if Comes_From_Source (N) then
Check_Compiler_Unit ("if expression", N);
end if;
@@ -2411,7 +2412,10 @@ package body Sem_Ch4 is
procedure Process_Function_Call;
-- Prefix in indexed component form is an overloadable entity, so the
- -- node is a function call. Reformat it as such.
+ -- node is very likely a function call; reformat it as such. The only
+ -- exception is a call to a parameterless function that returns an
+ -- array type, or an access type thereof, in which case this will be
+ -- undone later by Resolve_Call or Resolve_Entry_Call.
procedure Process_Indexed_Component;
-- Prefix in indexed component form is actually an indexed component.
@@ -2522,7 +2526,7 @@ package body Sem_Ch4 is
if Is_Access_Type (Array_Type) then
Error_Msg_NW
(Warn_On_Dereference, "?d?implicit dereference", N);
- Array_Type := Process_Implicit_Dereference_Prefix (Pent, P);
+ Array_Type := Implicitly_Designated_Type (Array_Type);
end if;
if Is_Array_Type (Array_Type) then
@@ -2829,18 +2833,6 @@ package body Sem_Ch4 is
and then Is_Overloadable (Entity (Selector_Name (P)))
then
Process_Function_Call;
-
- -- In ASIS mode within a generic, a prefixed call is analyzed and
- -- partially rewritten but the original indexed component has not
- -- yet been rewritten as a call. Perform the replacement now.
-
- elsif Nkind (P) = N_Selected_Component
- and then Nkind (Parent (P)) = N_Function_Call
- and then ASIS_Mode
- then
- Rewrite (N, Parent (P));
- Analyze (N);
-
else
-- Indexed component, slice, or a call to a member of a family
-- entry, which will be converted to an entry call later.
@@ -3047,6 +3039,8 @@ package body Sem_Ch4 is
end if;
end Analyze_Set_Membership;
+ Op : Node_Id;
+
-- Start of processing for Analyze_Membership_Op
begin
@@ -3093,17 +3087,20 @@ package body Sem_Ch4 is
and then Has_Compatible_Type (R, Etype (L))
then
if Nkind (N) = N_In then
- Rewrite (N,
- Make_Op_Eq (Loc,
- Left_Opnd => L,
- Right_Opnd => R));
+ Op := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R);
else
- Rewrite (N,
- Make_Op_Ne (Loc,
- Left_Opnd => L,
- Right_Opnd => R));
+ Op := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R);
+ end if;
+
+ if Is_Record_Or_Limited_Type (Etype (L)) then
+
+ -- We reset the Entity in order to use the primitive equality
+ -- of the type, as per RM 4.5.2 (28.1/4).
+
+ Set_Entity (Op, Empty);
end if;
+ Rewrite (N, Op);
Analyze (N);
return;
@@ -3202,8 +3199,6 @@ package body Sem_Ch4 is
procedure Analyze_Null (N : Node_Id) is
begin
- Check_SPARK_05_Restriction ("null is not allowed", N);
-
Set_Etype (N, Any_Access);
end Analyze_Null;
@@ -3282,7 +3277,7 @@ package body Sem_Ch4 is
-- When the type Address is a visible integer type, and the DEC
-- system extension is visible, the predefined operator may be
-- hidden as well, by one of the address operations in auxdec.
- -- Finally, The abstract operations on address do not hide the
+ -- Finally, the abstract operations on address do not hide the
-- predefined operator (this is the purpose of making them abstract).
-----------------------------------
@@ -3294,20 +3289,30 @@ package body Sem_Ch4 is
T2 : Entity_Id) return Boolean
is
function Common_Type (T : Entity_Id) return Entity_Id;
- -- Find non-private full view if any, without going to ancestor type
- -- (as opposed to Underlying_Type).
+ -- Find non-private underlying full view if any, without going to
+ -- ancestor type (as opposed to Underlying_Type).
-----------------
-- Common_Type --
-----------------
function Common_Type (T : Entity_Id) return Entity_Id is
+ CT : Entity_Id;
+
begin
- if Is_Private_Type (T) and then Present (Full_View (T)) then
- return Base_Type (Full_View (T));
- else
- return Base_Type (T);
+ CT := T;
+
+ if Is_Private_Type (CT) and then Present (Full_View (CT)) then
+ CT := Full_View (CT);
+ end if;
+
+ if Is_Private_Type (CT)
+ and then Present (Underlying_Full_View (CT))
+ then
+ CT := Underlying_Full_View (CT);
end if;
+
+ return Base_Type (CT);
end Common_Type;
-- Start of processing for Compatible_Types_In_Predicate
@@ -3770,22 +3775,23 @@ package body Sem_Ch4 is
-- To avoid breaking privacy, Is_Hidden gets set elsewhere on such
-- primitives, but we still need to verify that Nam is indeed a
- -- controlled subprogram. So, we do that here and issue the
- -- appropriate error.
+ -- non-visible controlled subprogram. So, we do that here and issue
+ -- the appropriate error.
if Is_Hidden (Nam)
and then not In_Instance
and then not Comes_From_Source (Nam)
and then Comes_From_Source (N)
- -- Verify Nam is a controlled primitive
+ -- Verify Nam is a non-visible controlled primitive
- and then Nam_In (Chars (Nam), Name_Adjust,
- Name_Finalize,
- Name_Initialize)
+ and then Chars (Nam) in Name_Adjust
+ | Name_Finalize
+ | Name_Initialize
and then Ekind (Nam) = E_Procedure
and then Is_Controlled (Etype (First_Form))
and then No (Next_Formal (First_Form))
+ and then not Is_Visibly_Controlled (Etype (First_Form))
then
Error_Msg_Node_2 := Etype (First_Form);
Error_Msg_NE ("call to non-visible controlled primitive & on type"
@@ -3921,15 +3927,13 @@ package body Sem_Ch4 is
and then Is_Visible_Component (Comp, Sel)
then
- -- AI05-105: if the context is an object renaming with
+ -- AI05-105: if the context is an object renaming with
-- an anonymous access type, the expected type of the
-- object must be anonymous. This is a name resolution rule.
if Nkind (Parent (N)) /= N_Object_Renaming_Declaration
or else No (Access_Definition (Parent (N)))
- or else Ekind (Etype (Comp)) = E_Anonymous_Access_Type
- or else
- Ekind (Etype (Comp)) = E_Anonymous_Access_Subprogram_Type
+ or else Is_Anonymous_Access_Type (Etype (Comp))
then
Set_Entity (Sel, Comp);
Set_Etype (Sel, Etype (Comp));
@@ -3971,18 +3975,6 @@ package body Sem_Ch4 is
Set_Etype (Sel, Etype (Comp));
Set_Etype (N, Etype (Comp));
Set_Etype (Nam, It.Typ);
-
- -- For access type case, introduce explicit dereference for
- -- more uniform treatment of entry calls. Do this only once
- -- if several interpretations yield an access type.
-
- if Is_Access_Type (Etype (Nam))
- and then Nkind (Nam) /= N_Explicit_Dereference
- then
- Insert_Explicit_Dereference (Nam);
- Error_Msg_NW
- (Warn_On_Dereference, "?d?implicit dereference", N);
- end if;
end if;
Next_Entity (Comp);
@@ -4021,14 +4013,15 @@ package body Sem_Ch4 is
Find_Type (Mark);
T := Entity (Mark);
- if Nkind_In (Enclosing_Declaration (N), N_Formal_Type_Declaration,
- N_Full_Type_Declaration,
- N_Incomplete_Type_Declaration,
- N_Protected_Type_Declaration,
- N_Private_Extension_Declaration,
- N_Private_Type_Declaration,
- N_Subtype_Declaration,
- N_Task_Type_Declaration)
+ if Nkind (Enclosing_Declaration (N)) in
+ N_Formal_Type_Declaration |
+ N_Full_Type_Declaration |
+ N_Incomplete_Type_Declaration |
+ N_Protected_Type_Declaration |
+ N_Private_Extension_Declaration |
+ N_Private_Type_Declaration |
+ N_Subtype_Declaration |
+ N_Task_Type_Declaration
and then T = Defining_Identifier (Enclosing_Declaration (N))
then
Error_Msg_N ("current instance not allowed", Mark);
@@ -4151,8 +4144,6 @@ package body Sem_Ch4 is
-- Start of processing for Analyze_Quantified_Expression
begin
- Check_SPARK_05_Restriction ("quantified expression is not allowed", N);
-
-- Create a scope to emulate the loop-like behavior of the quantified
-- expression. The scope is needed to provide proper visibility of the
-- loop variable.
@@ -4197,6 +4188,7 @@ package body Sem_Ch4 is
-- reflect the right kind. This is needed for proper ASIS
-- navigation. If expansion is enabled, the transformation is
-- performed when the expression is rewritten as a loop.
+ -- Is this still needed???
Set_Iterator_Specification (N,
New_Copy_Tree (Iterator_Specification (Parent (Loop_Par))));
@@ -4453,7 +4445,6 @@ package body Sem_Ch4 is
In_Scope : Boolean;
Is_Private_Op : Boolean;
Parent_N : Node_Id;
- Pent : Entity_Id := Empty;
Prefix_Type : Entity_Id;
Type_To_Use : Entity_Id;
@@ -4482,7 +4473,15 @@ package body Sem_Ch4 is
-- indexed component rather than a function call.
function Has_Dereference (Nod : Node_Id) return Boolean;
- -- Check whether prefix includes a dereference at any level.
+ -- Check whether prefix includes a dereference, explicit or implicit,
+ -- at any recursive level.
+
+ function Try_By_Protected_Procedure_Prefixed_View return Boolean;
+ -- Return True if N is an access attribute whose prefix is a prefixed
+ -- class-wide (synchronized or protected) interface view for which some
+ -- interpretation is a procedure with synchronization kind By_Protected
+ -- _Procedure, and collect all its interpretations (since it may be an
+ -- overloaded interface primitive); otherwise return False.
--------------------------------
-- Find_Component_In_Instance --
@@ -4594,14 +4593,10 @@ package body Sem_Ch4 is
if Nkind (Nod) = N_Explicit_Dereference then
return True;
- -- When expansion is disabled an explicit dereference may not have
- -- been inserted, but if this is an access type the indirection makes
- -- the call safe.
-
elsif Is_Access_Type (Etype (Nod)) then
return True;
- elsif Nkind_In (Nod, N_Indexed_Component, N_Selected_Component) then
+ elsif Nkind (Nod) in N_Indexed_Component | N_Selected_Component then
return Has_Dereference (Prefix (Nod));
else
@@ -4609,6 +4604,65 @@ package body Sem_Ch4 is
end if;
end Has_Dereference;
+ ----------------------------------------------
+ -- Try_By_Protected_Procedure_Prefixed_View --
+ ----------------------------------------------
+
+ function Try_By_Protected_Procedure_Prefixed_View return Boolean is
+ Candidate : Node_Id := Empty;
+ Elmt : Elmt_Id;
+ Prim : Node_Id;
+
+ begin
+ if Nkind (Parent (N)) = N_Attribute_Reference
+ and then Attribute_Name (Parent (N)) in
+ Name_Access
+ | Name_Unchecked_Access
+ | Name_Unrestricted_Access
+ and then Is_Class_Wide_Type (Prefix_Type)
+ and then (Is_Synchronized_Interface (Prefix_Type)
+ or else Is_Protected_Interface (Prefix_Type))
+ then
+ -- If we have not found yet any interpretation then mark this
+ -- one as the first interpretation (cf. Add_One_Interp).
+
+ if No (Etype (Sel)) then
+ Set_Etype (Sel, Any_Type);
+ end if;
+
+ Elmt := First_Elmt (Primitive_Operations (Etype (Prefix_Type)));
+ while Present (Elmt) loop
+ Prim := Node (Elmt);
+
+ if Chars (Prim) = Chars (Sel)
+ and then Is_By_Protected_Procedure (Prim)
+ then
+ Candidate := New_Copy (Prim);
+
+ -- Skip the controlling formal; required to check type
+ -- conformance of the target access to protected type
+ -- (see Conforming_Types).
+
+ Set_First_Entity (Candidate,
+ Next_Entity (First_Entity (Prim)));
+
+ Add_One_Interp (Sel, Candidate, Etype (Prim));
+ Set_Etype (N, Etype (Prim));
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+
+ -- Propagate overloaded attribute
+
+ if Present (Candidate) and then Is_Overloaded (Sel) then
+ Set_Is_Overloaded (N);
+ end if;
+
+ return Present (Candidate);
+ end Try_By_Protected_Procedure_Prefixed_View;
+
-- Start of processing for Analyze_Selected_Component
begin
@@ -4650,16 +4704,7 @@ package body Sem_Ch4 is
else
Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N);
-
- if Is_Entity_Name (Name) then
- Pent := Entity (Name);
- elsif Nkind (Name) = N_Selected_Component
- and then Is_Entity_Name (Selector_Name (Name))
- then
- Pent := Entity (Selector_Name (Name));
- end if;
-
- Prefix_Type := Process_Implicit_Dereference_Prefix (Pent, Name);
+ Prefix_Type := Implicitly_Designated_Type (Prefix_Type);
end if;
-- If we have an explicit dereference of a remote access-to-class-wide
@@ -4747,11 +4792,6 @@ package body Sem_Ch4 is
Set_Etype (N, Etype (Comp));
Check_Implicit_Dereference (N, Etype (Comp));
- if Is_Access_Type (Etype (Name)) then
- Insert_Explicit_Dereference (Name);
- Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N);
- end if;
-
elsif Is_Record_Type (Prefix_Type) then
-- Find component with given name. In an instance, if the node is
@@ -4833,10 +4873,10 @@ package body Sem_Ch4 is
or else
(Nkind (Parent_N) = N_Attribute_Reference
and then
- Nam_In (Attribute_Name (Parent_N), Name_First,
- Name_Last,
- Name_Length,
- Name_Range)))
+ Attribute_Name (Parent_N) in Name_First
+ | Name_Last
+ | Name_Length
+ | Name_Range))
then
Set_Etype (N, Etype (Comp));
@@ -4918,6 +4958,9 @@ package body Sem_Ch4 is
return;
end if;
+ elsif Try_By_Protected_Procedure_Prefixed_View then
+ return;
+
elsif Try_Object_Operation (N) then
return;
end if;
@@ -5014,9 +5057,9 @@ package body Sem_Ch4 is
-- a visible entity is found.
if Is_Tagged_Type (Prefix_Type)
- and then Nkind_In (Parent (N), N_Function_Call,
- N_Indexed_Component,
- N_Procedure_Call_Statement)
+ and then Nkind (Parent (N)) in N_Function_Call
+ | N_Indexed_Component
+ | N_Procedure_Call_Statement
and then Has_Mode_Conformant_Spec (Comp)
then
Has_Candidate := True;
@@ -5025,7 +5068,7 @@ package body Sem_Ch4 is
-- Note: a selected component may not denote a component of a
-- protected type (4.1.3(7)).
- elsif Ekind_In (Comp, E_Discriminant, E_Entry_Family)
+ elsif Ekind (Comp) in E_Discriminant | E_Entry_Family
or else (In_Scope
and then not Is_Protected_Type (Prefix_Type)
and then Is_Entity_Name (Name))
@@ -5052,15 +5095,6 @@ package body Sem_Ch4 is
if Ekind (Comp) = E_Discriminant then
Set_Original_Discriminant (Sel, Comp);
end if;
-
- -- For access type case, introduce explicit dereference for
- -- more uniform treatment of entry calls.
-
- if Is_Access_Type (Etype (Name)) then
- Insert_Explicit_Dereference (Name);
- Error_Msg_NW
- (Warn_On_Dereference, "?d?implicit dereference", N);
- end if;
end if;
<<Next_Comp>>
@@ -5112,7 +5146,7 @@ package body Sem_Ch4 is
then
if Is_Task_Type (Prefix_Type)
and then Present (Entity (Sel))
- and then Ekind_In (Entity (Sel), E_Entry, E_Entry_Family)
+ and then Is_Entry (Entity (Sel))
then
null;
@@ -5302,24 +5336,21 @@ package body Sem_Ch4 is
end loop;
-- Another special case: the type is an extension of a private
- -- type T, is an actual in an instance, and we are in the body
- -- of the instance, so the generic body had a full view of the
- -- type declaration for T or of some ancestor that defines the
- -- component in question.
+ -- type T, either is an actual in an instance or is immediately
+ -- visible, and we are in the body of the instance, which means
+ -- the generic body had a full view of the type declaration for
+ -- T or some ancestor that defines the component in question.
+ -- This happens because Is_Visible_Component returned False on
+ -- this component, as T or the ancestor is still private since
+ -- the Has_Private_View mechanism is bypassed because T or the
+ -- ancestor is not directly referenced in the generic body.
elsif Is_Derived_Type (Type_To_Use)
- and then Used_As_Generic_Actual (Type_To_Use)
+ and then (Used_As_Generic_Actual (Type_To_Use)
+ or else Is_Immediately_Visible (Type_To_Use))
and then In_Instance_Body
then
Find_Component_In_Instance (Parent_Subtype (Type_To_Use));
-
- -- In ASIS mode the generic parent type may be absent. Examine
- -- the parent type directly for a component that may have been
- -- visible in a parent generic unit.
-
- elsif Is_Derived_Type (Prefix_Type) then
- Par := Etype (Prefix_Type);
- Find_Component_In_Instance (Par);
end if;
end;
@@ -5517,10 +5548,6 @@ package body Sem_Ch4 is
-- Start of processing for Analyze_Slice
begin
- if Comes_From_Source (N) then
- Check_SPARK_05_Restriction ("slice is not allowed", N);
- end if;
-
Analyze (P);
Analyze (D);
@@ -5532,8 +5559,8 @@ package body Sem_Ch4 is
Set_Etype (N, Any_Type);
if Is_Access_Type (Array_Type) then
- Array_Type := Designated_Type (Array_Type);
Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N);
+ Array_Type := Implicitly_Designated_Type (Array_Type);
end if;
if not Is_Array_Type (Array_Type) then
@@ -5630,9 +5657,9 @@ package body Sem_Ch4 is
end if;
elsif Nkind (Expr) = N_Attribute_Reference
- and then Nam_In (Attribute_Name (Expr), Name_Access,
- Name_Unchecked_Access,
- Name_Unrestricted_Access)
+ and then Attribute_Name (Expr) in Name_Access
+ | Name_Unchecked_Access
+ | Name_Unrestricted_Access
then
Error_Msg_N ("argument of conversion cannot be access", N);
Error_Msg_N ("\use qualified expression instead", N);
@@ -5721,54 +5748,47 @@ package body Sem_Ch4 is
procedure Analyze_User_Defined_Binary_Op
(N : Node_Id;
- Op_Id : Entity_Id)
- is
+ Op_Id : Entity_Id) is
begin
- -- Only do analysis if the operator Comes_From_Source, since otherwise
- -- the operator was generated by the expander, and all such operators
- -- always refer to the operators in package Standard.
-
- if Comes_From_Source (N) then
- declare
- F1 : constant Entity_Id := First_Formal (Op_Id);
- F2 : constant Entity_Id := Next_Formal (F1);
-
- begin
- -- Verify that Op_Id is a visible binary function. Note that since
- -- we know Op_Id is overloaded, potentially use visible means use
- -- visible for sure (RM 9.4(11)).
+ declare
+ F1 : constant Entity_Id := First_Formal (Op_Id);
+ F2 : constant Entity_Id := Next_Formal (F1);
- if Ekind (Op_Id) = E_Function
- and then Present (F2)
- and then (Is_Immediately_Visible (Op_Id)
- or else Is_Potentially_Use_Visible (Op_Id))
- and then Has_Compatible_Type (Left_Opnd (N), Etype (F1))
- and then Has_Compatible_Type (Right_Opnd (N), Etype (F2))
- then
- Add_One_Interp (N, Op_Id, Etype (Op_Id));
+ begin
+ -- Verify that Op_Id is a visible binary function. Note that since
+ -- we know Op_Id is overloaded, potentially use visible means use
+ -- visible for sure (RM 9.4(11)).
+
+ if Ekind (Op_Id) = E_Function
+ and then Present (F2)
+ and then (Is_Immediately_Visible (Op_Id)
+ or else Is_Potentially_Use_Visible (Op_Id))
+ and then Has_Compatible_Type (Left_Opnd (N), Etype (F1))
+ and then Has_Compatible_Type (Right_Opnd (N), Etype (F2))
+ then
+ Add_One_Interp (N, Op_Id, Etype (Op_Id));
- -- If the left operand is overloaded, indicate that the current
- -- type is a viable candidate. This is redundant in most cases,
- -- but for equality and comparison operators where the context
- -- does not impose a type on the operands, setting the proper
- -- type is necessary to avoid subsequent ambiguities during
- -- resolution, when both user-defined and predefined operators
- -- may be candidates.
+ -- If the left operand is overloaded, indicate that the current
+ -- type is a viable candidate. This is redundant in most cases,
+ -- but for equality and comparison operators where the context
+ -- does not impose a type on the operands, setting the proper
+ -- type is necessary to avoid subsequent ambiguities during
+ -- resolution, when both user-defined and predefined operators
+ -- may be candidates.
- if Is_Overloaded (Left_Opnd (N)) then
- Set_Etype (Left_Opnd (N), Etype (F1));
- end if;
+ if Is_Overloaded (Left_Opnd (N)) then
+ Set_Etype (Left_Opnd (N), Etype (F1));
+ end if;
- if Debug_Flag_E then
- Write_Str ("user defined operator ");
- Write_Name (Chars (Op_Id));
- Write_Str (" on node ");
- Write_Int (Int (N));
- Write_Eol;
- end if;
+ if Debug_Flag_E then
+ Write_Str ("user defined operator ");
+ Write_Name (Chars (Op_Id));
+ Write_Str (" on node ");
+ Write_Int (Int (N));
+ Write_Eol;
end if;
- end;
- end if;
+ end if;
+ end;
end Analyze_User_Defined_Binary_Op;
-----------------------------------
@@ -5901,7 +5921,7 @@ package body Sem_Ch4 is
-- Start of processing for Check_Arithmetic_Pair
begin
- if Nam_In (Op_Name, Name_Op_Add, Name_Op_Subtract) then
+ if Op_Name in Name_Op_Add | Name_Op_Subtract then
if Is_Numeric_Type (T1)
and then Is_Numeric_Type (T2)
and then (Covers (T1 => T1, T2 => T2)
@@ -5911,29 +5931,19 @@ package body Sem_Ch4 is
Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
end if;
- elsif Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide) then
+ elsif Op_Name in Name_Op_Multiply | Name_Op_Divide then
if Is_Fixed_Point_Type (T1)
and then (Is_Fixed_Point_Type (T2) or else T2 = Universal_Real)
then
- -- If Treat_Fixed_As_Integer is set then the Etype is already set
- -- and no further processing is required (this is the case of an
- -- operator constructed by Exp_Fixd for a fixed point operation)
- -- Otherwise add one interpretation with universal fixed result
- -- If the operator is given in functional notation, it comes
- -- from source and Fixed_As_Integer cannot apply.
-
- if (Nkind (N) not in N_Op
- or else not Treat_Fixed_As_Integer (N))
- and then
- (not Has_Fixed_Op (T1, Op_Id)
- or else Nkind (Parent (N)) = N_Type_Conversion)
+ -- Add one interpretation with universal fixed result
+
+ if not Has_Fixed_Op (T1, Op_Id)
+ or else Nkind (Parent (N)) = N_Type_Conversion
then
Add_One_Interp (N, Op_Id, Universal_Fixed);
end if;
elsif Is_Fixed_Point_Type (T2)
- and then (Nkind (N) not in N_Op
- or else not Treat_Fixed_As_Integer (N))
and then T1 = Universal_Real
and then
(not Has_Fixed_Op (T1, Op_Id)
@@ -5985,10 +5995,6 @@ package body Sem_Ch4 is
elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
- -- Note: The fixed-point operands case with Treat_Fixed_As_Integer
- -- set does not require any special processing, since the Etype is
- -- already set (case of operation constructed by Exp_Fixed).
-
if Is_Integer_Type (T1)
and then (Covers (T1 => T1, T2 => T2)
or else
@@ -6051,7 +6057,7 @@ package body Sem_Ch4 is
return;
end if;
- Comp := First_Entity (Prefix);
+ Comp := First_Entity (Prefix);
while Nr_Of_Suggestions <= Max_Suggestions and then Present (Comp) loop
if Is_Visible_Component (Comp, Sel) then
if Is_Bad_Spelling_Of (Chars (Comp), Chars (Sel)) then
@@ -6065,7 +6071,7 @@ package body Sem_Ch4 is
end if;
end if;
- Comp := Next_Entity (Comp);
+ Next_Entity (Comp);
end loop;
-- Report at most two suggestions
@@ -6223,7 +6229,7 @@ package body Sem_Ch4 is
else
while Present (It.Nam) loop
- if Ekind_In (It.Nam, E_Function, E_Operator) then
+ if Ekind (It.Nam) in E_Function | E_Operator then
return;
else
Get_Next_Interp (X, It);
@@ -6598,12 +6604,44 @@ package body Sem_Ch4 is
Op_Id : Entity_Id;
N : Node_Id)
is
- Index : Interp_Index;
- It : Interp;
- Found : Boolean := False;
- I_F : Interp_Index;
- T_F : Entity_Id;
- Scop : Entity_Id := Empty;
+ Index : Interp_Index := 0;
+ It : Interp;
+ Found : Boolean := False;
+ Is_Universal_Access : Boolean := False;
+ I_F : Interp_Index;
+ T_F : Entity_Id;
+ Scop : Entity_Id := Empty;
+
+ procedure Check_Access_Attribute (N : Node_Id);
+ -- For any object, '[Unchecked_]Access of such object can never be
+ -- passed as a parameter of a call to the Universal_Access equality
+ -- operator.
+ -- This is because the expected type for Obj'Access in a call to
+ -- the Standard."=" operator whose formals are of type
+ -- Universal_Access is Universal_Integer, and Universal_Access
+ -- doesn't have a designated type. For more detail see RM 6.4.1(3)
+ -- and 3.10.2.
+ -- This procedure assumes that the context is a universal_access.
+
+ function Check_Access_Object_Types
+ (N : Node_Id; Typ : Entity_Id) return Boolean;
+ -- Check for RM 4.5.2 (9.6/2): When both are of access-to-object types,
+ -- the designated types shall be the same or one shall cover the other,
+ -- and if the designated types are elementary or array types, then the
+ -- designated subtypes shall statically match.
+ -- If N is not overloaded, then its unique type must be compatible as
+ -- per above. Otherwise iterate through the interpretations of N looking
+ -- for a compatible one.
+
+ procedure Check_Compatible_Profiles (N : Node_Id; Typ : Entity_Id);
+ -- Check for RM 4.5.2(9.7/2): When both are of access-to-subprogram
+ -- types, the designated profiles shall be subtype conformant.
+
+ function References_Anonymous_Access_Type
+ (N : Node_Id; Typ : Entity_Id) return Boolean;
+ -- Return True either if N is not overloaded and its Etype is an
+ -- anonymous access type or if one of the interpretations of N refers
+ -- to an anonymous access type compatible with Typ.
procedure Try_One_Interp (T1 : Entity_Id);
-- The context of the equality operator plays no role in resolving the
@@ -6612,12 +6650,198 @@ package body Sem_Ch4 is
-- and an error can be emitted now, after trying to disambiguate, i.e.
-- applying preference rules.
+ ----------------------------
+ -- Check_Access_Attribute --
+ ----------------------------
+
+ procedure Check_Access_Attribute (N : Node_Id) is
+ begin
+ if Nkind (N) = N_Attribute_Reference
+ and then Attribute_Name (N) in Name_Access | Name_Unchecked_Access
+ then
+ Error_Msg_N
+ ("access attribute cannot be used as actual for "
+ & "universal_access equality", N);
+ end if;
+ end Check_Access_Attribute;
+
+ -------------------------------
+ -- Check_Access_Object_Types --
+ -------------------------------
+
+ function Check_Access_Object_Types
+ (N : Node_Id; Typ : Entity_Id) return Boolean
+ is
+ function Check_Designated_Types (DT1, DT2 : Entity_Id) return Boolean;
+ -- Check RM 4.5.2 (9.6/2) on the given designated types.
+
+ ----------------------------
+ -- Check_Designated_Types --
+ ----------------------------
+
+ function Check_Designated_Types
+ (DT1, DT2 : Entity_Id) return Boolean is
+ begin
+ -- If the designated types are elementary or array types, then
+ -- the designated subtypes shall statically match.
+
+ if Is_Elementary_Type (DT1) or else Is_Array_Type (DT1) then
+ if Base_Type (DT1) /= Base_Type (DT2) then
+ return False;
+ else
+ return Subtypes_Statically_Match (DT1, DT2);
+ end if;
+
+ -- Otherwise, the designated types shall be the same or one
+ -- shall cover the other.
+
+ else
+ return DT1 = DT2
+ or else Covers (DT1, DT2)
+ or else Covers (DT2, DT1);
+ end if;
+ end Check_Designated_Types;
+
+ -- Start of processing for Check_Access_Object_Types
+
+ begin
+ -- Return immediately with no checks if Typ is not an
+ -- access-to-object type.
+
+ if not Is_Access_Object_Type (Typ) then
+ return True;
+
+ -- Any_Type is compatible with all types in this context, and is used
+ -- in particular for the designated type of a 'null' value.
+
+ elsif Directly_Designated_Type (Typ) = Any_Type
+ or else Nkind (N) = N_Null
+ then
+ return True;
+ end if;
+
+ if not Is_Overloaded (N) then
+ if Is_Access_Object_Type (Etype (N)) then
+ return Check_Designated_Types
+ (Designated_Type (Typ), Designated_Type (Etype (N)));
+ end if;
+ else
+ declare
+ Typ_Is_Anonymous : constant Boolean :=
+ Is_Anonymous_Access_Type (Typ);
+
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (N, I, It);
+ while Present (It.Typ) loop
+
+ -- The check on designated types if only relevant when one
+ -- of the types is anonymous, ignore other (non relevant)
+ -- types.
+
+ if (Typ_Is_Anonymous
+ or else Is_Anonymous_Access_Type (It.Typ))
+ and then Is_Access_Object_Type (It.Typ)
+ then
+ if Check_Designated_Types
+ (Designated_Type (Typ), Designated_Type (It.Typ))
+ then
+ return True;
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Check_Access_Object_Types;
+
+ -------------------------------
+ -- Check_Compatible_Profiles --
+ -------------------------------
+
+ procedure Check_Compatible_Profiles (N : Node_Id; Typ : Entity_Id) is
+ I : Interp_Index;
+ It : Interp;
+ I1 : Interp_Index := 0;
+ Found : Boolean := False;
+ Tmp : Entity_Id := Empty;
+
+ begin
+ if not Is_Overloaded (N) then
+ Check_Subtype_Conformant
+ (Designated_Type (Etype (N)), Designated_Type (Typ), N);
+ else
+ Get_First_Interp (N, I, It);
+ while Present (It.Typ) loop
+ if Is_Access_Subprogram_Type (It.Typ) then
+ if not Found then
+ Found := True;
+ Tmp := It.Typ;
+ I1 := I;
+
+ else
+ It := Disambiguate (N, I1, I, Any_Type);
+
+ if It /= No_Interp then
+ Tmp := It.Typ;
+ I1 := I;
+ else
+ Found := False;
+ exit;
+ end if;
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if Found then
+ Check_Subtype_Conformant
+ (Designated_Type (Tmp), Designated_Type (Typ), N);
+ end if;
+ end if;
+ end Check_Compatible_Profiles;
+
+ --------------------------------------
+ -- References_Anonymous_Access_Type --
+ --------------------------------------
+
+ function References_Anonymous_Access_Type
+ (N : Node_Id; Typ : Entity_Id) return Boolean
+ is
+ I : Interp_Index;
+ It : Interp;
+ begin
+ if not Is_Overloaded (N) then
+ return Is_Anonymous_Access_Type (Etype (N));
+ else
+ Get_First_Interp (N, I, It);
+ while Present (It.Typ) loop
+ if Is_Anonymous_Access_Type (It.Typ)
+ and then (Covers (It.Typ, Typ) or else Covers (Typ, It.Typ))
+ then
+ return True;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ return False;
+ end if;
+ end References_Anonymous_Access_Type;
+
--------------------
-- Try_One_Interp --
--------------------
procedure Try_One_Interp (T1 : Entity_Id) is
- Bas : Entity_Id;
+ Universal_Access : Boolean;
+ Bas : Entity_Id;
begin
-- Perform a sanity check in case of previous errors
@@ -6637,6 +6861,9 @@ package body Sem_Ch4 is
-- In Ada 2005, the equality operator for anonymous access types
-- is declared in Standard, and preference rules apply to it.
+ Universal_Access := Is_Anonymous_Access_Type (T1)
+ or else References_Anonymous_Access_Type (R, T1);
+
if Present (Scop) then
-- Note that we avoid returning if we are currently within a
@@ -6657,48 +6884,28 @@ package body Sem_Ch4 is
then
null;
- elsif Ekind (T1) = E_Anonymous_Access_Type
- and then Scop = Standard_Standard
- then
- null;
+ elsif Scop /= Standard_Standard or else not Universal_Access then
- else
-- The scope does not contain an operator for the type
return;
end if;
-- If we have infix notation, the operator must be usable. Within
- -- an instance, if the type is already established we know it is
- -- correct. If an operand is universal it is compatible with any
- -- numeric type.
+ -- an instance, the type may have been immediately visible if the
+ -- types are compatible.
elsif In_Open_Scopes (Scope (Bas))
or else Is_Potentially_Use_Visible (Bas)
or else In_Use (Bas)
or else (In_Use (Scope (Bas)) and then not Is_Hidden (Bas))
-
- -- In an instance, the type may have been immediately visible.
- -- Either the types are compatible, or one operand is universal
- -- (numeric or null).
-
or else
((In_Instance or else In_Inlined_Body)
- and then
- (First_Subtype (T1) = First_Subtype (Etype (R))
- or else Nkind (R) = N_Null
- or else
- (Is_Numeric_Type (T1)
- and then Is_Universal_Numeric_Type (Etype (R)))))
-
- -- In Ada 2005, the equality on anonymous access types is declared
- -- in Standard, and is always visible.
-
- or else Ekind (T1) = E_Anonymous_Access_Type
+ and then Has_Compatible_Type (R, T1))
then
null;
- else
+ elsif not Universal_Access then
-- Save candidate type for subsequent error message, if any
if not Is_Limited_Type (T1) then
@@ -6711,9 +6918,7 @@ package body Sem_Ch4 is
-- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95:
-- Do not allow anonymous access types in equality operators.
- if Ada_Version < Ada_2005
- and then Ekind (T1) = E_Anonymous_Access_Type
- then
+ if Ada_Version < Ada_2005 and then Universal_Access then
return;
end if;
@@ -6725,15 +6930,16 @@ package body Sem_Ch4 is
-- in Standard to be chosen, and the "/=" will be rewritten as a
-- negation of "=" (see the end of Analyze_Equality_Op). This ensures
-- that rewriting happens during analysis rather than being
- -- delayed until expansion (this is needed for ASIS, which only sees
- -- the unexpanded tree). Note that if the node is N_Op_Ne, but Op_Id
+ -- delayed until expansion (is this still needed now that ASIS mode
+ -- is gone???). Note that if the node is N_Op_Ne, but Op_Id
-- is Name_Op_Eq then we still proceed with the interpretation,
-- because that indicates the potential rewriting case where the
-- interpretation to consider is actually "=" and the node may be
-- about to be rewritten by Analyze_Equality_Op.
+ -- Finally, also check for RM 4.5.2 (9.6/2).
if T1 /= Standard_Void_Type
- and then Has_Compatible_Type (R, T1)
+ and then (Universal_Access or else Has_Compatible_Type (R, T1))
and then
((not Is_Limited_Type (T1)
@@ -6748,6 +6954,9 @@ package body Sem_Ch4 is
(Nkind (N) /= N_Op_Ne
or else not Is_Tagged_Type (T1)
or else Chars (Op_Id) = Name_Op_Eq)
+
+ and then (not Universal_Access
+ or else Check_Access_Object_Types (R, T1))
then
if Found
and then Base_Type (T1) /= Base_Type (T_F)
@@ -6761,12 +6970,14 @@ package body Sem_Ch4 is
else
T_F := It.Typ;
+ Is_Universal_Access := Universal_Access;
end if;
else
Found := True;
T_F := T1;
I_F := Index;
+ Is_Universal_Access := Universal_Access;
end if;
if not Analyzed (L) then
@@ -6780,11 +6991,6 @@ package body Sem_Ch4 is
if Etype (N) = Any_Type then
Found := False;
end if;
-
- elsif Scop = Standard_Standard
- and then Ekind (T1) = E_Anonymous_Access_Type
- then
- Found := True;
end if;
end Try_One_Interp;
@@ -6819,7 +7025,6 @@ package body Sem_Ch4 is
if not Is_Overloaded (L) then
Try_One_Interp (Etype (L));
-
else
Get_First_Interp (L, Index, It);
while Present (It.Typ) loop
@@ -6827,6 +7032,18 @@ package body Sem_Ch4 is
Get_Next_Interp (Index, It);
end loop;
end if;
+
+ if Is_Universal_Access then
+ if Is_Access_Subprogram_Type (Etype (L))
+ and then Nkind (L) /= N_Null
+ and then Nkind (R) /= N_Null
+ then
+ Check_Compatible_Profiles (R, Etype (L));
+ end if;
+
+ Check_Access_Attribute (R);
+ Check_Access_Attribute (L);
+ end if;
end Find_Equality_Types;
-------------------------
@@ -7182,7 +7399,7 @@ package body Sem_Ch4 is
-- pretty much know that the other operand should be Boolean, so
-- resolve it that way (generating an error).
- elsif Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor) then
+ elsif Nkind (N) in N_Op_And | N_Op_Or | N_Op_Xor then
if Etype (L) = Standard_Boolean then
Resolve (R, Standard_Boolean);
return;
@@ -7196,17 +7413,16 @@ package body Sem_Ch4 is
-- is not the same numeric type. If it is a non-numeric type,
-- then probably it is intended to match the other operand.
- elsif Nkind_In (N, N_Op_Add,
- N_Op_Divide,
- N_Op_Ge,
- N_Op_Gt,
- N_Op_Le)
- or else
- Nkind_In (N, N_Op_Lt,
- N_Op_Mod,
- N_Op_Multiply,
- N_Op_Rem,
- N_Op_Subtract)
+ elsif Nkind (N) in N_Op_Add
+ | N_Op_Divide
+ | N_Op_Ge
+ | N_Op_Gt
+ | N_Op_Le
+ | N_Op_Lt
+ | N_Op_Mod
+ | N_Op_Multiply
+ | N_Op_Rem
+ | N_Op_Subtract
then
-- If Allow_Integer_Address is active, check whether the
-- operation becomes legal after converting an operand.
@@ -7215,10 +7431,14 @@ package body Sem_Ch4 is
and then not Is_Numeric_Type (Etype (R))
then
if Address_Integer_Convert_OK (Etype (R), Etype (L)) then
+ Rewrite (L,
+ Unchecked_Convert_To (
+ Standard_Address, Relocate_Node (L)));
Rewrite (R,
- Unchecked_Convert_To (Etype (L), Relocate_Node (R)));
+ Unchecked_Convert_To (
+ Standard_Address, Relocate_Node (R)));
- if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then
+ if Nkind (N) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt then
Analyze_Comparison_Op (N);
else
Analyze_Arithmetic_Op (N);
@@ -7234,9 +7454,13 @@ package body Sem_Ch4 is
then
if Address_Integer_Convert_OK (Etype (L), Etype (R)) then
Rewrite (L,
- Unchecked_Convert_To (Etype (R), Relocate_Node (L)));
+ Unchecked_Convert_To (
+ Standard_Address, Relocate_Node (L)));
+ Rewrite (R,
+ Unchecked_Convert_To (
+ Standard_Address, Relocate_Node (R)));
- if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then
+ if Nkind (N) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt then
Analyze_Comparison_Op (N);
else
Analyze_Arithmetic_Op (N);
@@ -7261,12 +7485,12 @@ package body Sem_Ch4 is
begin
Rewrite (L,
Unchecked_Convert_To (
- Standard_Integer, Relocate_Node (L)));
+ Standard_Address, Relocate_Node (L)));
Rewrite (R,
Unchecked_Convert_To (
- Standard_Integer, Relocate_Node (R)));
+ Standard_Address, Relocate_Node (R)));
- if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then
+ if Nkind (N) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt then
Analyze_Comparison_Op (N);
else
Analyze_Arithmetic_Op (N);
@@ -7290,7 +7514,7 @@ package body Sem_Ch4 is
elsif Null_To_Null_Address_Convert_OK (N) then
Replace_Null_By_Null_Address (N);
- if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then
+ if Nkind (N) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt then
Analyze_Comparison_Op (N);
else
Analyze_Arithmetic_Op (N);
@@ -7302,7 +7526,7 @@ package body Sem_Ch4 is
-- Comparisons on A'Access are common enough to deserve a
-- special message.
- elsif Nkind_In (N, N_Op_Eq, N_Op_Ne)
+ elsif Nkind (N) in N_Op_Eq | N_Op_Ne
and then Ekind (Etype (L)) = E_Access_Attribute_Type
and then Ekind (Etype (R)) = E_Access_Attribute_Type
then
@@ -7360,10 +7584,14 @@ package body Sem_Ch4 is
return;
- elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) then
+ elsif Nkind (N) in N_Op_Eq | N_Op_Ne then
if Address_Integer_Convert_OK (Etype (R), Etype (L)) then
+ Rewrite (L,
+ Unchecked_Convert_To (
+ Standard_Address, Relocate_Node (L)));
Rewrite (R,
- Unchecked_Convert_To (Etype (L), Relocate_Node (R)));
+ Unchecked_Convert_To (
+ Standard_Address, Relocate_Node (R)));
Analyze_Equality_Op (N);
return;
@@ -7447,7 +7675,7 @@ package body Sem_Ch4 is
-- indicate that the integer operand should be of
-- type Integer.
- if Nkind_In (N, N_Op_Multiply, N_Op_Divide)
+ if Nkind (N) in N_Op_Multiply | N_Op_Divide
and then Is_Fixed_Point_Type (Etype (L))
and then Is_Integer_Type (Etype (R))
then
@@ -7481,48 +7709,6 @@ package body Sem_Ch4 is
end if;
end Operator_Check;
- -----------------------------------------
- -- Process_Implicit_Dereference_Prefix --
- -----------------------------------------
-
- function Process_Implicit_Dereference_Prefix
- (E : Entity_Id;
- P : Entity_Id) return Entity_Id
- is
- Ref : Node_Id;
- Typ : constant Entity_Id := Designated_Type (Etype (P));
-
- begin
- if Present (E)
- and then (Operating_Mode = Check_Semantics or else not Expander_Active)
- then
- -- We create a dummy reference to E to ensure that the reference is
- -- not considered as part of an assignment (an implicit dereference
- -- can never assign to its prefix). The Comes_From_Source attribute
- -- needs to be propagated for accurate warnings.
-
- Ref := New_Occurrence_Of (E, Sloc (P));
- Set_Comes_From_Source (Ref, Comes_From_Source (P));
- Generate_Reference (E, Ref);
- end if;
-
- -- An implicit dereference is a legal occurrence of an incomplete type
- -- imported through a limited_with clause, if the full view is visible.
-
- if From_Limited_With (Typ)
- and then not From_Limited_With (Scope (Typ))
- and then
- (Is_Immediately_Visible (Scope (Typ))
- or else
- (Is_Child_Unit (Scope (Typ))
- and then Is_Visible_Lib_Unit (Scope (Typ))))
- then
- return Available_View (Typ);
- else
- return Typ;
- end if;
- end Process_Implicit_Dereference_Prefix;
-
--------------------------------
-- Remove_Abstract_Operations --
--------------------------------
@@ -7563,7 +7749,7 @@ package body Sem_Ch4 is
Formal := First_Entity (It.Nam);
if Op = Second_Op then
- Formal := Next_Entity (Formal);
+ Next_Entity (Formal);
end if;
if Is_Descendant_Of_Address (Etype (Formal)) then
@@ -7791,7 +7977,7 @@ package body Sem_Ch4 is
Prefix : Node_Id;
Exprs : List_Id) return Boolean
is
- Pref_Typ : constant Entity_Id := Etype (Prefix);
+ Pref_Typ : Entity_Id := Etype (Prefix);
function Constant_Indexing_OK return Boolean;
-- Constant_Indexing is legal if there is no Variable_Indexing defined
@@ -7842,8 +8028,8 @@ package body Sem_Ch4 is
-- resolution does not depend on the type of the parameter that
-- includes the indexing operation.
- elsif Nkind_In (Parent (Par), N_Function_Call,
- N_Procedure_Call_Statement)
+ elsif Nkind (Parent (Par)) in
+ N_Function_Call | N_Procedure_Call_Statement
and then Is_Entity_Name (Name (Parent (Par)))
then
declare
@@ -8227,6 +8413,25 @@ package body Sem_Ch4 is
return True;
end if;
+ -- An explicit dereference needs to be created in the case of a prefix
+ -- that's an access.
+
+ -- It seems that this should be done elsewhere, but not clear where that
+ -- should happen. Normally Insert_Explicit_Dereference is called via
+ -- Resolve_Implicit_Dereference, called from Resolve_Indexed_Component,
+ -- but that won't be called in this case because we transform the
+ -- indexing to a call. Resolve_Call.Check_Prefixed_Call takes care of
+ -- implicit dereferencing and referencing on prefixed calls, but that
+ -- would be too late, even if we expanded to a prefix call, because
+ -- Process_Indexed_Component will flag an error before the resolution
+ -- happens. ???
+
+ if Is_Access_Type (Pref_Typ) then
+ Pref_Typ := Implicitly_Designated_Type (Pref_Typ);
+ Insert_Explicit_Dereference (Prefix);
+ Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N);
+ end if;
+
C_Type := Pref_Typ;
-- If indexing a class-wide container, obtain indexing primitive from
@@ -8268,7 +8473,8 @@ package body Sem_Ch4 is
-- as such and retry.
if Has_Implicit_Dereference (Pref_Typ) then
- Build_Explicit_Dereference (Prefix, First_Discriminant (Pref_Typ));
+ Build_Explicit_Dereference
+ (Prefix, Get_Reference_Discriminant (Pref_Typ));
return Try_Container_Indexing (N, Prefix, Exprs);
-- Otherwise this is definitely not container indexing
@@ -8290,8 +8496,8 @@ package body Sem_Ch4 is
-- the Controlled types. The code below is motivated by containers that
-- are derived from other types with a Reference aspect.
-- Note as well that we need to examine the base type, given that
- -- the container object may be a constrained subtype or itype which
- -- does not have an explicit declaration,
+ -- the container object may be a constrained subtype or itype that
+ -- does not have an explicit declaration.
elsif Is_Derived_Type (C_Type)
and then Etype (First_Formal (Entity (Func_Name))) /= Pref_Typ
@@ -8348,6 +8554,12 @@ package body Sem_Ch4 is
if not Is_Overloaded (Func_Name) then
Func := Entity (Func_Name);
+ -- Can happen in case of e.g. cascaded errors
+
+ if No (Func) then
+ return False;
+ end if;
+
Indexing :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Func, Loc),
@@ -8630,7 +8842,9 @@ package body Sem_Ch4 is
-- Transform Obj.Operation (X, Y, ...) into Operation (Obj, X, Y ...).
-- Call_Node is the resulting subprogram call, Node_To_Replace is
-- either N or the parent of N, and Subprog is a reference to the
- -- subprogram we are trying to match.
+ -- subprogram we are trying to match. Note that the transformation
+ -- may be partially destructive for the parent of N, so it needs to
+ -- be undone in the case where Try_Object_Operation returns false.
function Try_Class_Wide_Operation
(Call_Node : Node_Id;
@@ -8888,14 +9102,6 @@ package body Sem_Ch4 is
Actuals : List_Id;
begin
- -- Obj may already have been rewritten if it involves an implicit
- -- dereference (e.g. if it is an access to a limited view). Preserve
- -- a link to the original node for ASIS use.
-
- if not Comes_From_Source (Obj) then
- Set_Original_Node (Dummy, Original_Node (Obj));
- end if;
-
-- Common case covering 1) Call to a procedure and 2) Call to a
-- function that has some additional actuals.
@@ -8909,7 +9115,7 @@ package body Sem_Ch4 is
-- example:
-- Some_Subprogram (..., Obj.Operation, ...)
- and then Name (Parent_Node) = N
+ and then N = Name (Parent_Node)
then
Node_To_Replace := Parent_Node;
@@ -9058,7 +9264,7 @@ package body Sem_Ch4 is
Hom := Current_Entity (Subprog);
while Present (Hom) loop
- if Ekind_In (Hom, E_Procedure, E_Function)
+ if Ekind (Hom) in E_Procedure | E_Function
and then Present (Renamed_Entity (Hom))
and then Is_Generic_Actual_Subprogram (Hom)
and then In_Open_Scopes (Scope (Hom))
@@ -9068,7 +9274,7 @@ package body Sem_Ch4 is
Candidate := Hom;
end if;
- if Ekind_In (Candidate, E_Function, E_Procedure)
+ if Ekind (Candidate) in E_Function | E_Procedure
and then (not Is_Hidden (Candidate) or else In_Instance)
and then Scope (Candidate) = Scope (Base_Type (Anc_Type))
and then First_Formal_Match (Candidate, CW_Typ)
@@ -9246,8 +9452,8 @@ package body Sem_Ch4 is
Obj_Type := Designated_Type (Obj_Type);
end if;
- if Ekind_In (Obj_Type, E_Private_Subtype,
- E_Record_Subtype_With_Private)
+ if Ekind (Obj_Type)
+ in E_Private_Subtype | E_Record_Subtype_With_Private
then
Obj_Type := Base_Type (Obj_Type);
end if;
@@ -9417,7 +9623,7 @@ package body Sem_Ch4 is
if Is_Derived_Type (T) then
return Primitive_Operations (T);
- elsif Ekind_In (Scope (T), E_Procedure, E_Function) then
+ elsif Ekind (Scope (T)) in E_Procedure | E_Function then
-- Scan the list of generic formals to find subprograms
-- that may have a first controlling formal of the type.
@@ -9480,7 +9686,7 @@ package body Sem_Ch4 is
Type_Scope : constant Entity_Id := Scope (T);
Op_List : Elist_Id := Primitive_Operations (T);
begin
- if Ekind_In (Type_Scope, E_Package, E_Generic_Package)
+ if Is_Package_Or_Generic_Package (Type_Scope)
and then ((In_Package_Body (Type_Scope)
and then In_Open_Scopes (Type_Scope)) or else In_Instance_Body)
then
@@ -9947,8 +10153,20 @@ package body Sem_Ch4 is
return True;
else
- -- There was no candidate operation, so report it as an error
- -- in the caller: Analyze_Selected_Component.
+ -- There was no candidate operation, but Analyze_Selected_Component
+ -- may continue the analysis so we need to undo the change possibly
+ -- made to the Parent of N earlier by Transform_Object_Operation.
+
+ declare
+ Parent_Node : constant Node_Id := Parent (N);
+
+ begin
+ if Node_To_Replace = Parent_Node then
+ Remove (First (Parameter_Associations (New_Call_Node)));
+ Set_Parent
+ (Parameter_Associations (New_Call_Node), Parent_Node);
+ end if;
+ end;
return False;
end if;
diff --git a/gcc/ada/sem_ch4.ads b/gcc/ada/sem_ch4.ads
index 4cadeec..25daab2 100644
--- a/gcc/ada/sem_ch4.ads
+++ b/gcc/ada/sem_ch4.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 2342c54..336507a 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,6 +26,7 @@
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
+with Debug; use Debug;
with Einfo; use Einfo;
with Errout; use Errout;
with Expander; use Expander;
@@ -39,8 +40,6 @@ with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
-with Restrict; use Restrict;
-with Rident; use Rident;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
@@ -306,9 +305,8 @@ package body Sem_Ch5 is
if Is_Entity_Name (Opnd)
and then (Ekind (Entity (Opnd)) = E_Out_Parameter
- or else Ekind_In (Entity (Opnd),
- E_In_Out_Parameter,
- E_Generic_In_Out_Parameter)
+ or else Ekind (Entity (Opnd)) in
+ E_In_Out_Parameter | E_Generic_In_Out_Parameter
or else
(Ekind (Entity (Opnd)) = E_Variable
and then Nkind (Parent (Entity (Opnd))) =
@@ -321,7 +319,7 @@ package body Sem_Ch5 is
-- If assignment operand is a component reference, then we get the
-- actual subtype of the component for the unconstrained case.
- elsif Nkind_In (Opnd, N_Selected_Component, N_Explicit_Dereference)
+ elsif Nkind (Opnd) in N_Selected_Component | N_Explicit_Dereference
and then not Is_Unchecked_Union (Opnd_Type)
then
Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd);
@@ -823,12 +821,10 @@ package body Sem_Ch5 is
-- that of the target mutable object.
if Is_Entity_Name (Lhs)
- and then Ekind_In (Entity (Lhs), E_In_Out_Parameter,
- E_Out_Parameter,
- E_Variable)
+ and then Is_Assignable (Entity (Lhs))
and then Is_Composite_Type (T1)
and then not Is_Constrained (Etype (Entity (Lhs)))
- and then Nkind_In (Rhs, N_If_Expression, N_Case_Expression)
+ and then Nkind (Rhs) in N_If_Expression | N_Case_Expression
then
Resolve (Rhs, Base_Type (T1));
@@ -997,7 +993,7 @@ package body Sem_Ch5 is
and then (Nkind (Rhs) /= N_Function_Call
or else Nkind (N) /= N_Block_Statement)
then
- -- Assignment verifies that the length of the Lsh and Rhs are equal,
+ -- Assignment verifies that the length of the Lhs and Rhs are equal,
-- but of course the indexes do not have to match. If the right-hand
-- side is a type conversion to an unconstrained type, a length check
-- is performed on the expression itself during expansion. In rare
@@ -1005,7 +1001,7 @@ package body Sem_Ch5 is
-- with a different representation, triggering incorrect code in the
-- back end.
- Apply_Length_Check (Rhs, Etype (Lhs));
+ Apply_Length_Check_On_Assignment (Rhs, Etype (Lhs), Lhs);
else
-- Discriminant checks are applied in the course of expansion
@@ -1242,7 +1238,7 @@ package body Sem_Ch5 is
-- Do not install the return object
- if not Ekind_In (Id, E_Constant, E_Variable)
+ if Ekind (Id) not in E_Constant | E_Variable
or else not Is_Return_Object (Id)
then
Install_Entity (Id);
@@ -1263,13 +1259,6 @@ package body Sem_Ch5 is
-- Start of processing for Analyze_Block_Statement
begin
- -- In SPARK mode, we reject block statements. Note that the case of
- -- block statements generated by the expander is fine.
-
- if Nkind (Original_Node (N)) = N_Block_Statement then
- Check_SPARK_05_Restriction ("block statement is not allowed", N);
- end if;
-
-- If no handled statement sequence is present, things are really messed
-- up, and we just return immediately (defence against previous errors).
@@ -1483,9 +1472,7 @@ package body Sem_Ch5 is
if Is_Entity_Name (Exp) then
Ent := Entity (Exp);
- if Ekind_In (Ent, E_Variable,
- E_In_Out_Parameter,
- E_Out_Parameter)
+ if Ekind (Ent) in E_Variable | E_In_Out_Parameter | E_Out_Parameter
then
if List_Length (Choices) = 1
and then Nkind (First (Choices)) in N_Subexpr
@@ -1583,13 +1570,6 @@ package body Sem_Ch5 is
Analyze_Choices (Alternatives (N), Exp_Type);
Check_Choices (N, Alternatives (N), Exp_Type, Others_Present);
- -- Case statement with single OTHERS alternative not allowed in SPARK
-
- if Others_Present and then List_Length (Alternatives (N)) = 1 then
- Check_SPARK_05_Restriction
- ("OTHERS as unique case alternative is not allowed", N);
- end if;
-
if Exp_Type = Universal_Integer and then not Others_Present then
Error_Msg_N ("case on universal integer requires OTHERS choice", Exp);
end if;
@@ -1672,11 +1652,6 @@ package body Sem_Ch5 is
return;
else
- if Has_Loop_In_Inner_Open_Scopes (U_Name) then
- Check_SPARK_05_Restriction
- ("exit label must name the closest enclosing loop", N);
- end if;
-
Set_Has_Exit (U_Name);
end if;
@@ -1712,42 +1687,6 @@ package body Sem_Ch5 is
Check_Unset_Reference (Cond);
end if;
- -- In SPARK mode, verify that the exit statement respects the SPARK
- -- restrictions.
-
- if Present (Cond) then
- if Nkind (Parent (N)) /= N_Loop_Statement then
- Check_SPARK_05_Restriction
- ("exit with when clause must be directly in loop", N);
- end if;
-
- else
- if Nkind (Parent (N)) /= N_If_Statement then
- if Nkind (Parent (N)) = N_Elsif_Part then
- Check_SPARK_05_Restriction
- ("exit must be in IF without ELSIF", N);
- else
- Check_SPARK_05_Restriction ("exit must be directly in IF", N);
- end if;
-
- elsif Nkind (Parent (Parent (N))) /= N_Loop_Statement then
- Check_SPARK_05_Restriction
- ("exit must be in IF directly in loop", N);
-
- -- First test the presence of ELSE, so that an exit in an ELSE leads
- -- to an error mentioning the ELSE.
-
- elsif Present (Else_Statements (Parent (N))) then
- Check_SPARK_05_Restriction ("exit must be in IF without ELSE", N);
-
- -- An exit in an ELSIF does not reach here, as it would have been
- -- detected in the case (Nkind (Parent (N)) /= N_If_Statement).
-
- elsif Present (Elsif_Parts (Parent (N))) then
- Check_SPARK_05_Restriction ("exit must be in IF without ELSIF", N);
- end if;
- end if;
-
-- Chain exit statement to associated loop entity
Set_Next_Exit_Statement (N, First_Exit_Statement (Scope_Id));
@@ -1772,8 +1711,6 @@ package body Sem_Ch5 is
Label_Ent : Entity_Id;
begin
- Check_SPARK_05_Restriction ("goto statement is not allowed", N);
-
-- Actual semantic checks
Check_Unreachable_Code (N);
@@ -1812,7 +1749,8 @@ package body Sem_Ch5 is
Scope_Id := Scope_Stack.Table (J).Entity;
if Label_Scope = Scope_Id
- or else not Ekind_In (Scope_Id, E_Block, E_Loop, E_Return_Statement)
+ or else Ekind (Scope_Id) not in
+ E_Block | E_Loop | E_Return_Statement
then
if Scope_Id /= Label_Scope then
Error_Msg_N
@@ -1847,7 +1785,7 @@ package body Sem_Ch5 is
Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
-- Recursively save value of this global, will be restored on exit
- Save_In_Deleted_Code : Boolean;
+ Save_In_Deleted_Code : Boolean := In_Deleted_Code;
Del : Boolean := False;
-- This flag gets set True if a True condition has been found, which
@@ -1893,7 +1831,7 @@ package body Sem_Ch5 is
-- If condition is False, analyze THEN with expansion off
- else -- Is_False (Expr_Value (Cond))
+ else pragma Assert (Is_False (Expr_Value (Cond)));
Expander_Mode_Save_And_Set (False);
In_Deleted_Code := True;
Analyze_Statements (Tstm);
@@ -2273,8 +2211,8 @@ package body Sem_Ch5 is
-- If the domain of iteration is an expression, create a declaration for
-- it, so that finalization actions are introduced outside of the loop.
- -- The declaration must be a renaming because the body of the loop may
- -- assign to elements.
+ -- The declaration must be a renaming (both in GNAT and GNATprove
+ -- modes), because the body of the loop may assign to elements.
if not Is_Entity_Name (Iter_Name)
@@ -2283,14 +2221,15 @@ package body Sem_Ch5 is
-- doing expansion.
and then (Nkind (Parent (N)) /= N_Quantified_Expression
- or else Operating_Mode = Check_Semantics)
+ or else (Operating_Mode = Check_Semantics
+ and then not GNATprove_Mode))
- -- Do not perform this expansion for ASIS and when expansion is
- -- disabled, where the temporary may hide the transformation of a
- -- selected component into a prefixed function call, and references
- -- need to see the original expression.
+ -- Do not perform this expansion when expansion is disabled, where the
+ -- temporary may hide the transformation of a selected component into
+ -- a prefixed function call, and references need to see the original
+ -- expression.
- and then Expander_Active
+ and then (Expander_Active or GNATprove_Mode)
then
declare
Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name);
@@ -2300,7 +2239,7 @@ package body Sem_Ch5 is
begin
-- If the domain of iteration is an array component that depends
- -- on a discriminant, create actual subtype for it. preanalysis
+ -- on a discriminant, create actual subtype for it. Preanalysis
-- does not generate the actual subtype of a selected component.
if Nkind (Iter_Name) = N_Selected_Component
@@ -2378,6 +2317,7 @@ package body Sem_Ch5 is
Insert_Actions (Parent (Parent (N)), New_List (Decl));
Rewrite (Name (N), New_Occurrence_Of (Id, Loc));
+ Analyze (Name (N));
Set_Etype (Id, Typ);
Set_Etype (Name (N), Typ);
end;
@@ -2449,7 +2389,7 @@ package body Sem_Ch5 is
-- AI12-0047 stipulates that the domain (array or container)
-- cannot be a component that depends on a discriminant if the
-- enclosing object is mutable, to prevent a modification of the
- -- dowmain of iteration in the course of an iteration.
+ -- domain of iteration in the course of an iteration.
-- If the object is an expression it has been captured in a
-- temporary, so examine original node.
@@ -2515,7 +2455,7 @@ package body Sem_Ch5 is
Check_Subtype_Indication (Etype (Def_Id));
- -- For a predefined container, The type of the loop variable is
+ -- For a predefined container, the type of the loop variable is
-- the Iterator_Element aspect of the container type.
else
@@ -2580,10 +2520,9 @@ package body Sem_Ch5 is
if Nkind (Orig_Iter_Name) = N_Selected_Component
and then
Present (Entity (Selector_Name (Orig_Iter_Name)))
- and then Ekind_In
- (Entity (Selector_Name (Orig_Iter_Name)),
- E_Component,
- E_Discriminant)
+ and then
+ Ekind (Entity (Selector_Name (Orig_Iter_Name))) in
+ E_Component | E_Discriminant
and then Is_Dependent_Component_Of_Mutable_Object
(Orig_Iter_Name)
then
@@ -2686,6 +2625,10 @@ package body Sem_Ch5 is
end if;
end if;
+
+ if Present (Iterator_Filter (N)) then
+ Analyze_And_Resolve (Iterator_Filter (N), Standard_Boolean);
+ end if;
end Analyze_Iterator_Specification;
-------------------
@@ -2857,8 +2800,8 @@ package body Sem_Ch5 is
if Analyzed (Original_Bound) then
return Original_Bound;
- elsif Nkind_In (Analyzed_Bound, N_Integer_Literal,
- N_Character_Literal)
+ elsif Nkind (Analyzed_Bound) in
+ N_Integer_Literal | N_Character_Literal
or else Is_Entity_Name (Analyzed_Bound)
then
Analyze_And_Resolve (Original_Bound, Typ);
@@ -3015,13 +2958,6 @@ package body Sem_Ch5 is
end if;
end;
- -- Loop parameter specification must include subtype mark in SPARK
-
- if Nkind (DS) = N_Range then
- Check_SPARK_05_Restriction
- ("loop parameter specification must include subtype mark", N);
- end if;
-
-- Analyze the subtype definition and create temporaries for the bounds.
-- Do not evaluate the range when preanalyzing a quantified expression
-- because bounds expressed as function calls with side effects will be
@@ -3063,8 +2999,8 @@ package body Sem_Ch5 is
and then not Is_Type (Entity (DS_Copy)))
or else (Nkind (DS_Copy) = N_Attribute_Reference
- and then Nam_In (Attribute_Name (DS_Copy),
- Name_Loop_Entry, Name_Old))
+ and then Attribute_Name (DS_Copy) in
+ Name_Loop_Entry | Name_Old)
or else Has_Aspect (Etype (DS_Copy), Aspect_Iterable)
@@ -3160,7 +3096,7 @@ package body Sem_Ch5 is
Check_Predicate_Use (Entity (Subtype_Mark (DS)));
end if;
- Make_Index (DS, N, In_Iter_Schm => True);
+ Make_Index (DS, N);
Set_Ekind (Id, E_Loop_Parameter);
-- A quantified expression which appears in a pre- or post-condition may
@@ -3204,14 +3140,15 @@ package body Sem_Ch5 is
-- Case where we have a range or a subtype, get type bounds
- if Nkind_In (DS, N_Range, N_Subtype_Indication)
+ if Nkind (DS) in N_Range | N_Subtype_Indication
and then not Error_Posted (DS)
and then Etype (DS) /= Any_Type
and then Is_Discrete_Type (Etype (DS))
then
declare
- L : Node_Id;
- H : Node_Id;
+ L : Node_Id;
+ H : Node_Id;
+ Null_Range : Boolean := False;
begin
if Nkind (DS) = N_Range then
@@ -3231,6 +3168,14 @@ package body Sem_Ch5 is
-- null range may be detected statically.
if Compile_Time_Compare (L, H, Assume_Valid => True) = GT then
+ if Compile_Time_Compare (L, H, Assume_Valid => False) = GT then
+ -- Since we know the range of the loop is always null,
+ -- set the appropriate flag to remove the loop entirely
+ -- during expansion.
+
+ Set_Is_Null_Loop (Loop_Nod);
+ Null_Range := True;
+ end if;
-- Suppress the warning if inside a generic template or
-- instance, since in practice they tend to be dubious in these
@@ -3241,24 +3186,14 @@ package body Sem_Ch5 is
-- Specialize msg if invalid values could make the loop
-- non-null after all.
- if Compile_Time_Compare
- (L, H, Assume_Valid => False) = GT
- then
- -- Since we know the range of the loop is null, set the
- -- appropriate flag to remove the loop entirely during
- -- expansion.
-
- Set_Is_Null_Loop (Loop_Nod);
-
+ if Null_Range then
if Comes_From_Source (N) then
Error_Msg_N
("??loop range is null, loop will not execute", DS);
end if;
- -- Here is where the loop could execute because of
- -- invalid values, so issue appropriate message and in
- -- this case we do not set the Is_Null_Loop flag since
- -- the loop may execute.
+ -- Here is where the loop could execute because of
+ -- invalid values, so issue appropriate message.
elsif Comes_From_Source (N) then
Error_Msg_N
@@ -3367,10 +3302,20 @@ package body Sem_Ch5 is
-- the warning is perfectly acceptable.
exception
- when others => null;
+ when others =>
+ -- With debug flag K we will get an exception unless an error
+ -- has already occurred (useful for debugging).
+
+ if Debug_Flag_K then
+ Check_Error_Detected;
+ end if;
end;
end if;
+ if Present (Iterator_Filter (N)) then
+ Analyze_And_Resolve (Iterator_Filter (N), Standard_Boolean);
+ end if;
+
-- A loop parameter cannot be effectively volatile (SPARK RM 7.1.3(4)).
-- This check is relevant only when SPARK_Mode is on as it is not a
-- standard Ada legality check.
@@ -3389,13 +3334,6 @@ package body Sem_Ch5 is
-- The following exception is raised by routine Prepare_Loop_Statement
-- to avoid further analysis of a transformed loop.
- function Disable_Constant (N : Node_Id) return Traverse_Result;
- -- If N represents an E_Variable entity, set Is_True_Constant To False
-
- procedure Disable_Constants is new Traverse_Proc (Disable_Constant);
- -- Helper for Analyze_Loop_Statement, to unset Is_True_Constant on
- -- variables referenced within an OpenACC construct.
-
procedure Prepare_Loop_Statement
(Iter : Node_Id;
Stop_Processing : out Boolean);
@@ -3403,22 +3341,6 @@ package body Sem_Ch5 is
-- transformed prior to analysis, and if so, perform it.
-- If Stop_Processing is set to True, should stop further processing.
- ----------------------
- -- Disable_Constant --
- ----------------------
-
- function Disable_Constant (N : Node_Id) return Traverse_Result is
- begin
- if Is_Entity_Name (N)
- and then Present (Entity (N))
- and then Ekind (Entity (N)) = E_Variable
- then
- Set_Is_True_Constant (Entity (N), False);
- end if;
-
- return OK;
- end Disable_Constant;
-
----------------------------
-- Prepare_Loop_Statement --
----------------------------
@@ -3975,7 +3897,7 @@ package body Sem_Ch5 is
Enter_Name (Id);
end if;
- -- In an element iterator, The loop parameter is a variable if
+ -- In an element iterator, the loop parameter is a variable if
-- the domain of iteration (container or array) is a variable.
if not Of_Present (I_Spec)
@@ -3994,6 +3916,12 @@ package body Sem_Ch5 is
Analyze_Statements (Statements (N));
end if;
+ -- If the loop has no side effects, mark it for removal.
+
+ if Side_Effect_Free_Loop (N) then
+ Set_Is_Null_Loop (N);
+ end if;
+
-- When the iteration scheme of a loop contains attribute 'Loop_Entry,
-- the loop is transformed into a conditional block. Retrieve the loop.
@@ -4030,15 +3958,6 @@ package body Sem_Ch5 is
if No (Iter) and then not Has_Exit (Ent) then
Check_Unreachable_Code (Stmt);
end if;
-
- -- Variables referenced within a loop subject to possible OpenACC
- -- offloading may be implicitly written to as part of the OpenACC
- -- transaction. Clear flags possibly conveying that they are constant,
- -- set for example when the code does not explicitly assign them.
-
- if Is_OpenAcc_Environment (Stmt) then
- Disable_Constants (Stmt);
- end if;
end Analyze_Loop_Statement;
----------------------------
@@ -4166,12 +4085,9 @@ package body Sem_Ch5 is
end loop;
-- If a label follows us, then we never have dead code, since
- -- someone could branch to the label, so we just ignore it, unless
- -- we are in formal mode where goto statements are not allowed.
+ -- someone could branch to the label, so we just ignore it.
- if Nkind (Nxt) = N_Label
- and then not Restriction_Check_Required (SPARK_05)
- then
+ if Nkind (Nxt) = N_Label then
return;
-- Otherwise see if we have a real statement following us
@@ -4204,8 +4120,8 @@ package body Sem_Ch5 is
-- This is the one case where we remove dead code in the
-- semantics as opposed to the expander, and we do not want
-- to remove code if we are not in code generation mode,
- -- since this messes up the ASIS trees or loses useful
- -- information in the CodePeer tree.
+ -- since this messes up the tree or loses useful information
+ -- for CodePeer.
-- Note that one might react by moving the whole circuit to
-- exp_ch5, but then we lose the warning in -gnatc mode.
@@ -4230,15 +4146,8 @@ package body Sem_Ch5 is
end loop;
end if;
- -- Now issue the warning (or error in formal mode)
-
- if Restriction_Check_Required (SPARK_05) then
- Check_SPARK_05_Restriction
- ("unreachable code is not allowed", Error_Node);
- else
- Error_Msg
- ("??unreachable code!", Sloc (Error_Node), Error_Node);
- end if;
+ Error_Msg
+ ("??unreachable code!", Sloc (Error_Node), Error_Node);
end if;
-- If the unconditional transfer of control instruction is the
@@ -4478,21 +4387,8 @@ package body Sem_Ch5 is
-- visible in the loop.
elsif Has_Implicit_Dereference (Etype (R_Copy)) then
- declare
- Disc : Entity_Id;
-
- begin
- Disc := First_Discriminant (Typ);
- while Present (Disc) loop
- if Has_Implicit_Dereference (Disc) then
- Build_Explicit_Dereference (R_Copy, Disc);
- exit;
- end if;
-
- Next_Discriminant (Disc);
- end loop;
- end;
-
+ Build_Explicit_Dereference
+ (R_Copy, Get_Reference_Discriminant (Etype (R_Copy)));
end if;
end if;
diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads
index fcf665c..55200e4 100644
--- a/gcc/ada/sem_ch5.ads
+++ b/gcc/ada/sem_ch5.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index eca0557..ed1c326 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,6 +32,7 @@ with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
+with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
@@ -51,7 +52,6 @@ with Nmake; use Nmake;
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
-with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
@@ -152,6 +152,16 @@ package body Sem_Ch6 is
-- against a formal access-to-subprogram type so Get_Instance_Of must
-- be called.
+ procedure Check_Formal_Subprogram_Conformance
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Err_Loc : Node_Id;
+ Errmsg : Boolean;
+ Conforms : out Boolean);
+ -- Core implementation of Check_Formal_Subprogram_Conformance from spec.
+ -- Errmsg can be set to False to not emit error messages.
+ -- Conforms is set to True if there is conformance, False otherwise.
+
procedure Check_Limited_Return
(N : Node_Id;
Expr : Node_Id;
@@ -225,8 +235,6 @@ package body Sem_Ch6 is
Analyze_Subprogram_Specification (Specification (N));
begin
- Check_SPARK_05_Restriction ("abstract subprogram is not allowed", N);
-
Generate_Definition (Subp_Id);
-- Set the SPARK mode from the current context (may be overwritten later
@@ -423,14 +431,6 @@ package body Sem_Ch6 is
Relocate_Pragmas_To_Body (N);
Analyze (N);
- -- Once the aspects of the generated body have been analyzed, create
- -- a copy for ASIS purposes and associate it with the original node.
-
- if Has_Aspects (N) then
- Set_Aspect_Specifications (Orig_N,
- New_Copy_List_Tree (Aspect_Specifications (N)));
- end if;
-
-- Prev is the previous entity with the same name, but it is can
-- be an unrelated spec that is not completed by the expression
-- function. In that case the relevant entity is the one in the body.
@@ -484,14 +484,6 @@ package body Sem_Ch6 is
Analyze (N);
- -- Once the aspects of the generated spec have been analyzed, create
- -- a copy for ASIS purposes and associate it with the original node.
-
- if Has_Aspects (N) then
- Set_Aspect_Specifications (Orig_N,
- New_Copy_List_Tree (Aspect_Specifications (N)));
- end if;
-
-- If aspect SPARK_Mode was specified on the body, it needs to be
-- repeated both on the generated spec and the body.
@@ -517,9 +509,14 @@ package body Sem_Ch6 is
-- Within a generic preanalyze the original expression for name
-- capture. The body is also generated but plays no role in
-- this because it is not part of the original source.
+ -- If this is an ignored Ghost entity, analysis of the generated
+ -- body is needed to hide external references (as is done in
+ -- Analyze_Subprogram_Body) after which the the subprogram profile
+ -- can be frozen, which is needed to expand calls to such an ignored
+ -- Ghost subprogram.
if Inside_A_Generic then
- Set_Has_Completion (Def_Id);
+ Set_Has_Completion (Def_Id, not Is_Ignored_Ghost_Entity (Def_Id));
Push_Scope (Def_Id);
Install_Formals (Def_Id);
Preanalyze_Spec_Expression (Expr, Etype (Def_Id));
@@ -571,6 +568,50 @@ package body Sem_Ch6 is
Check_Limited_Return (Original_Node (N), Expr, Typ);
End_Scope;
end if;
+
+ -- In the case of an expression function marked with the
+ -- aspect Static, we need to check the requirement that the
+ -- function's expression is a potentially static expression.
+ -- This is done by making a full copy of the expression tree
+ -- and performing a special preanalysis on that tree with
+ -- the global flag Checking_Potentially_Static_Expression
+ -- enabled. If the resulting expression is static, then it's
+ -- OK, but if not, that means the expression violates the
+ -- requirements of the Ada 202x RM in 4.9(3.2/5-3.4/5) and
+ -- we flag an error.
+
+ if Is_Static_Function (Def_Id) then
+ if not Is_Static_Expression (Expr) then
+ declare
+ Exp_Copy : constant Node_Id := New_Copy_Tree (Expr);
+ begin
+ Set_Checking_Potentially_Static_Expression (True);
+
+ Preanalyze_Formal_Expression (Exp_Copy, Typ);
+
+ if not Is_Static_Expression (Exp_Copy) then
+ Error_Msg_N
+ ("static expression function requires "
+ & "potentially static expression", Expr);
+ end if;
+
+ Set_Checking_Potentially_Static_Expression (False);
+ end;
+ end if;
+
+ -- We also make an additional copy of the expression and
+ -- replace the expression of the expression function with
+ -- this copy, because the currently present expression is
+ -- now associated with the body created for the static
+ -- expression function, which will later be analyzed and
+ -- possibly rewritten, and we need to have the separate
+ -- unanalyzed copy available for use with later static
+ -- calls.
+
+ Set_Expression
+ (Original_Node (Subprogram_Spec (Def_Id)),
+ New_Copy_Tree (Expr));
+ end if;
end if;
end;
end if;
@@ -694,7 +735,11 @@ package body Sem_Ch6 is
R_Type : constant Entity_Id := Etype (Scope_Id);
-- Function result subtype
- procedure Check_Return_Obj_Accessibility (Return_Stmt : Node_Id);
+ procedure Check_No_Return_Expression (Return_Expr : Node_Id);
+ -- Ada 2020: Check that the return expression in a No_Return function
+ -- meets the conditions specified by RM 6.5.1(5.1/5).
+
+ procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id);
-- Apply legality rule of 6.5 (5.9) to the access discriminants of an
-- aggregate in a return statement.
@@ -702,32 +747,62 @@ package body Sem_Ch6 is
-- Check that the return_subtype_indication properly matches the result
-- subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
- ------------------------------------
- -- Check_Return_Obj_Accessibility --
- ------------------------------------
+ --------------------------------
+ -- Check_No_Return_Expression --
+ --------------------------------
+
+ procedure Check_No_Return_Expression (Return_Expr : Node_Id) is
+ Kind : constant Node_Kind := Nkind (Return_Expr);
+
+ begin
+ if Kind = N_Raise_Expression then
+ return;
+
+ elsif Kind = N_Function_Call
+ and then Is_Entity_Name (Name (Return_Expr))
+ and then Ekind (Entity (Name (Return_Expr))) in
+ E_Function | E_Generic_Function
+ and then No_Return (Entity (Name (Return_Expr)))
+ then
+ return;
+ end if;
- procedure Check_Return_Obj_Accessibility (Return_Stmt : Node_Id) is
+ Error_Msg_N
+ ("illegal expression in RETURN statement of No_Return function",
+ Return_Expr);
+ Error_Msg_N
+ ("\must be raise expression or call to No_Return (RM 6.5.1(5.1/5))",
+ Return_Expr);
+ end Check_No_Return_Expression;
+
+ ------------------------------------------
+ -- Check_Return_Construct_Accessibility --
+ ------------------------------------------
+
+ procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id) is
Assoc : Node_Id;
Agg : Node_Id := Empty;
Discr : Entity_Id;
Expr : Node_Id;
Obj : Node_Id;
Process_Exprs : Boolean := False;
- Return_Obj : Node_Id;
+ Return_Con : Node_Id;
begin
- -- Only perform checks on record types with access discriminants
+ -- Only perform checks on record types with access discriminants and
+ -- non-internally generated functions.
if not Is_Record_Type (R_Type)
or else not Has_Discriminants (R_Type)
+ or else not Comes_From_Source (Return_Stmt)
then
return;
end if;
-- We are only interested in return statements
- if not Nkind_In (Return_Stmt, N_Extended_Return_Statement,
- N_Simple_Return_Statement)
+ if Nkind (Return_Stmt) not in
+ N_Extended_Return_Statement | N_Simple_Return_Statement
then
return;
end if;
@@ -736,32 +811,47 @@ package body Sem_Ch6 is
-- simple return statement the expression is part of the node.
if Nkind (Return_Stmt) = N_Extended_Return_Statement then
- Return_Obj := Last (Return_Object_Declarations (Return_Stmt));
+ -- Obtain the object definition from the expanded extended return
- -- We could be looking at something that's been expanded with
- -- an initialzation procedure which we can safely ignore.
+ Return_Con := First (Return_Object_Declarations (Return_Stmt));
+ while Present (Return_Con) loop
+ -- Inspect the original node to avoid object declarations
+ -- expanded into renamings.
- if Nkind (Return_Obj) /= N_Object_Declaration then
- return;
- end if;
+ if Nkind (Original_Node (Return_Con)) = N_Object_Declaration
+ and then Comes_From_Source (Original_Node (Return_Con))
+ then
+ exit;
+ end if;
+
+ Nlists.Next (Return_Con);
+ end loop;
+
+ pragma Assert (Present (Return_Con));
+
+ -- Could be dealing with a renaming
+
+ Return_Con := Original_Node (Return_Con);
else
- Return_Obj := Return_Stmt;
+ Return_Con := Return_Stmt;
end if;
-- We may need to check an aggregate or a subtype indication
-- depending on how the discriminants were specified and whether
-- we are looking at an extended return statement.
- if Nkind (Return_Obj) = N_Object_Declaration
- and then Nkind (Object_Definition (Return_Obj))
+ if Nkind (Return_Con) = N_Object_Declaration
+ and then Nkind (Object_Definition (Return_Con))
= N_Subtype_Indication
then
- Assoc := First (Constraints
- (Constraint (Object_Definition (Return_Obj))));
+ Assoc := Original_Node
+ (First
+ (Constraints
+ (Constraint (Object_Definition (Return_Con)))));
else
-- Qualified expressions may be nested
- Agg := Original_Node (Expression (Return_Obj));
+ Agg := Original_Node (Expression (Return_Con));
while Nkind (Agg) = N_Qualified_Expression loop
Agg := Original_Node (Expression (Agg));
end loop;
@@ -794,71 +884,89 @@ package body Sem_Ch6 is
if Nkind (Assoc) = N_Attribute_Reference then
Expr := Assoc;
- elsif Nkind_In (Assoc, N_Component_Association,
- N_Discriminant_Association)
+ elsif Nkind (Assoc) in
+ N_Component_Association | N_Discriminant_Association
then
Expr := Expression (Assoc);
+ else
+ Expr := Empty;
end if;
-- This anonymous access discriminant has an associated
-- expression which needs checking.
- if Nkind (Expr) = N_Attribute_Reference
+ if Present (Expr)
+ and then Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) /= Name_Unrestricted_Access
then
-- Obtain the object to perform static checks on by moving
-- up the prefixes in the expression taking into account
- -- named access types.
+ -- named access types and renamed objects within the
+ -- expression.
- Obj := Prefix (Expr);
- while Nkind_In (Obj, N_Indexed_Component,
- N_Selected_Component)
+ -- Note, this loop duplicates some of the logic in
+ -- Object_Access_Level since we have to check special rules
+ -- based on the context we are in (a return aggregate)
+ -- relating to formals of the current function.
+
+ Obj := Original_Node (Prefix (Expr));
loop
- -- When we encounter a named access type then we can
- -- ignore accessibility checks on the dereference.
+ while Nkind (Obj) in N_Explicit_Dereference
+ | N_Indexed_Component
+ | N_Selected_Component
+ loop
+ -- When we encounter a named access type then we can
+ -- ignore accessibility checks on the dereference.
- if Ekind (Etype (Prefix (Obj)))
- in E_Access_Type ..
- E_Access_Protected_Subprogram_Type
- then
- if Nkind (Obj) = N_Selected_Component then
- Obj := Selector_Name (Obj);
+ if Ekind (Etype (Original_Node (Prefix (Obj))))
+ in E_Access_Type ..
+ E_Access_Protected_Subprogram_Type
+ then
+ if Nkind (Obj) = N_Selected_Component then
+ Obj := Selector_Name (Obj);
+ else
+ Obj := Original_Node (Prefix (Obj));
+ end if;
+ exit;
end if;
- exit;
- end if;
- -- Skip over the explicit dereference
+ Obj := Original_Node (Prefix (Obj));
+ end loop;
- if Nkind (Prefix (Obj)) = N_Explicit_Dereference then
- Obj := Prefix (Prefix (Obj));
+ if Nkind (Obj) = N_Selected_Component then
+ Obj := Selector_Name (Obj);
+ end if;
- -- Otherwise move up to the next prefix
+ -- Check for renamings
+ pragma Assert (Is_Entity_Name (Obj));
+
+ if Present (Renamed_Object (Entity (Obj))) then
+ Obj := Renamed_Object (Entity (Obj));
else
- Obj := Prefix (Obj);
+ exit;
end if;
end loop;
- -- Do not check aliased formals or function calls. A
- -- run-time check may still be needed ???
+ -- Do not check aliased formals statically
- if Is_Entity_Name (Obj)
- and then Comes_From_Source (Obj)
+ if Is_Formal (Entity (Obj))
+ and then (Is_Aliased (Entity (Obj))
+ or else Ekind (Etype (Entity (Obj))) =
+ E_Anonymous_Access_Type)
then
- -- Explicitly aliased formals are allowed
+ null;
- if Is_Formal (Entity (Obj))
- and then Is_Aliased (Entity (Obj))
- then
- null;
+ -- Otherwise, handle the expression normally, avoiding the
+ -- special logic above, and call Object_Access_Level with
+ -- the original expression.
- elsif Object_Access_Level (Obj) >
- Scope_Depth (Scope (Scope_Id))
- then
- Error_Msg_N
- ("access discriminant in return aggregate would "
- & "be a dangling reference", Obj);
- end if;
+ elsif Object_Access_Level (Expr) >
+ Scope_Depth (Scope (Scope_Id))
+ then
+ Error_Msg_N
+ ("access discriminant in return aggregate would "
+ & "be a dangling reference", Obj);
end if;
end if;
end if;
@@ -886,7 +994,7 @@ package body Sem_Ch6 is
end if;
end if;
end loop;
- end Check_Return_Obj_Accessibility;
+ end Check_Return_Construct_Accessibility;
-------------------------------------
-- Check_Return_Subtype_Indication --
@@ -1048,8 +1156,7 @@ package body Sem_Ch6 is
-- This early expansion is done only when the return statement is
-- not part of a handled sequence of statements.
- if Nkind_In (Expr, N_Aggregate,
- N_Extension_Aggregate)
+ if Nkind (Expr) in N_Aggregate | N_Extension_Aggregate
and then Needs_Finalization (R_Type)
and then Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
then
@@ -1081,7 +1188,7 @@ package body Sem_Ch6 is
if Expander_Active
and then Serious_Errors_Detected = 0
and then Is_Access_Type (R_Type)
- and then not Nkind_In (Expr, N_Null, N_Raise_Expression)
+ and then Nkind (Expr) not in N_Null | N_Raise_Expression
and then Is_Interface (Designated_Type (R_Type))
and then Is_Progenitor (Designated_Type (R_Type),
Designated_Type (Etype (Expr)))
@@ -1093,22 +1200,22 @@ package body Sem_Ch6 is
Resolve (Expr, R_Type);
Check_Limited_Return (N, Expr, R_Type);
- Check_Return_Obj_Accessibility (N);
- end if;
+ Check_Return_Construct_Accessibility (N);
- -- RETURN only allowed in SPARK as the last statement in function
+ -- Ada 2020 (AI12-0269): Any return statement that applies to a
+ -- nonreturning function shall be a simple_return_statement with
+ -- an expression that is a raise_expression, or else a call on a
+ -- nonreturning function, or else a parenthesized expression of
+ -- one of these.
- if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
- and then
- (Nkind (Parent (Parent (N))) /= N_Subprogram_Body
- or else Present (Next (N)))
- then
- Check_SPARK_05_Restriction
- ("RETURN should be the last statement in function", N);
+ if Ada_Version >= Ada_2020
+ and then No_Return (Scope_Id)
+ and then Comes_From_Source (N)
+ then
+ Check_No_Return_Expression (Original_Node (Expr));
+ end if;
end if;
-
else
- Check_SPARK_05_Restriction ("extended RETURN is not allowed", N);
Obj_Decl := Last (Return_Object_Declarations (N));
-- Analyze parts specific to extended_return_statement:
@@ -1125,7 +1232,33 @@ package body Sem_Ch6 is
-- object declaration.
Set_Is_Return_Object (Defining_Identifier (Obj_Decl));
- Analyze (Obj_Decl);
+
+ -- Returning a build-in-place unconstrained array type we defer
+ -- the full analysis of the returned object to avoid generating
+ -- the corresponding constrained subtype; otherwise the bounds
+ -- would be created in the stack and a dangling reference would
+ -- be returned pointing to the bounds. We perform its preanalysis
+ -- to report errors on the initializing aggregate now (if any);
+ -- we also ensure its activation chain and Master variable are
+ -- defined (if tasks are being declared) since they are generated
+ -- as part of the analysis and expansion of the object declaration
+ -- at this stage.
+
+ if Is_Array_Type (R_Type)
+ and then not Is_Constrained (R_Type)
+ and then Is_Build_In_Place_Function (Scope_Id)
+ and then Needs_BIP_Alloc_Form (Scope_Id)
+ and then Nkind (Expr) in N_Aggregate | N_Extension_Aggregate
+ then
+ Preanalyze (Obj_Decl);
+
+ if Expander_Active then
+ Ensure_Activation_Chain_And_Master (Obj_Decl);
+ end if;
+
+ else
+ Analyze (Obj_Decl);
+ end if;
Check_Return_Subtype_Indication (Obj_Decl);
@@ -1149,7 +1282,7 @@ package body Sem_Ch6 is
Check_References (Stm_Entity);
- Check_Return_Obj_Accessibility (N);
+ Check_Return_Construct_Accessibility (N);
-- Check RM 6.5 (5.9/3)
@@ -1168,6 +1301,18 @@ package body Sem_Ch6 is
("aliased only allowed for limited return objects", N);
end if;
end if;
+
+ -- Ada 2020 (AI12-0269): Any return statement that applies to a
+ -- nonreturning function shall be a simple_return_statement.
+
+ if Ada_Version >= Ada_2020
+ and then No_Return (Scope_Id)
+ and then Comes_From_Source (N)
+ then
+ Error_Msg_N
+ ("extended RETURN statement not allowed in No_Return "
+ & "function", N);
+ end if;
end;
end if;
@@ -1200,20 +1345,31 @@ package body Sem_Ch6 is
-- The return value is converted to the return type of the function,
-- which implies a predicate check if the return type is predicated.
+ -- We do not apply the check for an extended return statement because
+ -- Analyze_Object_Declaration has already done it on Obj_Decl above.
-- We do not apply the check to a case expression because it will
-- be expanded into a series of return statements, each of which
-- will receive a predicate check.
- if Nkind (Expr) /= N_Case_Expression then
+ if Nkind (N) /= N_Extended_Return_Statement
+ and then Nkind (Expr) /= N_Case_Expression
+ then
Apply_Predicate_Check (Expr, R_Type);
end if;
-- Ada 2005 (AI-318-02): When the result type is an anonymous access
-- type, apply an implicit conversion of the expression to that type
-- to force appropriate static and run-time accessibility checks.
+ -- But we want to apply the checks to an extended return statement
+ -- only once, i.e. not to the simple return statement generated at
+ -- the end of its expansion because, prior to leaving the function,
+ -- the accessibility level of the return object changes to be a level
+ -- determined by the point of call (RM 3.10.2(10.8/3)).
if Ada_Version >= Ada_2005
and then Ekind (R_Type) = E_Anonymous_Access_Type
+ and then (Nkind (N) = N_Extended_Return_Statement
+ or else not Comes_From_Extended_Return_Statement (N))
then
Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr)));
Analyze_And_Resolve (Expr, R_Type);
@@ -1839,9 +1995,9 @@ package body Sem_Ch6 is
-- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls
if Nkind (P) = N_Attribute_Reference
- and then Nam_In (Attribute_Name (P), Name_Elab_Spec,
- Name_Elab_Body,
- Name_Elab_Subp_Body)
+ and then Attribute_Name (P) in Name_Elab_Spec
+ | Name_Elab_Body
+ | Name_Elab_Subp_Body
then
if Present (Actuals) then
Error_Msg_N
@@ -1867,6 +2023,10 @@ package body Sem_Ch6 is
and then Comes_From_Source (N)
then
Error_Msg_N ("missing explicit dereference in call", N);
+
+ elsif Ekind (Entity (P)) = E_Operator then
+ Error_Msg_Name_1 := Chars (P);
+ Error_Msg_N ("operator % cannot be used as a procedure", N);
end if;
Analyze_Call_And_Resolve;
@@ -1927,9 +2087,8 @@ package body Sem_Ch6 is
-- function, the context will select the operation whose type is Void.
elsif Nkind (P) = N_Selected_Component
- and then Ekind_In (Entity (Selector_Name (P)), E_Entry,
- E_Function,
- E_Procedure)
+ and then Ekind (Entity (Selector_Name (P)))
+ in E_Entry | E_Function | E_Procedure
then
-- When front-end inlining is enabled, as with SPARK_Mode, a call
-- in prefix notation may still be missing its controlling argument,
@@ -2028,8 +2187,8 @@ package body Sem_Ch6 is
------------------------------
procedure Analyze_Return_Statement (N : Node_Id) is
- pragma Assert (Nkind_In (N, N_Extended_Return_Statement,
- N_Simple_Return_Statement));
+ pragma Assert
+ (Nkind (N) in N_Extended_Return_Statement | N_Simple_Return_Statement);
Returns_Object : constant Boolean :=
Nkind (N) = N_Extended_Return_Statement
@@ -2062,7 +2221,7 @@ package body Sem_Ch6 is
for J in reverse 0 .. Scope_Stack.Last loop
Result := Scope_Stack.Table (J).Entity;
- exit when not Ekind_In (Result, E_Block, E_Loop)
+ exit when Ekind (Result) not in E_Block | E_Loop
and then Chars (Result) /= Name_uPostconditions;
end loop;
@@ -2097,8 +2256,12 @@ package body Sem_Ch6 is
-- Check that pragma No_Return is obeyed. Don't complain about the
-- implicitly-generated return that is placed at the end.
- if No_Return (Scope_Id) and then Comes_From_Source (N) then
- Error_Msg_N ("RETURN statement not allowed (No_Return)", N);
+ if No_Return (Scope_Id)
+ and then Kind in E_Procedure | E_Generic_Procedure
+ and then Comes_From_Source (N)
+ then
+ Error_Msg_N
+ ("RETURN statement not allowed in No_Return procedure", N);
end if;
-- Warn on any unassigned OUT parameters if in procedure
@@ -2109,17 +2272,17 @@ package body Sem_Ch6 is
-- Check that functions return objects, and other things do not
- if Kind = E_Function or else Kind = E_Generic_Function then
+ if Kind in E_Function | E_Generic_Function then
if not Returns_Object then
Error_Msg_N ("missing expression in return from function", N);
end if;
- elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then
+ elsif Kind in E_Procedure | E_Generic_Procedure then
if Returns_Object then
Error_Msg_N ("procedure cannot return value (use function)", N);
end if;
- elsif Kind = E_Entry or else Kind = E_Entry_Family then
+ elsif Kind in E_Entry | E_Entry_Family then
if Returns_Object then
if Is_Protected_Type (Scope (Scope_Id)) then
Error_Msg_N ("entry body cannot return value", N);
@@ -2153,10 +2316,10 @@ package body Sem_Ch6 is
Error_Msg_N ("illegal context for return statement", N);
end if;
- if Ekind_In (Kind, E_Function, E_Generic_Function) then
+ if Kind in E_Function | E_Generic_Function then
Analyze_Function_Return (N);
- elsif Ekind_In (Kind, E_Procedure, E_Generic_Procedure) then
+ elsif Kind in E_Procedure | E_Generic_Procedure then
Set_Return_Present (Scope_Id);
end if;
@@ -2196,8 +2359,6 @@ package body Sem_Ch6 is
if Result_Definition (N) /= Error then
if Nkind (Result_Definition (N)) = N_Access_Definition then
- Check_SPARK_05_Restriction
- ("access result is not allowed", Result_Definition (N));
-- Ada 2005 (AI-254): Handle anonymous access to subprograms
@@ -2227,14 +2388,6 @@ package body Sem_Ch6 is
Typ := Entity (Result_Definition (N));
Set_Etype (Designator, Typ);
- -- Unconstrained array as result is not allowed in SPARK
-
- if Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
- Check_SPARK_05_Restriction
- ("returning an unconstrained array is not allowed",
- Result_Definition (N));
- end if;
-
-- Ada 2005 (AI-231): Ensure proper usage of null exclusion
Null_Exclusion_Static_Checks (N);
@@ -2331,8 +2484,8 @@ package body Sem_Ch6 is
null;
elsif Nkind (Parent (N)) = N_Subprogram_Body
- or else Nkind_In (Parent (Parent (N)), N_Accept_Statement,
- N_Entry_Body)
+ or else Nkind (Parent (Parent (N))) in
+ N_Accept_Statement | N_Entry_Body
then
Error_Msg_NE
("invalid use of untagged incomplete type&",
@@ -2459,6 +2612,15 @@ package body Sem_Ch6 is
-- because it is specified directly on the body, or because it is
-- inherited from the enclosing subprogram or package.
+ function Build_Internal_Protected_Declaration
+ (N : Node_Id) return Entity_Id;
+ -- A subprogram body without a previous spec that appears in a protected
+ -- body must be expanded separately to create a subprogram declaration
+ -- for it, in order to resolve internal calls to it from other protected
+ -- operations.
+ --
+ -- Possibly factor this with Exp_Dist.Copy_Specification ???
+
procedure Build_Subprogram_Declaration;
-- Create a matching subprogram declaration for subprogram body N
@@ -2507,6 +2669,12 @@ package body Sem_Ch6 is
-- the not-yet-frozen types referenced by the simple return statement
-- of the function as formally frozen.
+ procedure Move_Pragmas (From : Node_Id; To : Node_Id);
+ -- Find all suitable source pragmas at the top of subprogram body
+ -- From's declarations and move them after arbitrary node To.
+ -- One exception is pragma SPARK_Mode which is copied rather than moved,
+ -- as it applies to the body too.
+
procedure Restore_Limited_Views (Restore_List : Elist_Id);
-- Undo the transformation done by Exchange_Limited_Views.
@@ -2619,68 +2787,129 @@ package body Sem_Ch6 is
return SPARK_Mode = On;
end Body_Has_SPARK_Mode_On;
- ----------------------------------
- -- Build_Subprogram_Declaration --
- ----------------------------------
+ ------------------------------------------
+ -- Build_Internal_Protected_Declaration --
+ ------------------------------------------
- procedure Build_Subprogram_Declaration is
- procedure Move_Pragmas (From : Node_Id; To : Node_Id);
- -- Relocate certain categorization pragmas from the declarative list
- -- of subprogram body From and insert them after node To. The pragmas
- -- in question are:
- -- Ghost
- -- Volatile_Function
- -- Also copy pragma SPARK_Mode if present in the declarative list
- -- of subprogram body From and insert it after node To. This pragma
- -- should not be moved, as it applies to the body too.
+ function Build_Internal_Protected_Declaration
+ (N : Node_Id) return Entity_Id
+ is
+ procedure Analyze_Pragmas (From : Node_Id);
+ -- Analyze all pragmas which follow arbitrary node From
- ------------------
- -- Move_Pragmas --
- ------------------
+ ---------------------
+ -- Analyze_Pragmas --
+ ---------------------
- procedure Move_Pragmas (From : Node_Id; To : Node_Id) is
- Decl : Node_Id;
- Next_Decl : Node_Id;
+ procedure Analyze_Pragmas (From : Node_Id) is
+ Decl : Node_Id;
begin
- pragma Assert (Nkind (From) = N_Subprogram_Body);
-
- -- The destination node must be part of a list, as the pragmas are
- -- inserted after it.
-
- pragma Assert (Is_List_Member (To));
-
- -- Inspect the declarations of the subprogram body looking for
- -- specific pragmas.
-
- Decl := First (Declarations (N));
+ Decl := Next (From);
while Present (Decl) loop
- Next_Decl := Next (Decl);
-
if Nkind (Decl) = N_Pragma then
- if Pragma_Name_Unmapped (Decl) = Name_SPARK_Mode then
- Insert_After (To, New_Copy_Tree (Decl));
+ Analyze_Pragma (Decl);
- elsif Nam_In (Pragma_Name_Unmapped (Decl),
- Name_Ghost,
- Name_Volatile_Function)
- then
- Remove (Decl);
- Insert_After (To, Decl);
- end if;
+ -- No candidate pragmas are available for analysis
+
+ else
+ exit;
end if;
- Decl := Next_Decl;
+ Next (Decl);
end loop;
- end Move_Pragmas;
+ end Analyze_Pragmas;
-- Local variables
+ Body_Id : constant Entity_Id := Defining_Entity (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Decl : Node_Id;
+ Formal : Entity_Id;
+ Formals : List_Id;
+ Spec : Node_Id;
+ Spec_Id : Entity_Id;
+
+ -- Start of processing for Build_Internal_Protected_Declaration
+
+ begin
+ Formal := First_Formal (Body_Id);
+
+ -- The protected operation always has at least one formal, namely the
+ -- object itself, but it is only placed in the parameter list if
+ -- expansion is enabled.
+
+ if Present (Formal) or else Expander_Active then
+ Formals := Copy_Parameter_List (Body_Id);
+ else
+ Formals := No_List;
+ end if;
+
+ Spec_Id :=
+ Make_Defining_Identifier (Sloc (Body_Id),
+ Chars => Chars (Body_Id));
+
+ -- Indicate that the entity comes from source, to ensure that cross-
+ -- reference information is properly generated. The body itself is
+ -- rewritten during expansion, and the body entity will not appear in
+ -- calls to the operation.
+
+ Set_Comes_From_Source (Spec_Id, True);
+
+ if Nkind (Specification (N)) = N_Procedure_Specification then
+ Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Spec_Id,
+ Parameter_Specifications => Formals);
+ else
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Spec_Id,
+ Parameter_Specifications => Formals,
+ Result_Definition =>
+ New_Occurrence_Of (Etype (Body_Id), Loc));
+ end if;
+
+ Decl := Make_Subprogram_Declaration (Loc, Specification => Spec);
+ Set_Corresponding_Body (Decl, Body_Id);
+ Set_Corresponding_Spec (N, Spec_Id);
+
+ Insert_Before (N, Decl);
+
+ -- Associate all aspects and pragmas of the body with the spec. This
+ -- ensures that these annotations apply to the initial declaration of
+ -- the subprogram body.
+
+ Move_Aspects (From => N, To => Decl);
+ Move_Pragmas (From => N, To => Decl);
+
+ Analyze (Decl);
+
+ -- The analysis of the spec may generate pragmas which require manual
+ -- analysis. Since the generation of the spec and the relocation of
+ -- the annotations is driven by the expansion of the stand-alone
+ -- body, the pragmas will not be analyzed in a timely manner. Do this
+ -- now.
+
+ Analyze_Pragmas (Decl);
+
+ -- This subprogram has convention Intrinsic as per RM 6.3.1(10/2)
+ -- ensuring in particular that 'Access is illegal.
+
+ Set_Convention (Spec_Id, Convention_Intrinsic);
+ Set_Has_Completion (Spec_Id);
+
+ return Spec_Id;
+ end Build_Internal_Protected_Declaration;
+
+ ----------------------------------
+ -- Build_Subprogram_Declaration --
+ ----------------------------------
+
+ procedure Build_Subprogram_Declaration is
Decl : Node_Id;
Subp_Decl : Node_Id;
- -- Start of processing for Build_Subprogram_Declaration
-
begin
-- Create a matching subprogram spec using the profile of the body.
-- The structure of the tree is identical, but has new entities for
@@ -2807,22 +3036,8 @@ package body Sem_Ch6 is
and then
Is_Limited_Record (Designated_Type (Etype (Scop)))))
and then Expander_Active
-
- -- Avoid cases with no tasking support
-
- and then RTE_Available (RE_Current_Master)
- and then not Restriction_Active (No_Task_Hierarchy)
then
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uMaster),
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Master_Id), Loc),
- Expression =>
- Make_Explicit_Dereference (Loc,
- New_Occurrence_Of (RTE (RE_Current_Master), Loc)));
+ Decl := Build_Master_Declaration (Loc);
if Present (Declarations (N)) then
Prepend (Decl, Declarations (N));
@@ -2844,8 +3059,8 @@ package body Sem_Ch6 is
-- the environment task is our effective master, so nothing
-- to mark.
- if Nkind_In
- (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body)
+ if Nkind (Par)
+ in N_Task_Body | N_Block_Statement | N_Subprogram_Body
then
Set_Is_Task_Master (Par, True);
exit;
@@ -2953,7 +3168,7 @@ package body Sem_Ch6 is
-- To ensure proper coverage when body is inlined, indicate
-- whether the subprogram comes from source.
- Set_Comes_From_Source (Subp, Comes_From_Source (N));
+ Preserve_Comes_From_Source (Subp, N);
if Present (First_Formal (Body_Id)) then
Plist := Copy_Parameter_List (Body_Id);
@@ -3046,42 +3261,6 @@ package body Sem_Ch6 is
Check_Returns (HSS, 'P', Missing_Ret, Id);
end if;
end if;
-
- -- Special checks in SPARK mode
-
- if Nkind (Body_Spec) = N_Function_Specification then
-
- -- In SPARK mode, last statement of a function should be a return
-
- declare
- Stat : constant Node_Id := Last_Source_Statement (HSS);
- begin
- if Present (Stat)
- and then not Nkind_In (Stat, N_Simple_Return_Statement,
- N_Extended_Return_Statement)
- then
- Check_SPARK_05_Restriction
- ("last statement in function should be RETURN", Stat);
- end if;
- end;
-
- -- In SPARK mode, verify that a procedure has no return
-
- elsif Nkind (Body_Spec) = N_Procedure_Specification then
- if Present (Spec_Id) then
- Id := Spec_Id;
- else
- Id := Body_Id;
- end if;
-
- -- Would be nice to point to return statement here, can we
- -- borrow the Check_Returns procedure here ???
-
- if Return_Present (Id) then
- Check_SPARK_05_Restriction
- ("procedure should not have RETURN", N);
- end if;
- end if;
end Check_Missing_Return;
-----------------------
@@ -3234,7 +3413,7 @@ package body Sem_Ch6 is
-- Do not process subprogram bodies as they already use the non-
-- limited view of types.
- if not Ekind_In (Subp_Id, E_Function, E_Procedure) then
+ if Ekind (Subp_Id) not in E_Function | E_Procedure then
return No_Elist;
end if;
@@ -3337,11 +3516,11 @@ package body Sem_Ch6 is
if Is_Entity_Name (Node) and then Present (Entity (Node)) then
Mask_Type (Etype (Entity (Node)));
- if Ekind_In (Entity (Node), E_Component, E_Discriminant) then
+ if Ekind (Entity (Node)) in E_Component | E_Discriminant then
Mask_Type (Scope (Entity (Node)));
end if;
- elsif Nkind_In (Node, N_Aggregate, N_Null, N_Type_Conversion)
+ elsif Nkind (Node) in N_Aggregate | N_Null | N_Type_Conversion
and then Present (Etype (Node))
then
Mask_Type (Etype (Node));
@@ -3367,6 +3546,76 @@ package body Sem_Ch6 is
return Result;
end Mask_Unfrozen_Types;
+ ------------------
+ -- Move_Pragmas --
+ ------------------
+
+ procedure Move_Pragmas (From : Node_Id; To : Node_Id) is
+ Decl : Node_Id;
+ Insert_Nod : Node_Id;
+ Next_Decl : Node_Id;
+
+ begin
+ pragma Assert (Nkind (From) = N_Subprogram_Body);
+
+ -- The pragmas are moved in an order-preserving fashion
+
+ Insert_Nod := To;
+
+ -- Inspect the declarations of the subprogram body and relocate all
+ -- candidate pragmas.
+
+ Decl := First (Declarations (From));
+ while Present (Decl) loop
+
+ -- Preserve the following declaration for iteration purposes, due
+ -- to possible relocation of a pragma.
+
+ Next_Decl := Next (Decl);
+
+ if Nkind (Decl) = N_Pragma then
+ -- Copy pragma SPARK_Mode if present in the declarative list
+ -- of subprogram body From and insert it after node To. This
+ -- pragma should not be moved, as it applies to the body too.
+
+ if Pragma_Name_Unmapped (Decl) = Name_SPARK_Mode then
+ Insert_After (Insert_Nod, New_Copy_Tree (Decl));
+
+ -- Move relevant pragmas to the spec
+
+ elsif Pragma_Name_Unmapped (Decl) in Name_Depends
+ | Name_Ghost
+ | Name_Global
+ | Name_Pre
+ | Name_Precondition
+ | Name_Post
+ | Name_Refined_Depends
+ | Name_Refined_Global
+ | Name_Refined_Post
+ | Name_Inline
+ | Name_Pure_Function
+ | Name_Volatile_Function
+ then
+ Remove (Decl);
+ Insert_After (Insert_Nod, Decl);
+ Insert_Nod := Decl;
+ end if;
+
+ -- Skip internally generated code
+
+ elsif not Comes_From_Source (Decl) then
+ null;
+
+ -- No candidate pragmas are available for relocation
+
+ else
+ exit;
+ end if;
+
+ Decl := Next_Decl;
+ end loop;
+ end Move_Pragmas;
+
---------------------------
-- Restore_Limited_Views --
---------------------------
@@ -3441,9 +3690,9 @@ package body Sem_Ch6 is
-- expansion. As a result, we add an exception for this case.
elsif not Present (Overridden_Operation (Spec_Id))
- and then not (Nam_In (Chars (Spec_Id), Name_Adjust,
- Name_Finalize,
- Name_Initialize)
+ and then not (Chars (Spec_Id) in Name_Adjust
+ | Name_Finalize
+ | Name_Initialize
and then In_Instance)
then
Error_Msg_NE
@@ -3659,6 +3908,8 @@ package body Sem_Ch6 is
-- are legal and can be processed ahead of the body.
-- We make two copies of the given spec, one for the new
-- declaration, and one for the body.
+ -- ??? This should be conditioned on front-end inlining rather
+ -- than GNATprove_Mode.
if No (Spec_Id) and then GNATprove_Mode
@@ -3699,7 +3950,7 @@ package body Sem_Ch6 is
Build_Subprogram_Declaration;
-- If this is a function that returns a constrained array, and
- -- we are generating SPARK_For_C, create subprogram declaration
+ -- we are generating C code, create subprogram declaration
-- to simplify subsequent C generation.
elsif No (Spec_Id)
@@ -3786,15 +4037,15 @@ package body Sem_Ch6 is
-- Deal with special case of a fully private operation in the body of
-- the protected type. We must create a declaration for the subprogram,
- -- in order to attach the protected subprogram that will be used in
- -- internal calls. We exclude compiler generated bodies from the
- -- expander since the issue does not arise for those cases.
+ -- in order to attach the subprogram that will be used in internal
+ -- calls. We exclude compiler generated bodies from the expander since
+ -- the issue does not arise for those cases.
if No (Spec_Id)
and then Comes_From_Source (N)
and then Is_Protected_Type (Current_Scope)
then
- Spec_Id := Build_Private_Protected_Declaration (N);
+ Spec_Id := Build_Internal_Protected_Declaration (N);
end if;
-- If we are generating C and this is a function returning a constrained
@@ -3839,8 +4090,8 @@ package body Sem_Ch6 is
-- the freeze actions that include the bodies. In particular, extra
-- formals for accessibility or for return-in-place may need to be
-- generated. Freeze nodes, if any, are inserted before the current
- -- body. These freeze actions are also needed in ASIS mode and in
- -- Compile_Only mode to enable the proper back-end type annotations.
+ -- body. These freeze actions are also needed in Compile_Only mode to
+ -- enable the proper back-end type annotations.
-- They are necessary in any case to ensure proper elaboration order
-- in gigi.
@@ -3849,7 +4100,6 @@ package body Sem_Ch6 is
and then not Has_Completion (Spec_Id)
and then Serious_Errors_Detected = 0
and then (Expander_Active
- or else ASIS_Mode
or else Operating_Mode = Check_Semantics
or else Is_Ignored_Ghost_Entity (Spec_Id))
then
@@ -4040,9 +4290,7 @@ package body Sem_Ch6 is
-- Within an instance, add local renaming declarations so that
-- gdb can retrieve the values of actuals more easily. This is
- -- only relevant if generating code (and indeed we definitely
- -- do not want these definitions -gnatc mode, because that would
- -- confuse ASIS).
+ -- only relevant if generating code.
if Is_Generic_Instance (Spec_Id)
and then Is_Wrapper_Package (Current_Scope)
@@ -4251,13 +4499,7 @@ package body Sem_Ch6 is
-- Handle inlining
- -- Note: Normally we don't do any inlining if expansion is off, since
- -- we won't generate code in any case. An exception arises in GNATprove
- -- mode where we want to expand some calls in place, even with expansion
- -- disabled, since the inlining eases formal verification.
-
- if not GNATprove_Mode
- and then Expander_Active
+ if Expander_Active
and then Serious_Errors_Detected = 0
and then Present (Spec_Id)
and then Has_Pragma_Inline (Spec_Id)
@@ -4265,8 +4507,7 @@ package body Sem_Ch6 is
-- Legacy implementation (relying on front-end inlining)
if not Back_End_Inlining then
- if (Has_Pragma_Inline_Always (Spec_Id)
- and then not Opt.Disable_FE_Inline_Always)
+ if Has_Pragma_Inline_Always (Spec_Id)
or else (Front_End_Inlining
and then not Opt.Disable_FE_Inline)
then
@@ -4454,7 +4695,7 @@ package body Sem_Ch6 is
then
-- Generate the minimum accessibility level object
- -- A60b : integer := integer'min(2, paramL);
+ -- A60b : natural := natural'min(1, paramL);
declare
Loc : constant Source_Ptr := Sloc (Body_Nod);
@@ -4464,11 +4705,11 @@ package body Sem_Ch6 is
Make_Temporary
(Loc, 'A', Extra_Accessibility (Form)),
Object_Definition => New_Occurrence_Of
- (Standard_Integer, Loc),
+ (Standard_Natural, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of
- (Standard_Integer, Loc),
+ (Standard_Natural, Loc),
Attribute_Name => Name_Min,
Expressions => New_List (
Make_Integer_Literal (Loc,
@@ -4585,6 +4826,15 @@ package body Sem_Ch6 is
elsif Nkind (Parent (Parent (Spec_Id))) = N_Subprogram_Body_Stub then
null;
+ -- SPARK_Mode Off could complete no SPARK_Mode in a generic, either
+ -- as specified in source code, or because SPARK_Mode On is ignored
+ -- in an instance where the context is SPARK_Mode Off/Auto.
+
+ elsif Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Body_Id)) = Off
+ and then (Is_Generic_Unit (Spec_Id) or else In_Instance)
+ then
+ null;
+
else
Error_Msg_Sloc := Sloc (SPARK_Pragma (Body_Id));
Error_Msg_N ("incorrect application of SPARK_Mode #", N);
@@ -4742,9 +4992,7 @@ package body Sem_Ch6 is
-- Push_xxx_Error_Label to find the first real statement.
Stm := First (Statements (HSS));
- while Nkind_In (Stm, N_Call_Marker, N_Label)
- or else Nkind (Stm) in N_Push_xxx_Label
- loop
+ while Nkind (Stm) in N_Call_Marker | N_Label | N_Push_xxx_Label loop
Next (Stm);
end loop;
@@ -4898,8 +5146,6 @@ package body Sem_Ch6 is
if Nkind (Specification (N)) = N_Procedure_Specification
and then Null_Present (Specification (N))
then
- Check_SPARK_05_Restriction ("null procedure is not allowed", N);
-
-- Null procedures are allowed in protected types, following the
-- recent AI12-0147.
@@ -5163,15 +5409,6 @@ package body Sem_Ch6 is
-- Start of processing for Analyze_Subprogram_Specification
begin
- -- User-defined operator is not allowed in SPARK, except as a renaming
-
- if Nkind (Defining_Unit_Name (N)) = N_Defining_Operator_Symbol
- and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
- then
- Check_SPARK_05_Restriction
- ("user-defined operator is not allowed", N);
- end if;
-
-- Proceed with analysis. Do not emit a cross-reference entry if the
-- specification comes from an expression function, because it may be
-- the completion of a previous declaration. If it is not, the cross-
@@ -5311,14 +5548,12 @@ package body Sem_Ch6 is
-- In case of primitives associated with abstract interface types
-- the check is applied later (see Analyze_Subprogram_Declaration).
- if not Nkind_In (Original_Node (Parent (N)),
- N_Abstract_Subprogram_Declaration,
- N_Formal_Abstract_Subprogram_Declaration,
- N_Subprogram_Renaming_Declaration)
+ if Nkind (Original_Node (Parent (N))) not in
+ N_Abstract_Subprogram_Declaration |
+ N_Formal_Abstract_Subprogram_Declaration |
+ N_Subprogram_Renaming_Declaration
then
- if Is_Abstract_Type (Etype (Designator))
- and then not Is_Interface (Etype (Designator))
- then
+ if Is_Abstract_Type (Etype (Designator)) then
Error_Msg_N
("function that returns abstract type must be abstract", N);
@@ -5365,10 +5600,11 @@ package body Sem_Ch6 is
-- in the message, and also provides the location for posting the
-- message in the absence of a specified Err_Loc location.
- function Conventions_Match
- (Id1 : Entity_Id;
- Id2 : Entity_Id) return Boolean;
- -- Determine whether the conventions of arbitrary entities Id1 and Id2
+ function Conventions_Match (Id1, Id2 : Entity_Id) return Boolean;
+ -- True if the conventions of entities Id1 and Id2 match.
+
+ function Null_Exclusions_Match (F1, F2 : Entity_Id) return Boolean;
+ -- True if the null exclusions of two formals of anonymous access type
-- match.
-----------------------
@@ -5444,11 +5680,11 @@ package body Sem_Ch6 is
-- the only way these may receive a convention is if they inherit
-- the convention of a related subprogram.
- if Ekind_In (Id1, E_Anonymous_Access_Subprogram_Type,
- E_Subprogram_Type)
+ if Ekind (Id1) in E_Anonymous_Access_Subprogram_Type
+ | E_Subprogram_Type
or else
- Ekind_In (Id2, E_Anonymous_Access_Subprogram_Type,
- E_Subprogram_Type)
+ Ekind (Id2) in E_Anonymous_Access_Subprogram_Type
+ | E_Subprogram_Type
then
return True;
@@ -5459,13 +5695,56 @@ package body Sem_Ch6 is
end if;
end Conventions_Match;
+ ---------------------------
+ -- Null_Exclusions_Match --
+ ---------------------------
+
+ function Null_Exclusions_Match (F1, F2 : Entity_Id) return Boolean is
+ begin
+ if not Is_Anonymous_Access_Type (Etype (F1))
+ or else not Is_Anonymous_Access_Type (Etype (F2))
+ then
+ return True;
+ end if;
+
+ -- AI12-0289-1: Case of controlling access parameter; False if the
+ -- partial view is untagged, the full view is tagged, and no explicit
+ -- "not null". Note that at this point, we're processing the package
+ -- body, so private/full types have been swapped. The Sloc test below
+ -- is to detect the (legal) case where F1 comes after the full type
+ -- declaration. This part is disabled pre-2005, because "not null" is
+ -- not allowed on those language versions.
+
+ if Ada_Version >= Ada_2005
+ and then Is_Controlling_Formal (F1)
+ and then not Null_Exclusion_Present (Parent (F1))
+ and then not Null_Exclusion_Present (Parent (F2))
+ then
+ declare
+ D : constant Entity_Id := Directly_Designated_Type (Etype (F1));
+ Partial_View_Of_Desig : constant Entity_Id :=
+ Incomplete_Or_Partial_View (D);
+ begin
+ return No (Partial_View_Of_Desig)
+ or else Is_Tagged_Type (Partial_View_Of_Desig)
+ or else Sloc (D) < Sloc (F1);
+ end;
+
+ -- Not a controlling parameter, or one or both views have an explicit
+ -- "not null".
+
+ else
+ return Null_Exclusion_Present (Parent (F1)) =
+ Null_Exclusion_Present (Parent (F2));
+ end if;
+ end Null_Exclusions_Match;
+
-- Local Variables
Old_Type : constant Entity_Id := Etype (Old_Id);
New_Type : constant Entity_Id := Etype (New_Id);
Old_Formal : Entity_Id;
New_Formal : Entity_Id;
- Access_Types_Match : Boolean;
Old_Formal_Base : Entity_Id;
New_Formal_Base : Entity_Id;
@@ -5557,22 +5836,19 @@ package body Sem_Ch6 is
Error_Msg_Name_2 :=
Name_Ada + Convention_Id'Pos (Convention (New_Id));
Conformance_Error ("\prior declaration for% has convention %!");
+ return;
else
Conformance_Error ("\calling conventions do not match!");
+ return;
end if;
+ else
+ Check_Formal_Subprogram_Conformance
+ (New_Id, Old_Id, Err_Loc, Errmsg, Conforms);
- return;
-
- elsif Is_Formal_Subprogram (Old_Id)
- or else Is_Formal_Subprogram (New_Id)
- or else (Is_Subprogram (New_Id)
- and then Present (Alias (New_Id))
- and then Is_Formal_Subprogram (Alias (New_Id)))
- then
- Conformance_Error
- ("\formal subprograms are not subtype conformant "
- & "(RM 6.3.1 (17/3))");
+ if not Conforms then
+ return;
+ end if;
end if;
end if;
@@ -5632,25 +5908,14 @@ package body Sem_Ch6 is
-- Null exclusion must match
- if Null_Exclusion_Present (Parent (Old_Formal))
- /=
- Null_Exclusion_Present (Parent (New_Formal))
- then
- -- Only give error if both come from source. This should be
- -- investigated some time, since it should not be needed ???
-
- if Comes_From_Source (Old_Formal)
- and then
- Comes_From_Source (New_Formal)
- then
- Conformance_Error
- ("\null exclusion for& does not match", New_Formal);
+ if not Null_Exclusions_Match (Old_Formal, New_Formal) then
+ Conformance_Error
+ ("\null exclusion for& does not match", New_Formal);
- -- Mark error posted on the new formal to avoid duplicated
- -- complaint about types not matching.
+ -- Mark error posted on the new formal to avoid duplicated
+ -- complaint about types not matching.
- Set_Error_Posted (New_Formal);
- end if;
+ Set_Error_Posted (New_Formal);
end if;
end if;
@@ -5674,57 +5939,6 @@ package body Sem_Ch6 is
New_Formal_Base := Get_Instance_Of (New_Formal_Base);
end if;
- Access_Types_Match := Ada_Version >= Ada_2005
-
- -- Ensure that this rule is only applied when New_Id is a
- -- renaming of Old_Id.
-
- and then Nkind (Parent (Parent (New_Id))) =
- N_Subprogram_Renaming_Declaration
- and then Nkind (Name (Parent (Parent (New_Id)))) in N_Has_Entity
- and then Present (Entity (Name (Parent (Parent (New_Id)))))
- and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id
-
- -- Now handle the allowed access-type case
-
- and then Is_Access_Type (Old_Formal_Base)
- and then Is_Access_Type (New_Formal_Base)
-
- -- The type kinds must match. The only exception occurs with
- -- multiple generics of the form:
-
- -- generic generic
- -- type F is private; type A is private;
- -- type F_Ptr is access F; type A_Ptr is access A;
- -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr);
- -- package F_Pack is ... package A_Pack is
- -- package F_Inst is
- -- new F_Pack (A, A_Ptr, A_P);
-
- -- When checking for conformance between the parameters of A_P
- -- and F_P, the type kinds of F_Ptr and A_Ptr will not match
- -- because the compiler has transformed A_Ptr into a subtype of
- -- F_Ptr. We catch this case in the code below.
-
- and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base)
- or else
- (Is_Generic_Type (Old_Formal_Base)
- and then Is_Generic_Type (New_Formal_Base)
- and then Is_Internal (New_Formal_Base)
- and then Etype (Etype (New_Formal_Base)) =
- Old_Formal_Base))
- and then Directly_Designated_Type (Old_Formal_Base) =
- Directly_Designated_Type (New_Formal_Base)
- and then ((Is_Itype (Old_Formal_Base)
- and then (Can_Never_Be_Null (Old_Formal_Base)
- or else Is_Access_Constant
- (Old_Formal_Base)))
- or else
- (Is_Itype (New_Formal_Base)
- and then (Can_Never_Be_Null (New_Formal_Base)
- or else Is_Access_Constant
- (New_Formal_Base))));
-
-- Types must always match. In the visible part of an instance,
-- usual overloading rules for dispatching operations apply, and
-- we check base types (not the actual subtypes).
@@ -5737,7 +5951,6 @@ package body Sem_Ch6 is
T2 => Base_Type (Etype (New_Formal)),
Ctype => Ctype,
Get_Inst => Get_Inst)
- and then not Access_Types_Match
then
Conformance_Error ("\type of & does not match!", New_Formal);
return;
@@ -5748,7 +5961,6 @@ package body Sem_Ch6 is
T2 => New_Formal_Base,
Ctype => Ctype,
Get_Inst => Get_Inst)
- and then not Access_Types_Match
then
-- Don't give error message if old type is Any_Type. This test
-- avoids some cascaded errors, e.g. in case of a bad spec.
@@ -5780,7 +5992,7 @@ package body Sem_Ch6 is
if Ctype >= Mode_Conformant then
if Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal) then
- if not Ekind_In (New_Id, E_Function, E_Procedure)
+ if Ekind (New_Id) not in E_Function | E_Procedure
or else not Is_Primitive_Wrapper (New_Id)
then
Conformance_Error ("\mode of & does not match!", New_Formal);
@@ -5791,7 +6003,11 @@ package body Sem_Ch6 is
begin
if Is_Protected_Type (Corresponding_Concurrent_Type (T))
then
- Error_Msg_PT (New_Id, Ultimate_Alias (Old_Id));
+ Conforms := False;
+
+ if Errmsg then
+ Error_Msg_PT (New_Id, Ultimate_Alias (Old_Id));
+ end if;
else
Conformance_Error
("\mode of & does not match!", New_Formal);
@@ -5801,10 +6017,8 @@ package body Sem_Ch6 is
return;
- -- Part of mode conformance for access types is having the same
- -- constant modifier.
-
- elsif Access_Types_Match
+ elsif Is_Access_Type (Old_Formal_Base)
+ and then Is_Access_Type (New_Formal_Base)
and then Is_Access_Constant (Old_Formal_Base) /=
Is_Access_Constant (New_Formal_Base)
then
@@ -5826,8 +6040,8 @@ package body Sem_Ch6 is
-- (access formals in the bodies aren't marked Can_Never_Be_Null).
if Ada_Version >= Ada_2005
- and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type
- and then Ekind (Etype (New_Formal)) = E_Anonymous_Access_Type
+ and then Is_Anonymous_Access_Type (Etype (Old_Formal))
+ and then Is_Anonymous_Access_Type (Etype (New_Formal))
and then
((Can_Never_Be_Null (Etype (Old_Formal)) /=
Can_Never_Be_Null (Etype (New_Formal))
@@ -6345,6 +6559,56 @@ package body Sem_Ch6 is
end if;
end Check_Discriminant_Conformance;
+ -----------------------------------------
+ -- Check_Formal_Subprogram_Conformance --
+ -----------------------------------------
+
+ procedure Check_Formal_Subprogram_Conformance
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Err_Loc : Node_Id;
+ Errmsg : Boolean;
+ Conforms : out Boolean)
+ is
+ N : Node_Id;
+ begin
+ Conforms := True;
+
+ if Is_Formal_Subprogram (Old_Id)
+ or else Is_Formal_Subprogram (New_Id)
+ or else (Is_Subprogram (New_Id)
+ and then Present (Alias (New_Id))
+ and then Is_Formal_Subprogram (Alias (New_Id)))
+ then
+ if Present (Err_Loc) then
+ N := Err_Loc;
+ else
+ N := New_Id;
+ end if;
+
+ Conforms := False;
+
+ if Errmsg then
+ Error_Msg_Sloc := Sloc (Old_Id);
+ Error_Msg_N ("not subtype conformant with declaration#!", N);
+ Error_Msg_NE
+ ("\formal subprograms are not subtype conformant "
+ & "(RM 6.3.1 (17/3))", N, New_Id);
+ end if;
+ end if;
+ end Check_Formal_Subprogram_Conformance;
+
+ procedure Check_Formal_Subprogram_Conformance
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Err_Loc : Node_Id := Empty)
+ is
+ Ignore : Boolean;
+ begin
+ Check_Formal_Subprogram_Conformance
+ (New_Id, Old_Id, Err_Loc, True, Ignore);
+ end Check_Formal_Subprogram_Conformance;
+
----------------------------
-- Check_Fully_Conformant --
----------------------------
@@ -6497,11 +6761,11 @@ package body Sem_Ch6 is
Decl := Unit_Declaration_Node (Subp);
end if;
- if Nkind_In (Decl, N_Subprogram_Body,
- N_Subprogram_Body_Stub,
- N_Subprogram_Declaration,
- N_Abstract_Subprogram_Declaration,
- N_Subprogram_Renaming_Declaration)
+ if Nkind (Decl) in N_Subprogram_Body
+ | N_Subprogram_Body_Stub
+ | N_Subprogram_Declaration
+ | N_Abstract_Subprogram_Declaration
+ | N_Subprogram_Renaming_Declaration
then
Spec := Specification (Decl);
@@ -6512,6 +6776,19 @@ package body Sem_Ch6 is
return;
end if;
+ -- An overriding indication is illegal on a subprogram declared
+ -- in a protected body, where there is no operation to override.
+
+ if (Must_Override (Spec) or else Must_Not_Override (Spec))
+ and then Is_List_Member (Decl)
+ and then Present (Parent (List_Containing (Decl)))
+ and then Nkind (Parent (List_Containing (Decl))) = N_Protected_Body
+ then
+ Error_Msg_N
+ ("illegal overriding indication in protected body", Decl);
+ return;
+ end if;
+
-- The overriding operation is type conformant with the overridden one,
-- but the names of the formals are not required to match. If the names
-- appear permuted in the overriding operation, this is a possible
@@ -6584,9 +6861,9 @@ package body Sem_Ch6 is
if Present (Overridden_Subp)
and then (not Is_Hidden (Overridden_Subp)
or else
- (Nam_In (Chars (Overridden_Subp), Name_Initialize,
- Name_Adjust,
- Name_Finalize)
+ (Chars (Overridden_Subp) in Name_Initialize
+ | Name_Adjust
+ | Name_Finalize
and then Present (Alias (Overridden_Subp))
and then (not Is_Hidden (Alias (Overridden_Subp))
or else In_Instance)))
@@ -6888,12 +7165,10 @@ package body Sem_Ch6 is
-- Don't count exception junk
or else
- (Nkind_In (Last_Stm, N_Goto_Statement,
- N_Label,
- N_Object_Declaration)
+ (Nkind (Last_Stm) in
+ N_Goto_Statement | N_Label | N_Object_Declaration
and then Exception_Junk (Last_Stm))
- or else Nkind (Last_Stm) in N_Push_xxx_Label
- or else Nkind (Last_Stm) in N_Pop_xxx_Label
+ or else Nkind (Last_Stm) in N_Push_xxx_Label | N_Pop_xxx_Label
-- Inserted code, such as finalization calls, is irrelevant: we only
-- need to check original source.
@@ -7321,7 +7596,7 @@ package body Sem_Ch6 is
function Is_Valid_Formal (F : Entity_Id) return Boolean is
begin
return
- Ekind_In (F, E_In_Out_Parameter, E_Out_Parameter)
+ Ekind (F) in E_In_Out_Parameter | E_Out_Parameter
or else
(Nkind (Parameter_Type (Parent (F))) = N_Access_Definition
and then not Constant_Present (Parameter_Type (Parent (F))));
@@ -7398,10 +7673,10 @@ package body Sem_Ch6 is
-- rest of the parameters.
if not In_Scope then
- Prim_Param := Next (Prim_Param);
+ Next (Prim_Param);
end if;
- Iface_Param := Next (Iface_Param);
+ Next (Iface_Param);
while Present (Iface_Param) and then Present (Prim_Param) loop
Iface_Id := Defining_Identifier (Iface_Param);
Iface_Typ := Find_Parameter_Type (Iface_Param);
@@ -7558,7 +7833,7 @@ package body Sem_Ch6 is
-- Entries and procedures can override abstract or null interface
-- procedures.
- elsif Ekind_In (Def_Id, E_Entry, E_Procedure)
+ elsif Ekind (Def_Id) in E_Entry | E_Procedure
and then Ekind (Subp) = E_Procedure
and then Matches_Prefixed_View_Profile
(Parameter_Specifications (Parent (Def_Id)),
@@ -7578,7 +7853,7 @@ package body Sem_Ch6 is
-- override, the first parameter of the overridden routine
-- must be of mode "out", "in out", or access-to-variable.
- if Ekind_In (Candidate, E_Entry, E_Procedure)
+ if Ekind (Candidate) in E_Entry | E_Procedure
and then Is_Protected_Type (Typ)
and then not Is_Valid_Formal (Formal)
then
@@ -7984,11 +8259,11 @@ package body Sem_Ch6 is
-- or both could be access to protected subprograms.
Are_Anonymous_Access_To_Subprogram_Types :=
- Ekind_In (Type_1, E_Anonymous_Access_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type)
+ Ekind (Type_1) in E_Anonymous_Access_Subprogram_Type
+ | E_Anonymous_Access_Protected_Subprogram_Type
and then
- Ekind_In (Type_2, E_Anonymous_Access_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type);
+ Ekind (Type_2) in E_Anonymous_Access_Subprogram_Type
+ | E_Anonymous_Access_Protected_Subprogram_Type;
-- Test anonymous access type case. For this case, static subtype
-- matching is required for mode conformance (RM 6.3.1(15)). We check
@@ -8401,6 +8676,9 @@ package body Sem_Ch6 is
Add_Extra_Formal
(E, RTE (RE_Master_Id),
E, BIP_Formal_Suffix (BIP_Task_Master));
+
+ Set_Has_Master_Entity (E);
+
Discard :=
Add_Extra_Formal
(E, RTE (RE_Activation_Chain_Access),
@@ -8447,8 +8725,8 @@ package body Sem_Ch6 is
-- to this are inherited operations from a parent type in which
-- case the derived type acts as their parent.
- if Nkind_In (Subp_Decl, N_Function_Specification,
- N_Procedure_Specification)
+ if Nkind (Subp_Decl) in N_Function_Specification
+ | N_Procedure_Specification
then
Subp_Decl := Parent (Subp_Decl);
end if;
@@ -8662,7 +8940,7 @@ package body Sem_Ch6 is
-- Warn unless genuine overloading. Do not emit warning on
-- hiding predefined operators in Standard (these are either an
- -- (artifact of our implicit declarations, or simple noise) but
+ -- artifact of our implicit declarations, or simple noise) but
-- keep warning on a operator defined on a local subtype, because
-- of the real danger that different operators may be applied in
-- various parts of the program.
@@ -8974,8 +9252,8 @@ package body Sem_Ch6 is
-- conformant with it. That can occur in cases where an
-- actual type causes unrelated homographs in the instance.
- if Nkind_In (N, N_Subprogram_Body,
- N_Subprogram_Renaming_Declaration)
+ if Nkind (N) in N_Subprogram_Body
+ | N_Subprogram_Renaming_Declaration
and then Present (Homonym (E))
and then not Fully_Conformant (Designator, E)
then
@@ -9239,6 +9517,29 @@ package body Sem_Ch6 is
end if;
end FCO;
+ function User_Defined_Numeric_Literal_Mismatch return Boolean;
+ -- Usually literals with the same value like 12345 and 12_345
+ -- or 123.0 and 123.00 conform, but not if they are
+ -- user-defined literals.
+
+ -------------------------------------------
+ -- User_Defined_Numeric_Literal_Mismatch --
+ -------------------------------------------
+
+ function User_Defined_Numeric_Literal_Mismatch return Boolean is
+ E1_Is_User_Defined : constant Boolean :=
+ Nkind (Given_E1) not in N_Integer_Literal | N_Real_Literal;
+ E2_Is_User_Defined : constant Boolean :=
+ Nkind (Given_E2) not in N_Integer_Literal | N_Real_Literal;
+
+ begin
+ pragma Assert (E1_Is_User_Defined = E2_Is_User_Defined);
+
+ return E1_Is_User_Defined and then
+ not String_Equal (String_From_Numeric_Literal (E1),
+ String_From_Numeric_Literal (E2));
+ end User_Defined_Numeric_Literal_Mismatch;
+
-- Local variables
Result : Boolean;
@@ -9500,7 +9801,8 @@ package body Sem_Ch6 is
FCL (Expressions (E1), Expressions (E2));
when N_Integer_Literal =>
- return (Intval (E1) = Intval (E2));
+ return (Intval (E1) = Intval (E2))
+ and then not User_Defined_Numeric_Literal_Mismatch;
when N_Null =>
return True;
@@ -9586,7 +9888,8 @@ package body Sem_Ch6 is
FCE (High_Bound (E1), High_Bound (E2));
when N_Real_Literal =>
- return (Realval (E1) = Realval (E2));
+ return (Realval (E1) = Realval (E2))
+ and then not User_Defined_Numeric_Literal_Mismatch;
when N_Selected_Component =>
return
@@ -10403,10 +10706,9 @@ package body Sem_Ch6 is
H := Homonym (H);
exit when not Present (H) or else Scope (H) /= Scope (S);
- if Nkind_In
- (Parent (H),
- N_Private_Extension_Declaration,
- N_Private_Type_Declaration)
+ if Nkind (Parent (H)) in
+ N_Private_Extension_Declaration |
+ N_Private_Type_Declaration
and then Defining_Identifier (Parent (H)) = Partial_View
then
return True;
@@ -10461,8 +10763,9 @@ package body Sem_Ch6 is
("\move subprogram to the visible part"
& " (RM 3.9.3(10))", S);
- -- AI05-0073: extend this test to the case of a
- -- function with a controlling access result.
+ -- Ada 2012 (AI05-0073): Extend this check to the case
+ -- of a function whose result subtype is defined by an
+ -- access_definition designating specific tagged type.
elsif Ekind (Etype (S)) = E_Anonymous_Access_Type
and then Is_Tagged_Type (Designated_Type (Etype (S)))
@@ -11217,6 +11520,18 @@ package body Sem_Ch6 is
Inherit_Subprogram_Contract (E, S);
end if;
+ -- When a dispatching operation overrides an inherited
+ -- subprogram, it shall be subtype conformant with the
+ -- inherited subprogram (RM 3.9.2 (10.2)).
+
+ if Comes_From_Source (E)
+ and then Is_Dispatching_Operation (E)
+ and then Find_Dispatching_Type (S)
+ = Find_Dispatching_Type (E)
+ then
+ Check_Subtype_Conformant (E, S);
+ end if;
+
if Comes_From_Source (E) then
Check_Overriding_Indicator (E, S, Is_Primitive => False);
@@ -11531,14 +11846,6 @@ package body Sem_Ch6 is
Check_Ghost_Overriding (S, Overridden_Subp);
- -- Overloading is not allowed in SPARK, except for operators
-
- if Nkind (S) /= N_Defining_Operator_Symbol then
- Error_Msg_Sloc := Sloc (Homonym (S));
- Check_SPARK_05_Restriction
- ("overloading not allowed with entity#", S);
- end if;
-
-- If S is a derived operation for an untagged type then by
-- definition it's not a dispatching operation (even if the parent
-- operation was dispatching), so Check_Dispatching_Operation is not
@@ -11703,9 +12010,9 @@ package body Sem_Ch6 is
and then not Is_Generic_Type (Formal_Type)
and then not Is_Class_Wide_Type (Formal_Type)
then
- if not Nkind_In
- (Parent (T), N_Access_Function_Definition,
- N_Access_Procedure_Definition)
+ if Nkind (Parent (T)) not in
+ N_Access_Function_Definition |
+ N_Access_Procedure_Definition
then
Append_Elmt (Current_Scope,
Private_Dependents (Base_Type (Formal_Type)));
@@ -11722,8 +12029,8 @@ package body Sem_Ch6 is
end if;
end if;
- elsif not Nkind_In (Parent (T), N_Access_Function_Definition,
- N_Access_Procedure_Definition)
+ elsif Nkind (Parent (T)) not in N_Access_Function_Definition
+ | N_Access_Procedure_Definition
then
-- AI05-0151: Tagged incomplete types are allowed in all
-- formal parts. Untagged incomplete types are not allowed
@@ -11750,9 +12057,9 @@ package body Sem_Ch6 is
then
null;
- elsif Nkind_In (Context, N_Accept_Statement,
- N_Accept_Alternative,
- N_Entry_Body)
+ elsif Nkind (Context) in N_Accept_Statement
+ | N_Accept_Alternative
+ | N_Entry_Body
or else (Nkind (Context) = N_Subprogram_Body
and then Comes_From_Source (Context))
then
@@ -11870,9 +12177,6 @@ package body Sem_Ch6 is
Default := Expression (Param_Spec);
if Present (Default) then
- Check_SPARK_05_Restriction
- ("default expression is not allowed", Default);
-
if Out_Present (Param_Spec) then
Error_Msg_N
("default initialization only allowed for IN parameters",
@@ -11933,12 +12237,12 @@ package body Sem_Ch6 is
-- these are not standard Ada legality rules.
if SPARK_Mode = On then
- if Ekind_In (Scope (Formal), E_Function, E_Generic_Function) then
+ if Ekind (Scope (Formal)) in E_Function | E_Generic_Function then
-- A function cannot have a parameter of mode IN OUT or OUT
-- (SPARK RM 6.1).
- if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
+ if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then
Error_Msg_N
("function cannot have parameter of mode `OUT` or "
& "`IN OUT`", Formal);
@@ -11946,7 +12250,7 @@ package body Sem_Ch6 is
-- A procedure cannot have an effectively volatile formal
-- parameter of mode IN because it behaves as a constant
- -- (SPARK RM 7.1.3(6)). -- ??? maybe 7.1.3(4)
+ -- (SPARK RM 7.1.3(4)).
elsif Ekind (Scope (Formal)) = E_Procedure
and then Ekind (Formal) = E_In_Parameter
@@ -12255,13 +12559,13 @@ package body Sem_Ch6 is
-- point of the call.
if Out_Present (Spec) then
- if Ekind_In (Id, E_Entry, E_Entry_Family)
+ if Is_Entry (Id)
or else Is_Subprogram_Or_Generic_Subprogram (Id)
then
Set_Has_Out_Or_In_Out_Parameter (Id, True);
end if;
- if Ekind_In (Id, E_Function, E_Generic_Function) then
+ if Ekind (Id) in E_Function | E_Generic_Function then
-- [IN] OUT parameters allowed for functions in Ada 2012
@@ -12443,12 +12747,12 @@ package body Sem_Ch6 is
-- Verify that user-defined operators have proper number of arguments
-- First case of operators which can only be unary
- if Nam_In (Id, Name_Op_Not, Name_Op_Abs) then
+ if Id in Name_Op_Not | Name_Op_Abs then
N_OK := (N = 1);
-- Case of operators which can be unary or binary
- elsif Nam_In (Id, Name_Op_Add, Name_Op_Subtract) then
+ elsif Id in Name_Op_Add | Name_Op_Subtract then
N_OK := (N in 1 .. 2);
-- All other operators can only be binary
diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads
index f069947..81b4821 100644
--- a/gcc/ada/sem_ch6.ads
+++ b/gcc/ada/sem_ch6.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -69,6 +69,16 @@ package Sem_Ch6 is
-- the source location of the partial view, which may be different than
-- Prev in the case of private types.
+ procedure Check_Formal_Subprogram_Conformance
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Err_Loc : Node_Id := Empty);
+ -- Check RM 6.3.1(17/3): the profile of a generic formal subprogram is not
+ -- subtype conformant with any other profile and post an error message if
+ -- either New_Id or Old_Id denotes a formal subprogram, with the flag being
+ -- placed on the Err_Loc node if it is specified, and on New_Id if not. See
+ -- also spec of Check_Fully_Conformant below for New_Id and Old_Id usage.
+
procedure Check_Fully_Conformant
(New_Id : Entity_Id;
Old_Id : Entity_Id;
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index 6d9a1db..3ff2001 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -47,7 +47,6 @@ with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
with Output; use Output;
-with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
@@ -463,29 +462,44 @@ package body Sem_Ch7 is
-- Exceptions, objects and renamings do not need to be public
-- if they are not followed by a construct which can reference
- -- and export them. Likewise for subprograms but we work harder
+ -- and export them.
+
+ elsif Nkind (Decl) in N_Exception_Declaration
+ | N_Object_Declaration
+ | N_Object_Renaming_Declaration
+ then
+ Decl_Id := Defining_Entity (Decl);
+
+ if not In_Nested_Instance
+ and then not Is_Imported (Decl_Id)
+ and then not Is_Exported (Decl_Id)
+ and then No (Interface_Name (Decl_Id))
+ and then not Has_Referencer_Of_Non_Subprograms
+ then
+ Set_Is_Public (Decl_Id, False);
+ end if;
+
+ -- Likewise for subprograms and renamings, but we work harder
-- for them to see whether they are referenced on an individual
-- basis by looking into the table of referenced subprograms.
- -- But we cannot say anything for entities declared in nested
- -- instances because instantiations are not done yet so the
- -- bodies are not visible and could contain references to them.
- elsif Nkind_In (Decl, N_Exception_Declaration,
- N_Object_Declaration,
- N_Object_Renaming_Declaration,
- N_Subprogram_Declaration,
- N_Subprogram_Renaming_Declaration)
+
+ elsif Nkind (Decl) in N_Subprogram_Declaration
+ | N_Subprogram_Renaming_Declaration
then
Decl_Id := Defining_Entity (Decl);
- if not In_Nested_Instance
+ -- We cannot say anything for subprograms declared in nested
+ -- instances because instantiations are not done yet so the
+ -- bodies are not visible and could contain references to
+ -- them, except if we still have no subprograms at all which
+ -- are referenced by an inlined body.
+
+ if (not In_Nested_Instance
+ or else not Subprogram_Table.Get_First)
and then not Is_Imported (Decl_Id)
and then not Is_Exported (Decl_Id)
and then No (Interface_Name (Decl_Id))
- and then
- ((Nkind (Decl) /= N_Subprogram_Declaration
- and then not Has_Referencer_Of_Non_Subprograms)
- or else (Nkind (Decl) = N_Subprogram_Declaration
- and then not Subprogram_Table.Get (Decl_Id)))
+ and then not Subprogram_Table.Get (Decl_Id)
then
Set_Is_Public (Decl_Id, False);
end if;
@@ -956,6 +970,15 @@ package body Sem_Ch7 is
("\value Off was set for SPARK_Mode on & #", N, Spec_Id);
end if;
+ -- SPARK_Mode Off could complete no SPARK_Mode in a generic, either
+ -- as specified in source code, or because SPARK_Mode On is ignored
+ -- in an instance where the context is SPARK_Mode Off/Auto.
+
+ elsif Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Body_Id)) = Off
+ and then (Is_Generic_Unit (Spec_Id) or else In_Instance)
+ then
+ null;
+
else
Error_Msg_Sloc := Sloc (SPARK_Pragma (Body_Id));
Error_Msg_N ("incorrect application of SPARK_Mode#", N);
@@ -1073,9 +1096,13 @@ package body Sem_Ch7 is
-- unit, especially subprograms.
-- This is done only for top-level library packages or child units as
- -- the algorithm does a top-down traversal of the package body.
+ -- the algorithm does a top-down traversal of the package body. This is
+ -- also done for instances because instantiations are still pending by
+ -- the time the enclosing package body is analyzed.
- if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id))
+ if (Scope (Spec_Id) = Standard_Standard
+ or else Is_Child_Unit (Spec_Id)
+ or else Is_Generic_Instance (Spec_Id))
and then not Is_Generic_Unit (Spec_Id)
then
Hide_Public_Entities (Declarations (N));
@@ -1262,10 +1289,6 @@ package body Sem_Ch7 is
-- private_with_clauses, and remove them at the end of the nested
-- package.
- procedure Check_One_Tagged_Type_Or_Extension_At_Most;
- -- Issue an error in SPARK mode if a package specification contains
- -- more than one tagged type or type extension.
-
procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id);
-- Clears constant indications (Never_Set_In_Source, Constant_Value, and
-- Is_True_Constant) on all variables that are entities of Id, and on
@@ -1292,58 +1315,6 @@ package body Sem_Ch7 is
-- private part rather than being done in Sem_Ch12.Install_Parent
-- (which is where the parents' visible declarations are installed).
- ------------------------------------------------
- -- Check_One_Tagged_Type_Or_Extension_At_Most --
- ------------------------------------------------
-
- procedure Check_One_Tagged_Type_Or_Extension_At_Most is
- Previous : Node_Id;
-
- procedure Check_Decls (Decls : List_Id);
- -- Check that either Previous is Empty and Decls does not contain
- -- more than one tagged type or type extension, or Previous is
- -- already set and Decls contains no tagged type or type extension.
-
- -----------------
- -- Check_Decls --
- -----------------
-
- procedure Check_Decls (Decls : List_Id) is
- Decl : Node_Id;
-
- begin
- Decl := First (Decls);
- while Present (Decl) loop
- if Nkind (Decl) = N_Full_Type_Declaration
- and then Is_Tagged_Type (Defining_Identifier (Decl))
- then
- if No (Previous) then
- Previous := Decl;
-
- else
- Error_Msg_Sloc := Sloc (Previous);
- Check_SPARK_05_Restriction
- ("at most one tagged type or type extension allowed",
- "\\ previous declaration#",
- Decl);
- end if;
- end if;
-
- Next (Decl);
- end loop;
- end Check_Decls;
-
- -- Start of processing for Check_One_Tagged_Type_Or_Extension_At_Most
-
- begin
- Previous := Empty;
- Check_Decls (Vis_Decls);
-
- if Present (Priv_Decls) then
- Check_Decls (Priv_Decls);
- end if;
- end Check_One_Tagged_Type_Or_Extension_At_Most;
-
---------------------
-- Clear_Constants --
---------------------
@@ -1399,8 +1370,8 @@ package body Sem_Ch7 is
then
Generate_Reference (Id, Scope (Id), 'k', False);
- elsif not Nkind_In (Unit (Cunit (Main_Unit)), N_Subprogram_Body,
- N_Subunit)
+ elsif Nkind (Unit (Cunit (Main_Unit))) not in
+ N_Subprogram_Body | N_Subunit
then
-- If current unit is an ancestor of main unit, generate a
-- reference to its own parent.
@@ -1466,8 +1437,8 @@ package body Sem_Ch7 is
-- prevents cascaded errors when routines defined only for type
-- entities are called with non-type entities.
- if Nkind_In (Decl, N_Incomplete_Type_Declaration,
- N_Private_Type_Declaration)
+ if Nkind (Decl) in N_Incomplete_Type_Declaration
+ | N_Private_Type_Declaration
and then Is_Type (Defining_Identifier (Decl))
and then Has_Discriminants (Defining_Identifier (Decl))
and then Present (Full_View (Defining_Identifier (Decl)))
@@ -1501,8 +1472,8 @@ package body Sem_Ch7 is
while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop
Inst_Node := Get_Unit_Instantiation_Node (Inst_Par);
- if Nkind_In (Inst_Node, N_Package_Instantiation,
- N_Formal_Package_Declaration)
+ if Nkind (Inst_Node) in
+ N_Package_Instantiation | N_Formal_Package_Declaration
and then Nkind (Name (Inst_Node)) = N_Expanded_Name
then
Inst_Par := Entity (Prefix (Name (Inst_Node)));
@@ -1880,11 +1851,6 @@ package body Sem_Ch7 is
Clear_Constants (Id, First_Private_Entity (Id));
end if;
- -- Issue an error in SPARK mode if a package specification contains
- -- more than one tagged type or type extension.
-
- Check_One_Tagged_Type_Or_Extension_At_Most;
-
-- Output relevant information as to why the package requires a body.
-- Do not consider generated packages as this exposes internal symbols
-- and leads to confusing messages.
@@ -2428,7 +2394,7 @@ package body Sem_Ch7 is
-- defined in the associated package, subject to at least one Part_Of
-- constituent.
- if Ekind_In (P, E_Generic_Package, E_Package) then
+ if Is_Package_Or_Generic_Package (P) then
declare
States : constant Elist_Id := Abstract_States (P);
State_Elmt : Elmt_Id;
@@ -2674,7 +2640,7 @@ package body Sem_Ch7 is
-- implicit completion at some point.
elsif (Is_Overloadable (Id)
- and then not Ekind_In (Id, E_Enumeration_Literal, E_Operator)
+ and then Ekind (Id) not in E_Enumeration_Literal | E_Operator
and then not Is_Abstract_Subprogram (Id)
and then not Has_Completion (Id)
and then Comes_From_Source (Parent (Id)))
@@ -2691,7 +2657,7 @@ package body Sem_Ch7 is
and then not Is_Generic_Type (Id))
or else
- (Ekind_In (Id, E_Task_Type, E_Protected_Type)
+ (Ekind (Id) in E_Task_Type | E_Protected_Type
and then not Has_Completion (Id))
or else
@@ -2792,34 +2758,20 @@ package body Sem_Ch7 is
Set_Freeze_Node (Priv, Freeze_Node (Full));
-- Propagate Default_Initial_Condition-related attributes from the
- -- base type of the full view to the full view and vice versa. This
- -- may seem strange, but is necessary depending on which type
- -- triggered the generation of the DIC procedure body. As a result,
- -- both the full view and its base type carry the same DIC-related
- -- information.
-
- Propagate_DIC_Attributes (Full, From_Typ => Full_Base);
- Propagate_DIC_Attributes (Full_Base, From_Typ => Full);
-
- -- Propagate Default_Initial_Condition-related attributes from the
-- full view to the private view.
Propagate_DIC_Attributes (Priv, From_Typ => Full);
- -- Propagate invariant-related attributes from the base type of the
- -- full view to the full view and vice versa. This may seem strange,
- -- but is necessary depending on which type triggered the generation
- -- of the invariant procedure body. As a result, both the full view
- -- and its base type carry the same invariant-related information.
-
- Propagate_Invariant_Attributes (Full, From_Typ => Full_Base);
- Propagate_Invariant_Attributes (Full_Base, From_Typ => Full);
-
-- Propagate invariant-related attributes from the full view to the
-- private view.
Propagate_Invariant_Attributes (Priv, From_Typ => Full);
+ -- Propagate predicate-related attributes from the full view to the
+ -- private view.
+
+ Propagate_Predicate_Attributes (Priv, From_Typ => Full);
+
if Is_Tagged_Type (Priv)
and then Is_Tagged_Type (Full)
and then not Error_Posted (Full)
@@ -3007,7 +2959,7 @@ package body Sem_Ch7 is
Check_Conventions (Id);
end if;
- if Ekind_In (Id, E_Private_Type, E_Limited_Private_Type)
+ if Ekind (Id) in E_Private_Type | E_Limited_Private_Type
and then No (Full_View (Id))
and then not Is_Generic_Type (Id)
and then not Is_Derived_Type (Id)
@@ -3322,7 +3274,7 @@ package body Sem_Ch7 is
-- performed if the caller requests this behavior.
if Do_Abstract_States
- and then Ekind_In (Pack_Id, E_Generic_Package, E_Package)
+ and then Is_Package_Or_Generic_Package (Pack_Id)
and then Has_Non_Null_Abstract_State (Pack_Id)
and then Requires_Body
then
@@ -3380,7 +3332,7 @@ package body Sem_Ch7 is
-- provided). If Ignore_Abstract_State is True, we don't do this check
-- (so we can use Unit_Requires_Body to check for some other reason).
- elsif Ekind_In (Pack_Id, E_Generic_Package, E_Package)
+ elsif Is_Package_Or_Generic_Package (Pack_Id)
and then Present (Abstract_States (Pack_Id))
and then not Is_Null_State
(Node (First_Elmt (Abstract_States (Pack_Id))))
diff --git a/gcc/ada/sem_ch7.ads b/gcc/ada/sem_ch7.ads
index 5347a31..f42c0bd 100644
--- a/gcc/ada/sem_ch7.ads
+++ b/gcc/ada/sem_ch7.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index f083f7c..3c10a96 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -501,6 +501,10 @@ package body Sem_Ch8 is
-- Ada 2005 (AI-262): Determines if the current compilation unit has a
-- private with on E.
+ function Has_Components (Typ : Entity_Id) return Boolean;
+ -- Determine if given type has components, i.e. is either a record type or
+ -- type or a type that has discriminants.
+
function Has_Implicit_Operator (N : Node_Id) return Boolean;
-- N is an expanded name whose selector is an operator name (e.g. P."+").
-- declarative part contains an implicit declaration of an operator if it
@@ -515,14 +519,6 @@ package body Sem_Ch8 is
-- specification are discarded and replaced with those of the renamed
-- subprogram, which are then used to recheck the default values.
- function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean;
- -- True if it is of a task type, a protected type, or else an access to one
- -- of these types.
-
- function Is_Appropriate_For_Record (T : Entity_Id) return Boolean;
- -- Prefix is appropriate for record if it is of a record type, or an access
- -- to such.
-
function Most_Descendant_Use_Clause
(Clause1 : Entity_Id;
Clause2 : Entity_Id) return Entity_Id;
@@ -568,8 +564,6 @@ package body Sem_Ch8 is
Nam : constant Node_Id := Name (N);
begin
- Check_SPARK_05_Restriction ("exception renaming is not allowed", N);
-
Enter_Name (Id);
Analyze (Nam);
@@ -682,8 +676,6 @@ package body Sem_Ch8 is
return;
end if;
- Check_SPARK_05_Restriction ("generic renaming is not allowed", N);
-
Generate_Definition (New_P);
if Current_Scope /= Standard_Standard then
@@ -737,7 +729,7 @@ package body Sem_Ch8 is
-- For subprograms, propagate the Intrinsic flag, to allow, e.g.
-- renamings and subsequent instantiations of Unchecked_Conversion.
- if Ekind_In (Old_P, E_Generic_Function, E_Generic_Procedure) then
+ if Is_Generic_Subprogram (Old_P) then
Set_Is_Intrinsic_Subprogram
(New_P, Is_Intrinsic_Subprogram (Old_P));
end if;
@@ -759,12 +751,13 @@ package body Sem_Ch8 is
-----------------------------
procedure Analyze_Object_Renaming (N : Node_Id) is
- Id : constant Entity_Id := Defining_Identifier (N);
- Loc : constant Source_Ptr := Sloc (N);
- Nam : constant Node_Id := Name (N);
- Dec : Node_Id;
- T : Entity_Id;
- T2 : Entity_Id;
+ Id : constant Entity_Id := Defining_Identifier (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Nam : constant Node_Id := Name (N);
+ Is_Object_Ref : Boolean;
+ Dec : Node_Id;
+ T : Entity_Id;
+ T2 : Entity_Id;
procedure Check_Constrained_Object;
-- If the nominal type is unconstrained but the renamed object is
@@ -787,7 +780,7 @@ package body Sem_Ch8 is
Subt : Entity_Id;
begin
- if Nkind_In (Nam, N_Function_Call, N_Explicit_Dereference)
+ if Nkind (Nam) in N_Function_Call | N_Explicit_Dereference
and then Is_Composite_Type (Typ)
and then not Is_Constrained (Typ)
and then not Has_Unknown_Discriminants (Typ)
@@ -795,7 +788,7 @@ package body Sem_Ch8 is
then
-- If Actual_Subtype is already set, nothing to do
- if Ekind_In (Id, E_Variable, E_Constant)
+ if Ekind (Id) in E_Variable | E_Constant
and then Present (Actual_Subtype (Id))
then
null;
@@ -847,18 +840,23 @@ package body Sem_Ch8 is
begin
Obj_Nam := Nod;
while Present (Obj_Nam) loop
- if Nkind_In (Obj_Nam, N_Attribute_Reference,
- N_Explicit_Dereference,
- N_Indexed_Component,
- N_Slice)
- then
- Obj_Nam := Prefix (Obj_Nam);
+ case Nkind (Obj_Nam) is
+ when N_Attribute_Reference
+ | N_Explicit_Dereference
+ | N_Indexed_Component
+ | N_Slice
+ =>
+ Obj_Nam := Prefix (Obj_Nam);
- elsif Nkind (Obj_Nam) = N_Selected_Component then
- Obj_Nam := Selector_Name (Obj_Nam);
- else
- exit;
- end if;
+ when N_Selected_Component =>
+ Obj_Nam := Selector_Name (Obj_Nam);
+
+ when N_Qualified_Expression | N_Type_Conversion =>
+ Obj_Nam := Expression (Obj_Nam);
+
+ when others =>
+ exit;
+ end case;
end loop;
return Obj_Nam;
@@ -871,8 +869,6 @@ package body Sem_Ch8 is
return;
end if;
- Check_SPARK_05_Restriction ("object renaming is not allowed", N);
-
Set_Is_Pure (Id, Is_Pure (Current_Scope));
Enter_Name (Id);
@@ -899,17 +895,116 @@ package body Sem_Ch8 is
T := Defining_Identifier (Dec);
Set_Etype (Nam, T);
end if;
-
- -- Complete analysis of the subtype mark in any case, for ASIS use
-
+ elsif Present (Subtype_Mark (N))
+ or else not Present (Access_Definition (N))
+ then
if Present (Subtype_Mark (N)) then
Find_Type (Subtype_Mark (N));
- end if;
+ T := Entity (Subtype_Mark (N));
+ Analyze (Nam);
- elsif Present (Subtype_Mark (N)) then
- Find_Type (Subtype_Mark (N));
- T := Entity (Subtype_Mark (N));
- Analyze (Nam);
+ -- AI12-0275: Case of object renaming without a subtype_mark
+
+ else
+ Analyze (Nam);
+
+ -- Normal case of no overloading in object name
+
+ if not Is_Overloaded (Nam) then
+
+ -- Catch error cases (such as attempting to rename a procedure
+ -- or package) using the shorthand form.
+
+ if No (Etype (Nam))
+ or else Etype (Nam) = Standard_Void_Type
+ then
+ Error_Msg_N
+ ("object name or value expected in renaming", Nam);
+
+ Set_Ekind (Id, E_Variable);
+ Set_Etype (Id, Any_Type);
+
+ return;
+
+ else
+ T := Etype (Nam);
+ end if;
+
+ -- Case of overloaded name, which will be illegal if there's more
+ -- than one acceptable interpretation (such as overloaded function
+ -- calls).
+
+ else
+ declare
+ I : Interp_Index;
+ I1 : Interp_Index;
+ It : Interp;
+ It1 : Interp;
+ Nam1 : Entity_Id;
+
+ begin
+ -- More than one candidate interpretation is available
+
+ -- Remove procedure calls, which syntactically cannot appear
+ -- in this context, but which cannot be removed by type
+ -- checking, because the context does not impose a type.
+
+ Get_First_Interp (Nam, I, It);
+ while Present (It.Typ) loop
+ if It.Typ = Standard_Void_Type then
+ Remove_Interp (I);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ Get_First_Interp (Nam, I, It);
+ I1 := I;
+ It1 := It;
+
+ -- If there's no type present, we have an error case (such
+ -- as overloaded procedures named in the object renaming).
+
+ if No (It.Typ) then
+ Error_Msg_N
+ ("object name or value expected in renaming", Nam);
+
+ Set_Ekind (Id, E_Variable);
+ Set_Etype (Id, Any_Type);
+
+ return;
+ end if;
+
+ Get_Next_Interp (I, It);
+
+ if Present (It.Typ) then
+ Nam1 := It1.Nam;
+ It1 := Disambiguate (Nam, I1, I, Any_Type);
+
+ if It1 = No_Interp then
+ Error_Msg_N ("ambiguous name in object renaming", Nam);
+
+ Error_Msg_Sloc := Sloc (It.Nam);
+ Error_Msg_N ("\\possible interpretation#!", Nam);
+
+ Error_Msg_Sloc := Sloc (Nam1);
+ Error_Msg_N ("\\possible interpretation#!", Nam);
+
+ return;
+ end if;
+ end if;
+
+ Set_Etype (Nam, It1.Typ);
+ T := It1.Typ;
+ end;
+ end if;
+
+ if Etype (Nam) = Standard_Exception_Type then
+ Error_Msg_N
+ ("exception requires a subtype mark in renaming", Nam);
+ return;
+ end if;
+ end if;
-- The object renaming declaration may become Ghost if it renames a
-- Ghost entity.
@@ -918,18 +1013,6 @@ package body Sem_Ch8 is
Mark_Ghost_Renaming (N, Entity (Nam));
end if;
- -- Reject renamings of conversions unless the type is tagged, or
- -- the conversion is implicit (which can occur for cases of anonymous
- -- access types in Ada 2012).
-
- if Nkind (Nam) = N_Type_Conversion
- and then Comes_From_Source (Nam)
- and then not Is_Tagged_Type (T)
- then
- Error_Msg_N
- ("renaming of conversion only allowed for tagged types", Nam);
- end if;
-
Resolve (Nam, T);
-- If the renamed object is a function call of a limited type,
@@ -965,8 +1048,8 @@ package body Sem_Ch8 is
if Nkind (Nam) = N_Type_Conversion
and then not Comes_From_Source (Nam)
- and then Ekind (Etype (Expression (Nam))) = E_Anonymous_Access_Type
- and then Ekind (T) /= E_Anonymous_Access_Type
+ and then Is_Anonymous_Access_Type (Etype (Expression (Nam)))
+ and then not Is_Anonymous_Access_Type (T)
then
Wrong_Type (Expression (Nam), T); -- Should we give better error???
end if;
@@ -1170,15 +1253,7 @@ package body Sem_Ch8 is
return;
end if;
- -- Ada 2005 (AI-327)
-
- if Ada_Version >= Ada_2005
- and then Nkind (Nam) = N_Attribute_Reference
- and then Attribute_Name (Nam) = Name_Priority
- then
- null;
-
- elsif Ada_Version >= Ada_2005 and then Nkind (Nam) in N_Has_Entity then
+ if Ada_Version >= Ada_2005 and then Nkind (Nam) in N_Has_Entity then
declare
Nam_Ent : constant Entity_Id := Entity (Get_Object_Name (Nam));
Nam_Decl : constant Node_Id := Declaration_Node (Nam_Ent);
@@ -1199,7 +1274,7 @@ package body Sem_Ch8 is
then
if not Can_Never_Be_Null (Etype (Nam_Ent)) then
Error_Msg_N
- ("renamed formal does not exclude `NULL` "
+ ("object does not exclude `NULL` "
& "(RM 8.5.1(4.6/2))", N);
elsif In_Package_Body (Scope (Id)) then
@@ -1213,7 +1288,7 @@ package body Sem_Ch8 is
elsif not Can_Never_Be_Null (Etype (Nam_Ent)) then
Error_Msg_N
- ("renamed object does not exclude `NULL` "
+ ("object does not exclude `NULL` "
& "(RM 8.5.1(4.6/2))", N);
-- An instance is illegal if it contains a renaming that
@@ -1230,8 +1305,7 @@ package body Sem_Ch8 is
N_Raise_Constraint_Error
then
Error_Msg_N
- ("renamed actual does not exclude `NULL` "
- & "(RM 8.5.1(4.6/2))", N);
+ ("actual does not exclude `NULL` (RM 8.5.1(4.6/2))", N);
-- Finally, if there is a null exclusion, the subtype mark
-- must not be null-excluding.
@@ -1249,8 +1323,7 @@ package body Sem_Ch8 is
and then not Can_Never_Be_Null (Etype (Nam_Ent))
then
Error_Msg_N
- ("renamed object does not exclude `NULL` "
- & "(RM 8.5.1(4.6/2))", N);
+ ("object does not exclude `NULL` (RM 8.5.1(4.6/2))", N);
elsif Has_Null_Exclusion (N)
and then No (Access_Definition (N))
@@ -1277,13 +1350,33 @@ package body Sem_Ch8 is
Init_Object_Size_Align (Id);
+ -- If N comes from source then check that the original node is an
+ -- object reference since there may have been several rewritting and
+ -- folding. Do not do this for N_Function_Call or N_Explicit_Dereference
+ -- which might correspond to rewrites of e.g. N_Selected_Component
+ -- (for example Object.Method rewriting).
+ -- If N does not come from source then assume the tree is properly
+ -- formed and accept any object reference. In such cases we do support
+ -- more cases of renamings anyway, so the actual check on which renaming
+ -- is valid is better left to the code generator as a last sanity
+ -- check.
+
+ if Comes_From_Source (N) then
+ if Nkind (Nam) in N_Function_Call | N_Explicit_Dereference then
+ Is_Object_Ref := Is_Object_Reference (Nam);
+ else
+ Is_Object_Ref := Is_Object_Reference (Original_Node (Nam));
+ end if;
+ else
+ Is_Object_Ref := True;
+ end if;
+
if T = Any_Type or else Etype (Nam) = Any_Type then
return;
- -- Verify that the renamed entity is an object or a function call. It
- -- may have been rewritten in several ways.
+ -- Verify that the renamed entity is an object or function call
- elsif Is_Object_Reference (Nam) then
+ elsif Is_Object_Ref then
if Comes_From_Source (N) then
if Is_Dependent_Component_Of_Mutable_Object (Nam) then
Error_Msg_N
@@ -1302,51 +1395,28 @@ package body Sem_Ch8 is
end if;
end if;
- -- A static function call may have been folded into a literal
+ -- Weird but legal, equivalent to renaming a function call. Illegal
+ -- if the literal is the result of constant-folding an attribute
+ -- reference that is not a function.
- elsif Nkind (Original_Node (Nam)) = N_Function_Call
-
- -- When expansion is disabled, attribute reference is not rewritten
- -- as function call. Otherwise it may be rewritten as a conversion,
- -- so check original node.
-
- or else (Nkind (Original_Node (Nam)) = N_Attribute_Reference
- and then Is_Function_Attribute_Name
- (Attribute_Name (Original_Node (Nam))))
-
- -- Weird but legal, equivalent to renaming a function call. Illegal
- -- if the literal is the result of constant-folding an attribute
- -- reference that is not a function.
-
- or else (Is_Entity_Name (Nam)
- and then Ekind (Entity (Nam)) = E_Enumeration_Literal
- and then
- Nkind (Original_Node (Nam)) /= N_Attribute_Reference)
-
- or else (Nkind (Nam) = N_Type_Conversion
- and then Is_Tagged_Type (Entity (Subtype_Mark (Nam))))
+ elsif Is_Entity_Name (Nam)
+ and then Ekind (Entity (Nam)) = E_Enumeration_Literal
+ and then Nkind (Original_Node (Nam)) /= N_Attribute_Reference
then
null;
- elsif Nkind (Nam) = N_Type_Conversion then
- Error_Msg_N
- ("renaming of conversion only allowed for tagged types", Nam);
+ -- A named number can only be renamed without a subtype mark
- -- Ada 2005 (AI-327)
-
- elsif Ada_Version >= Ada_2005
- and then Nkind (Nam) = N_Attribute_Reference
- and then Attribute_Name (Nam) = Name_Priority
+ elsif Nkind (Nam) in N_Real_Literal | N_Integer_Literal
+ and then Present (Subtype_Mark (N))
+ and then Present (Original_Entity (Nam))
then
- null;
+ Error_Msg_N ("incompatible types in renaming", Nam);
- -- Allow internally generated x'Ref resulting in N_Reference node
-
- elsif Nkind (Nam) = N_Reference then
- null;
+ -- AI12-0383: Names that denote values can be renamed
- else
- Error_Msg_N ("expect object name in renaming", Nam);
+ elsif Ada_Version < Ada_2020 then
+ Error_Msg_N ("value in renaming requires -gnat2020", Nam);
end if;
Set_Etype (Id, T2);
@@ -1681,6 +1751,9 @@ package body Sem_Ch8 is
-- The prefix can be an arbitrary expression that yields a task or
-- protected object, so it must be resolved.
+ if Is_Access_Type (Etype (Prefix (Nam))) then
+ Insert_Explicit_Dereference (Prefix (Nam));
+ end if;
Resolve (Prefix (Nam), Scope (Old_S));
end if;
@@ -1764,6 +1837,7 @@ package body Sem_Ch8 is
Is_Body : Boolean)
is
Old_S : Entity_Id;
+ Nam : Entity_Id;
function Conforms
(Subp : Entity_Id;
@@ -1840,7 +1914,7 @@ package body Sem_Ch8 is
end if;
if Old_S = Any_Id then
- Error_Msg_N (" no subprogram or entry matches specification", N);
+ Error_Msg_N ("no subprogram or entry matches specification", N);
else
if Is_Body then
@@ -1858,6 +1932,21 @@ package body Sem_Ch8 is
Error_Msg_N ("mode conformance error in renaming", N);
end if;
+ -- AI12-0204: The prefix of a prefixed view that is renamed or
+ -- passed as a formal subprogram must be renamable as an object.
+
+ Nam := Prefix (Name (N));
+
+ if Is_Object_Reference (Nam) then
+ if Is_Dependent_Component_Of_Mutable_Object (Nam) then
+ Error_Msg_N
+ ("illegal renaming of discriminant-dependent component",
+ Nam);
+ end if;
+ else
+ Error_Msg_N ("expect object name in renaming", Nam);
+ end if;
+
-- Enforce the rule given in (RM 6.3.1 (10.1/2)): a prefixed
-- view of a subprogram is intrinsic, because the compiler has
-- to generate a wrapper for any call to it. If the name in a
@@ -1934,15 +2023,14 @@ package body Sem_Ch8 is
-- Ada 2005 (AI-423): Given renaming Ren of subprogram Sub, check the
-- following AI rules:
--
- -- If Ren is a renaming of a formal subprogram and one of its
- -- parameters has a null exclusion, then the corresponding formal
- -- in Sub must also have one. Otherwise the subtype of the Sub's
- -- formal parameter must exclude null.
+ -- If Ren denotes a generic formal object of a generic unit G, and the
+ -- renaming (or instantiation containing the actual) occurs within the
+ -- body of G or within the body of a generic unit declared within the
+ -- declarative region of G, then the corresponding parameter of G
+ -- shall have a null_exclusion; Otherwise the subtype of the Sub's
+ -- formal parameter shall exclude null.
--
- -- If Ren is a renaming of a formal function and its return
- -- profile has a null exclusion, then Sub's return profile must
- -- have one. Otherwise the subtype of Sub's return profile must
- -- exclude null.
+ -- Similarly for its return profile.
procedure Check_SPARK_Primitive_Operation (Subp_Id : Entity_Id);
-- Ensure that a SPARK renaming denoted by its entity Subp_Id does not
@@ -2034,7 +2122,7 @@ package body Sem_Ch8 is
-- Generate:
-- return Subp_Id (Actuals);
- if Ekind_In (Subp_Id, E_Function, E_Operator) then
+ if Ekind (Subp_Id) in E_Function | E_Operator then
return
Make_Simple_Return_Statement (Loc,
Expression =>
@@ -2066,7 +2154,7 @@ package body Sem_Ch8 is
Formal : Node_Id;
begin
- pragma Assert (Ekind_In (Subp_Id, E_Function, E_Operator));
+ pragma Assert (Ekind (Subp_Id) in E_Function | E_Operator);
-- Build the actual parameters of the call
@@ -2433,7 +2521,7 @@ package body Sem_Ch8 is
-- dispatching call to the wrapped function is known during proof.
if GNATprove_Mode
- and then Ekind_In (Ren_Id, E_Function, E_Operator)
+ and then Ekind (Ren_Id) in E_Function | E_Operator
then
New_Spec := Build_Spec (Ren_Id);
Body_Decl :=
@@ -2509,20 +2597,38 @@ package body Sem_Ch8 is
Ren_Formal : Entity_Id;
Sub_Formal : Entity_Id;
+ function Null_Exclusion_Mismatch
+ (Renaming : Entity_Id; Renamed : Entity_Id) return Boolean;
+ -- Return True if there is a null exclusion mismatch between
+ -- Renaming and Renamed, False otherwise.
+
+ -----------------------------
+ -- Null_Exclusion_Mismatch --
+ -----------------------------
+
+ function Null_Exclusion_Mismatch
+ (Renaming : Entity_Id; Renamed : Entity_Id) return Boolean is
+ begin
+ return Has_Null_Exclusion (Parent (Renaming))
+ and then
+ not (Has_Null_Exclusion (Parent (Renamed))
+ or else (Can_Never_Be_Null (Etype (Renamed))
+ and then not
+ (Is_Formal_Subprogram (Sub)
+ and then In_Generic_Body (Current_Scope))));
+ end Null_Exclusion_Mismatch;
+
begin
-- Parameter check
Ren_Formal := First_Formal (Ren);
Sub_Formal := First_Formal (Sub);
while Present (Ren_Formal) and then Present (Sub_Formal) loop
- if Has_Null_Exclusion (Parent (Ren_Formal))
- and then
- not (Has_Null_Exclusion (Parent (Sub_Formal))
- or else Can_Never_Be_Null (Etype (Sub_Formal)))
- then
+ if Null_Exclusion_Mismatch (Ren_Formal, Sub_Formal) then
+ Error_Msg_Sloc := Sloc (Sub_Formal);
Error_Msg_NE
- ("`NOT NULL` required for parameter &",
- Parent (Sub_Formal), Sub_Formal);
+ ("`NOT NULL` required for parameter &#",
+ Ren_Formal, Sub_Formal);
end if;
Next_Formal (Ren_Formal);
@@ -2533,13 +2639,10 @@ package body Sem_Ch8 is
if Nkind (Parent (Ren)) = N_Function_Specification
and then Nkind (Parent (Sub)) = N_Function_Specification
- and then Has_Null_Exclusion (Parent (Ren))
- and then not (Has_Null_Exclusion (Parent (Sub))
- or else Can_Never_Be_Null (Etype (Sub)))
+ and then Null_Exclusion_Mismatch (Ren, Sub)
then
- Error_Msg_N
- ("return must specify `NOT NULL`",
- Result_Definition (Parent (Sub)));
+ Error_Msg_Sloc := Sloc (Sub);
+ Error_Msg_N ("return must specify `NOT NULL`#", Ren);
end if;
end Check_Null_Exclusion;
@@ -2605,7 +2708,7 @@ package body Sem_Ch8 is
exit;
end if;
- F := Next_Formal (F);
+ Next_Formal (F);
end loop;
if Ekind (Formal_Spec) = E_Function
@@ -2643,7 +2746,7 @@ package body Sem_Ch8 is
end if;
end if;
- F := Next_Formal (F);
+ Next_Formal (F);
end loop;
end if;
end if;
@@ -2740,12 +2843,12 @@ package body Sem_Ch8 is
if Nkind (Nam) = N_Attribute_Reference then
-- In the case of an abstract formal subprogram association, rewrite
- -- an actual given by a stream attribute as the name of the
- -- corresponding stream primitive of the type.
+ -- an actual given by a stream or Put_Image attribute as the name of
+ -- the corresponding stream or Put_Image primitive of the type.
- -- In a generic context the stream operations are not generated, and
- -- this must be treated as a normal attribute reference, to be
- -- expanded in subsequent instantiations.
+ -- In a generic context the stream and Put_Image operations are not
+ -- generated, and this must be treated as a normal attribute
+ -- reference, to be expanded in subsequent instantiations.
if Is_Actual
and then Is_Abstract_Subprogram (Formal_Spec)
@@ -2753,12 +2856,12 @@ package body Sem_Ch8 is
then
declare
Prefix_Type : constant Entity_Id := Entity (Prefix (Nam));
- Stream_Prim : Entity_Id;
+ Prim : Entity_Id;
begin
- -- The class-wide forms of the stream attributes are not
- -- primitive dispatching operations (even though they
- -- internally dispatch to a stream attribute).
+ -- The class-wide forms of the stream and Put_Image attributes
+ -- are not primitive dispatching operations (even though they
+ -- internally dispatch).
if Is_Class_Wide_Type (Prefix_Type) then
Error_Msg_N
@@ -2775,21 +2878,25 @@ package body Sem_Ch8 is
case Attribute_Name (Nam) is
when Name_Input =>
- Stream_Prim :=
+ Prim :=
Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Input);
when Name_Output =>
- Stream_Prim :=
+ Prim :=
Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Output);
when Name_Read =>
- Stream_Prim :=
+ Prim :=
Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Read);
when Name_Write =>
- Stream_Prim :=
+ Prim :=
Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Write);
+ when Name_Put_Image =>
+ Prim :=
+ Find_Optional_Prim_Op (Prefix_Type, TSS_Put_Image);
+
when others =>
Error_Msg_N
("attribute must be a primitive dispatching operation",
@@ -2797,10 +2904,13 @@ package body Sem_Ch8 is
return;
end case;
- -- If no operation was found, and the type is limited, the user
- -- should have defined one.
+ -- If no stream operation was found, and the type is limited,
+ -- the user should have defined one. This rule does not apply
+ -- to Put_Image.
- if No (Stream_Prim) then
+ if No (Prim)
+ and then Attribute_Name (Nam) /= Name_Put_Image
+ then
if Is_Limited_Type (Prefix_Type) then
Error_Msg_NE
("stream operation not defined for type&",
@@ -2821,9 +2931,9 @@ package body Sem_Ch8 is
declare
Prim_Name : constant Node_Id :=
Make_Identifier (Sloc (Nam),
- Chars => Chars (Stream_Prim));
+ Chars => Chars (Prim));
begin
- Set_Entity (Prim_Name, Stream_Prim);
+ Set_Entity (Prim_Name, Prim);
Rewrite (Nam, Prim_Name);
Analyze (Nam);
end;
@@ -3029,9 +3139,10 @@ package body Sem_Ch8 is
if No_Return (Rename_Spec)
and then not No_Return (Entity (Nam))
then
- Error_Msg_N ("renaming completes a No_Return procedure", N);
+ Error_Msg_NE
+ ("renamed subprogram & must be No_Return", N, Entity (Nam));
Error_Msg_N
- ("\renamed procedure must be nonreturning (RM 6.5.1 (7/2))", N);
+ ("\since renaming subprogram is No_Return (RM 6.5.1(7/2))", N);
end if;
-- The specification does not introduce new formals, but only
@@ -3068,6 +3179,22 @@ package body Sem_Ch8 is
Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec);
end if;
+ -- AI12-0132: a renames-as-body freezes the expression of any
+ -- expression function that it renames.
+
+ if Is_Entity_Name (Nam)
+ and then Is_Expression_Function (Entity (Nam))
+ and then not Inside_A_Generic
+ then
+ Freeze_Expr_Types
+ (Def_Id => Entity (Nam),
+ Typ => Etype (Entity (Nam)),
+ Expr =>
+ Expression
+ (Original_Node (Unit_Declaration_Node (Entity (Nam)))),
+ N => N);
+ end if;
+
-- Normal subprogram renaming (not renaming as body)
else
@@ -3093,7 +3220,7 @@ package body Sem_Ch8 is
Set_Kill_Elaboration_Checks (New_S, True);
- -- If we had a previous error, indicate a completely is present to stop
+ -- If we had a previous error, indicate a completion is present to stop
-- junk cascaded messages, but don't take any further action.
if Etype (Nam) = Any_Type then
@@ -3268,7 +3395,7 @@ package body Sem_Ch8 is
-- Guard against previous errors, and omit renamings of predefined
-- operators.
- elsif not Ekind_In (Old_S, E_Function, E_Procedure) then
+ elsif Ekind (Old_S) not in E_Function | E_Procedure then
null;
elsif Requires_Overriding (Old_S)
@@ -3331,6 +3458,8 @@ package body Sem_Ch8 is
if Original_Subprogram (Old_S) = Rename_Spec then
Error_Msg_N ("unfrozen subprogram cannot rename itself ", N);
+ else
+ Check_Formal_Subprogram_Conformance (New_S, Old_S, Spec);
end if;
else
Check_Subtype_Conformant (New_S, Old_S, Spec);
@@ -3374,10 +3503,6 @@ package body Sem_Ch8 is
then
Check_Mode_Conformant (New_S, Old_S);
end if;
-
- if Is_Actual and then Error_Posted (New_S) then
- Error_Msg_NE ("invalid actual subprogram: & #!", N, Old_S);
- end if;
end if;
if No (Rename_Spec) then
@@ -3694,6 +3819,17 @@ package body Sem_Ch8 is
Analyze_Aspect_Specifications (N, New_S);
end if;
+ -- AI12-0279
+
+ if Is_Actual
+ and then Has_Yield_Aspect (Formal_Spec)
+ and then not Has_Yield_Aspect (Old_S)
+ then
+ Error_Msg_Name_1 := Name_Yield;
+ Error_Msg_N
+ ("actual subprogram& must have aspect% to match formal", Name (N));
+ end if;
+
Ada_Version := Save_AV;
Ada_Version_Pragma := Save_AVP;
Ada_Version_Explicit := Save_AV_Exp;
@@ -3828,8 +3964,6 @@ package body Sem_Ch8 is
-- Start of processing for Analyze_Use_Package
begin
- Check_SPARK_05_Restriction ("use clause is not allowed", N);
-
Set_Hidden_By_Use_Clause (N, No_Elist);
-- Use clause not allowed in a spec of a predefined package declaration
@@ -3882,20 +4016,19 @@ package body Sem_Ch8 is
Set_Prev_Use_Clause (N, Current_Use_Clause (Pack));
end if;
- -- Mark all entities as potentially use visible.
+ -- Mark all entities as potentially use visible
if Ekind (Pack) /= E_Package and then Etype (Pack) /= Any_Type then
if Ekind (Pack) = E_Generic_Package then
Error_Msg_N -- CODEFIX
("a generic package is not allowed in a use clause", Name (N));
- elsif Ekind_In (Pack, E_Generic_Function, E_Generic_Package)
- then
+ elsif Is_Generic_Subprogram (Pack) then
Error_Msg_N -- CODEFIX
("a generic subprogram is not allowed in a use clause",
Name (N));
- elsif Ekind_In (Pack, E_Function, E_Procedure, E_Operator) then
+ elsif Is_Subprogram (Pack) then
Error_Msg_N -- CODEFIX
("a subprogram is not allowed in a use clause", Name (N));
@@ -4124,10 +4257,9 @@ package body Sem_Ch8 is
elsif Present (Expressions (Nam)) then
Error_Msg_N ("illegal expressions in attribute reference", Nam);
- elsif
- Nam_In (Aname, Name_Compose, Name_Exponent, Name_Leading_Part,
- Name_Pos, Name_Round, Name_Scaling,
- Name_Val)
+ elsif Aname in Name_Compose | Name_Exponent | Name_Leading_Part |
+ Name_Pos | Name_Round | Name_Scaling |
+ Name_Val
then
if Nkind (N) = N_Subprogram_Renaming_Declaration
and then Present (Corresponding_Formal_Spec (N))
@@ -4391,8 +4523,8 @@ package body Sem_Ch8 is
elsif Is_Concurrent_Type (Scope (E)) then
P := Parent (N);
while Present (P)
- and then not Nkind_In (P, N_Parameter_Specification,
- N_Component_Declaration)
+ and then Nkind (P) not in
+ N_Parameter_Specification | N_Component_Declaration
loop
P := Parent (P);
end loop;
@@ -4630,8 +4762,8 @@ package body Sem_Ch8 is
Pop_Scope;
while not (Is_List_Member (Decl))
- or else Nkind_In (Parent (Decl), N_Protected_Definition,
- N_Task_Definition)
+ or else Nkind (Parent (Decl)) in N_Protected_Definition
+ | N_Task_Definition
loop
Decl := Parent (Decl);
end loop;
@@ -4922,7 +5054,12 @@ package body Sem_Ch8 is
-- not know what procedure is being called if the procedure might be
-- overloaded, so it is premature to go setting referenced flags or
-- making calls to Generate_Reference. We will wait till Resolve_Actuals
- -- for that processing
+ -- for that processing.
+ -- Note: there is a similar routine Sem_Util.Is_Actual_Parameter, but
+ -- it works for both function and procedure calls, while here we are
+ -- only concerned with procedure calls (and with entry calls as well,
+ -- but they are parsed as procedure calls and only later rewritten to
+ -- entry calls).
function Known_But_Invisible (E : Entity_Id) return Boolean;
-- This function determines whether a reference to the entity E, which
@@ -5043,15 +5180,24 @@ package body Sem_Ch8 is
function Is_Actual_Parameter return Boolean is
begin
- return
- Nkind (N) = N_Identifier
- and then
- (Nkind (Parent (N)) = N_Procedure_Call_Statement
- or else
- (Nkind (Parent (N)) = N_Parameter_Association
- and then N = Explicit_Actual_Parameter (Parent (N))
- and then Nkind (Parent (Parent (N))) =
- N_Procedure_Call_Statement));
+ if Nkind (N) = N_Identifier then
+ case Nkind (Parent (N)) is
+ when N_Procedure_Call_Statement =>
+ return Is_List_Member (N)
+ and then List_Containing (N) =
+ Parameter_Associations (Parent (N));
+
+ when N_Parameter_Association =>
+ return N = Explicit_Actual_Parameter (Parent (N))
+ and then Nkind (Parent (Parent (N))) =
+ N_Procedure_Call_Statement;
+
+ when others =>
+ return False;
+ end case;
+ else
+ return False;
+ end if;
end Is_Actual_Parameter;
-------------------------
@@ -5337,7 +5483,7 @@ package body Sem_Ch8 is
return;
end if;
- Lit := Next_Literal (Lit);
+ Next_Literal (Lit);
end if;
end;
end if;
@@ -5396,7 +5542,7 @@ package body Sem_Ch8 is
-- is Put or Put_Line, then add a special error message (since
-- this is a very common error for beginners to make).
- if Nam_In (Chars (N), Name_Put, Name_Put_Line) then
+ if Chars (N) in Name_Put | Name_Put_Line then
Error_Msg_N -- CODEFIX
("\\possible missing `WITH Ada.Text_'I'O; " &
"USE Ada.Text_'I'O`!", N);
@@ -5935,9 +6081,9 @@ package body Sem_Ch8 is
begin
-- Generate reference unless this is an actual parameter
- -- (see comment below)
+ -- (see comment below).
- if Reference_OK and then Is_Actual_Parameter then
+ if Reference_OK and then not Is_Actual_Parameter then
Generate_Reference (E, N);
Set_Referenced (E, R);
end if;
@@ -5950,7 +6096,7 @@ package body Sem_Ch8 is
-- Package or generic package is always a simple reference
- if Ekind_In (E, E_Package, E_Generic_Package) then
+ if Is_Package_Or_Generic_Package (E) then
Generate_Reference (E, N, 'r');
-- Else see if we have a left hand side
@@ -5981,9 +6127,9 @@ package body Sem_Ch8 is
if Ada_Version >= Ada_2012
and then
(Nkind (Parent (N)) in N_Subexpr
- or else Nkind_In (Parent (N), N_Assignment_Statement,
- N_Object_Declaration,
- N_Parameter_Association))
+ or else Nkind (Parent (N)) in N_Assignment_Statement
+ | N_Object_Declaration
+ | N_Parameter_Association)
then
Check_Implicit_Dereference (N, Etype (E));
end if;
@@ -6070,13 +6216,13 @@ package body Sem_Ch8 is
Par := Nod;
while Present (Par) loop
if Nkind (Par) = N_Pragma then
- if Nam_In (Pragma_Name_Unmapped (Par),
- Name_Abstract_State,
- Name_Depends,
- Name_Global,
- Name_Initializes,
- Name_Refined_Depends,
- Name_Refined_Global)
+ if Pragma_Name_Unmapped (Par)
+ in Name_Abstract_State
+ | Name_Depends
+ | Name_Global
+ | Name_Initializes
+ | Name_Refined_Depends
+ | Name_Refined_Global
then
return True;
@@ -6177,7 +6323,7 @@ package body Sem_Ch8 is
-- The non-limited view may itself be incomplete, in which case
-- get the full view if available.
- elsif Ekind_In (Id, E_Incomplete_Type, E_Class_Wide_Type)
+ elsif Ekind (Id) in E_Incomplete_Type | E_Class_Wide_Type
and then From_Limited_With (Id)
and then Present (Non_Limited_View (Id))
and then Scope (Non_Limited_View (Id)) = P_Name
@@ -6231,7 +6377,7 @@ package body Sem_Ch8 is
end;
if No (Id)
- and then Ekind_In (P_Name, E_Procedure, E_Function)
+ and then Ekind (P_Name) in E_Procedure | E_Function
and then Is_Generic_Instance (P_Name)
then
-- Expanded name denotes entity in (instance of) generic subprogram.
@@ -6362,9 +6508,7 @@ package body Sem_Ch8 is
exit when S = Standard_Standard;
- if Ekind_In (S, E_Function,
- E_Package,
- E_Procedure)
+ if Ekind (S) in E_Function | E_Package | E_Procedure
then
P :=
Generic_Parent (Specification
@@ -7086,10 +7230,10 @@ package body Sem_Ch8 is
-- is an array type we may already have a usable subtype for it, so we
-- can use it rather than generating a new one, because the bounds
-- will be the values of the discriminants and not discriminant refs.
- -- This simplifies value tracing in GNATProve. For consistency, both
+ -- This simplifies value tracing in GNATprove. For consistency, both
-- the entity name and the subtype come from the constrained component.
- -- This is only used in GNATProve mode: when generating code it may be
+ -- This is only used in GNATprove mode: when generating code it may be
-- necessary to create an itype in the scope of use of the selected
-- component, e.g. in the context of a expanded record equality.
@@ -7155,7 +7299,7 @@ package body Sem_Ch8 is
return True;
end if;
- Clause := Next (Clause);
+ Next (Clause);
end loop;
return False;
@@ -7170,21 +7314,6 @@ package body Sem_Ch8 is
return;
end if;
- -- Selector name cannot be a character literal or an operator symbol in
- -- SPARK, except for the operator symbol in a renaming.
-
- if Restriction_Check_Required (SPARK_05) then
- if Nkind (Selector_Name (N)) = N_Character_Literal then
- Check_SPARK_05_Restriction
- ("character literal cannot be prefixed", N);
- elsif Nkind (Selector_Name (N)) = N_Operator_Symbol
- and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
- then
- Check_SPARK_05_Restriction
- ("operator symbol cannot be prefixed", N);
- end if;
- end if;
-
-- If the selector already has an entity, the node has been constructed
-- in the course of expansion, and is known to be valid. Do not verify
-- that it is defined for the type (it may be a private component used
@@ -7272,23 +7401,6 @@ package body Sem_Ch8 is
Set_Etype (N, C_Etype);
end;
- -- If this is the name of an entry or protected operation, and
- -- the prefix is an access type, insert an explicit dereference,
- -- so that entry calls are treated uniformly.
-
- if Is_Access_Type (Etype (P))
- and then Is_Concurrent_Type (Designated_Type (Etype (P)))
- then
- declare
- New_P : constant Node_Id :=
- Make_Explicit_Dereference (Sloc (P),
- Prefix => Relocate_Node (P));
- begin
- Rewrite (P, New_P);
- Set_Etype (P, Designated_Type (Etype (Prefix (P))));
- end;
- end if;
-
-- If the selected component appears within a default expression
-- and it has an actual subtype, the preanalysis has not yet
-- completed its analysis, because Insert_Actions is disabled in
@@ -7332,37 +7444,16 @@ package body Sem_Ch8 is
Write_Entity_Info (P_Type, " "); Write_Eol;
end if;
- -- The designated type may be a limited view with no components.
- -- Check whether the non-limited view is available, because in some
- -- cases this will not be set when installing the context. Rewrite
- -- the node by introducing an explicit dereference at once, and
- -- setting the type of the rewritten prefix to the non-limited view
- -- of the original designated type.
+ -- If the prefix's type is an access type, get to the record type
if Is_Access_Type (P_Type) then
- declare
- Desig_Typ : constant Entity_Id :=
- Directly_Designated_Type (P_Type);
-
- begin
- if Is_Incomplete_Type (Desig_Typ)
- and then From_Limited_With (Desig_Typ)
- and then Present (Non_Limited_View (Desig_Typ))
- then
- Rewrite (P,
- Make_Explicit_Dereference (Sloc (P),
- Prefix => Relocate_Node (P)));
-
- Set_Etype (P, Get_Full_View (Non_Limited_View (Desig_Typ)));
- P_Type := Etype (P);
- end if;
- end;
+ P_Type := Implicitly_Designated_Type (P_Type);
end if;
-- First check for components of a record object (not the
-- result of a call, which is handled below).
- if Is_Appropriate_For_Record (P_Type)
+ if Has_Components (P_Type)
and then not Is_Overloadable (P_Name)
and then not Is_Type (P_Name)
then
@@ -7376,7 +7467,7 @@ package body Sem_Ch8 is
-- Reference to type name in predicate/invariant expression
- elsif Is_Appropriate_For_Entry_Prefix (P_Type)
+ elsif (Is_Task_Type (P_Type) or else Is_Protected_Type (P_Type))
and then not In_Open_Scopes (P_Name)
and then (not Is_Concurrent_Type (Etype (P_Name))
or else not In_Open_Scopes (Etype (P_Name)))
@@ -7424,7 +7515,7 @@ package body Sem_Ch8 is
-- The subprogram may be a renaming (of an enclosing scope) as
-- in the case of the name of the generic within an instantiation.
- if Ekind_In (P_Name, E_Procedure, E_Function)
+ if Ekind (P_Name) in E_Procedure | E_Function
and then Present (Alias (P_Name))
and then Is_Generic_Instance (Alias (P_Name))
then
@@ -7527,8 +7618,7 @@ package body Sem_Ch8 is
-- routines, but this is too tricky for that.
-- Note that using Rewrite would be wrong, because we would
- -- have a tree where the original node is unanalyzed, and
- -- this violates the required interface for ASIS.
+ -- have a tree where the original node is unanalyzed.
Replace (P,
Make_Function_Call (Sloc (P), Name => Nam));
@@ -7556,16 +7646,6 @@ package body Sem_Ch8 is
else
-- Format node as expanded name, to avoid cascaded errors
- -- If the limited_with transformation was applied earlier, restore
- -- source for proper error reporting.
-
- if not Comes_From_Source (P)
- and then Nkind (P) = N_Explicit_Dereference
- then
- Rewrite (P, Prefix (P));
- P_Type := Etype (P);
- end if;
-
Change_Selected_Component_To_Expanded_Name (N);
Set_Entity (N, Any_Id);
Set_Etype (N, Any_Type);
@@ -7578,9 +7658,9 @@ package body Sem_Ch8 is
-- It is not an error if the prefix is the current instance of
-- type name, e.g. the expression of a type aspect, when it is
- -- analyzed for ASIS use, or within a generic unit. We still
- -- have to verify that a component of that name exists, and
- -- decorate the node accordingly.
+ -- analyzed within a generic unit. We still have to verify that a
+ -- component of that name exists, and decorate the node
+ -- accordingly.
elsif Is_Entity_Name (P) and then Is_Current_Instance (P) then
declare
@@ -7627,8 +7707,8 @@ package body Sem_Ch8 is
Error_Msg_N ("invalid prefix in selected component&", P);
- if Is_Access_Type (P_Type)
- and then Ekind (Designated_Type (P_Type)) = E_Incomplete_Type
+ if Is_Incomplete_Type (P_Type)
+ and then Is_Access_Type (Etype (P))
then
Error_Msg_N
("\dereference must not be of an incomplete type "
@@ -7639,21 +7719,6 @@ package body Sem_Ch8 is
Error_Msg_N ("invalid prefix in selected component", P);
end if;
end if;
-
- -- Selector name is restricted in SPARK
-
- if Nkind (N) = N_Expanded_Name
- and then Restriction_Check_Required (SPARK_05)
- then
- if Is_Subprogram (P_Name) then
- Check_SPARK_05_Restriction
- ("prefix of expanded name cannot be a subprogram", P);
- elsif Ekind (P_Name) = E_Loop then
- Check_SPARK_05_Restriction
- ("prefix of expanded name cannot be a loop statement", P);
- end if;
- end if;
-
else
-- If prefix is not the name of an entity, it must be an expression,
-- whose type is appropriate for a record. This is determined by
@@ -7811,10 +7876,6 @@ package body Sem_Ch8 is
-- Base attribute, not allowed in Ada 83
elsif Attribute_Name (N) = Name_Base then
- Error_Msg_Name_1 := Name_Base;
- Check_SPARK_05_Restriction
- ("attribute% is only allowed as prefix of another attribute", N);
-
if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_N
("(Ada 83) Base attribute not allowed in subtype mark", N);
@@ -7916,7 +7977,7 @@ package body Sem_Ch8 is
-- limited-with clauses
if From_Limited_With (T_Name)
- and then Ekind (T_Name) in Incomplete_Kind
+ and then Is_Incomplete_Type (T_Name)
and then Present (Non_Limited_View (T_Name))
and then Is_Interface (Non_Limited_View (T_Name))
then
@@ -8001,6 +8062,20 @@ package body Sem_Ch8 is
end if;
end Find_Type;
+ --------------------
+ -- Has_Components --
+ --------------------
+
+ function Has_Components (Typ : Entity_Id) return Boolean is
+ begin
+ return Is_Record_Type (Typ)
+ or else (Is_Private_Type (Typ) and then Has_Discriminants (Typ))
+ or else (Is_Task_Type (Typ) and then Has_Discriminants (Typ))
+ or else (Is_Incomplete_Type (Typ)
+ and then From_Limited_With (Typ)
+ and then Is_Record_Type (Available_View (Typ)));
+ end Has_Components;
+
------------------------------------
-- Has_Implicit_Character_Literal --
------------------------------------
@@ -8137,11 +8212,13 @@ package body Sem_Ch8 is
else
Add_One_Interp (N, Predef_Op2, T);
end if;
-
else
if not Is_Binary_Op then
Add_One_Interp (N, Predef_Op, T);
- else
+
+ -- Predef_Op2 may be empty in case of previous errors
+
+ elsif Present (Predef_Op2) then
Add_One_Interp (N, Predef_Op2, T);
end if;
end if;
@@ -8399,7 +8476,7 @@ package body Sem_Ch8 is
pragma Assert (No (Old_F));
- if Ekind_In (Old_S, E_Function, E_Enumeration_Literal) then
+ if Ekind (Old_S) in E_Function | E_Enumeration_Literal then
Set_Etype (New_S, Etype (Old_S));
end if;
end if;
@@ -8444,57 +8521,6 @@ package body Sem_Ch8 is
end loop;
end Install_Use_Clauses;
- -------------------------------------
- -- Is_Appropriate_For_Entry_Prefix --
- -------------------------------------
-
- function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean is
- P_Type : Entity_Id := T;
-
- begin
- if Is_Access_Type (P_Type) then
- P_Type := Designated_Type (P_Type);
- end if;
-
- return Is_Task_Type (P_Type) or else Is_Protected_Type (P_Type);
- end Is_Appropriate_For_Entry_Prefix;
-
- -------------------------------
- -- Is_Appropriate_For_Record --
- -------------------------------
-
- function Is_Appropriate_For_Record (T : Entity_Id) return Boolean is
-
- function Has_Components (T1 : Entity_Id) return Boolean;
- -- Determine if given type has components (i.e. is either a record
- -- type or a type that has discriminants).
-
- --------------------
- -- Has_Components --
- --------------------
-
- function Has_Components (T1 : Entity_Id) return Boolean is
- begin
- return Is_Record_Type (T1)
- or else (Is_Private_Type (T1) and then Has_Discriminants (T1))
- or else (Is_Task_Type (T1) and then Has_Discriminants (T1))
- or else (Is_Incomplete_Type (T1)
- and then From_Limited_With (T1)
- and then Present (Non_Limited_View (T1))
- and then Is_Record_Type
- (Get_Full_View (Non_Limited_View (T1))));
- end Has_Components;
-
- -- Start of processing for Is_Appropriate_For_Record
-
- begin
- return
- Present (T)
- and then (Has_Components (T)
- or else (Is_Access_Type (T)
- and then Has_Components (Designated_Type (T))));
- end Is_Appropriate_For_Record;
-
----------------------
-- Mark_Use_Clauses --
----------------------
@@ -8526,7 +8552,7 @@ package body Sem_Ch8 is
while Present (Curr) loop
Mark_Use_Type (Curr);
- Curr := Next_Formal (Curr);
+ Next_Formal (Curr);
end loop;
-- Handle the return type
@@ -8651,7 +8677,7 @@ package body Sem_Ch8 is
-- Use clauses in and of themselves do not count as a "use" of a
-- package.
- if Nkind_In (Parent (Id), N_Use_Package_Clause, N_Use_Type_Clause) then
+ if Nkind (Parent (Id)) in N_Use_Package_Clause | N_Use_Type_Clause then
return;
end if;
@@ -8673,11 +8699,11 @@ package body Sem_Ch8 is
-- Mark primitives
elsif (Ekind (Id) in Overloadable_Kind
- or else Ekind_In (Id, E_Generic_Function,
- E_Generic_Procedure))
+ or else Ekind (Id) in
+ E_Generic_Function | E_Generic_Procedure)
and then (Is_Potentially_Use_Visible (Id)
or else Is_Intrinsic_Subprogram (Id)
- or else (Ekind_In (Id, E_Function, E_Procedure)
+ or else (Ekind (Id) in E_Function | E_Procedure
and then Is_Generic_Actual_Subprogram (Id)))
then
Mark_Parameters (Id);
@@ -8713,7 +8739,7 @@ package body Sem_Ch8 is
-- Ignore fully qualified names as they do not count as a "use" of
-- a package.
- if Nkind_In (Id, N_Identifier, N_Operator_Symbol)
+ if Nkind (Id) in N_Identifier | N_Operator_Symbol
or else (Present (Prefix (Id))
and then Scope (Entity (Id)) /= Entity (Prefix (Id)))
then
@@ -8779,7 +8805,7 @@ package body Sem_Ch8 is
-- Set Default_Storage_Pool field of the library unit if necessary
- if Ekind_In (S, E_Package, E_Generic_Package)
+ if Is_Package_Or_Generic_Package (S)
and then
Nkind (Parent (Unit_Declaration_Node (S))) = N_Compilation_Unit
then
@@ -8949,7 +8975,7 @@ package body Sem_Ch8 is
if Is_Child_Unit (S)
and then Present (E)
- and then Ekind_In (E, E_Package, E_Generic_Package)
+ and then Is_Package_Or_Generic_Package (E)
and then
Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
then
@@ -8992,43 +9018,43 @@ package body Sem_Ch8 is
end if;
end if;
- if Kind = N_Component_Declaration then
- Error_Msg_N
- ("component&! cannot be used before end of record declaration", N);
+ case Kind is
+ when N_Component_Declaration =>
+ Error_Msg_N
+ ("component&! cannot be used before end of record declaration",
+ N);
- elsif Kind = N_Parameter_Specification then
- Error_Msg_N
- ("formal parameter&! cannot be used before end of specification",
- N);
+ when N_Parameter_Specification =>
+ Error_Msg_N
+ ("formal parameter&! cannot be used before end of specification",
+ N);
- elsif Kind = N_Discriminant_Specification then
- Error_Msg_N
- ("discriminant&! cannot be used before end of discriminant part",
- N);
+ when N_Discriminant_Specification =>
+ Error_Msg_N
+ ("discriminant&! cannot be used before end of discriminant part",
+ N);
- elsif Kind = N_Procedure_Specification
- or else Kind = N_Function_Specification
- then
- Error_Msg_N
- ("subprogram&! cannot be used before end of its declaration",
- N);
+ when N_Procedure_Specification | N_Function_Specification =>
+ Error_Msg_N
+ ("subprogram&! cannot be used before end of its declaration",
+ N);
- elsif Kind = N_Full_Type_Declaration then
- Error_Msg_N
- ("type& cannot be used before end of its declaration!", N);
+ when N_Full_Type_Declaration | N_Subtype_Declaration =>
+ Error_Msg_N
+ ("type& cannot be used before end of its declaration!", N);
- else
- Error_Msg_N
- ("object& cannot be used before end of its declaration!", N);
+ when others =>
+ Error_Msg_N
+ ("object& cannot be used before end of its declaration!", N);
- -- If the premature reference appears as the expression in its own
- -- declaration, rewrite it to prevent compiler loops in subsequent
- -- uses of this mangled declaration in address clauses.
+ -- If the premature reference appears as the expression in its own
+ -- declaration, rewrite it to prevent compiler loops in subsequent
+ -- uses of this mangled declaration in address clauses.
- if Nkind (Parent (N)) = N_Object_Declaration then
- Set_Entity (N, Any_Id);
- end if;
- end if;
+ if Nkind (Parent (N)) = N_Object_Declaration then
+ Set_Entity (N, Any_Id);
+ end if;
+ end case;
end Premature_Usage;
------------------------
@@ -9407,7 +9433,7 @@ package body Sem_Ch8 is
Set_Current_Use_Clause (Entity (N), Prev_Use_Clause (Curr));
end if;
- Curr := Next_Use_Clause (Curr);
+ Next_Use_Clause (Curr);
end loop;
end Update_Chain_In_Scope;
@@ -9469,9 +9495,14 @@ package body Sem_Ch8 is
Set_Redundant_Use (Clause, True);
+ -- Do not check for redundant use if clause is generated, or in an
+ -- instance, or in a predefined unit to avoid misleading warnings
+ -- that may occur as part of a rtsfind load.
+
if not Comes_From_Source (Clause)
or else In_Instance
or else not Warn_On_Redundant_Constructs
+ or else Is_Predefined_Unit (Current_Sem_Unit)
then
return;
end if;
@@ -9604,10 +9635,12 @@ package body Sem_Ch8 is
Private_Declarations (Parent (Decl))
then
declare
- Par : constant Entity_Id := Defining_Entity (Parent (Decl));
- Spec : constant Node_Id :=
- Specification (Unit (Cunit (Current_Sem_Unit)));
+ Par : constant Entity_Id :=
+ Defining_Entity (Parent (Decl));
+ Spec : constant Node_Id :=
+ Specification (Unit (Cunit (Current_Sem_Unit)));
Cur_List : constant List_Id := List_Containing (Cur_Use);
+
begin
if Is_Compilation_Unit (Par)
and then Par /= Cunit_Entity (Current_Sem_Unit)
@@ -9649,7 +9682,7 @@ package body Sem_Ch8 is
Error_Msg_Sloc := Sloc (Prev_Use);
Error_Msg_NE -- CODEFIX
- ("& is already use-visible through previous use_clause #??",
+ ("& is already use-visible through previous use_clause #?r?",
Redundant, Pack_Name);
end if;
end Note_Redundant_Use;
@@ -10240,7 +10273,7 @@ package body Sem_Ch8 is
& "use_type_clause #??", Clause1, T);
return;
- elsif Nkind_In (Unit2, N_Package_Body, N_Subprogram_Body)
+ elsif Nkind (Unit2) in N_Package_Body | N_Subprogram_Body
and then Nkind (Unit1) /= Nkind (Unit2)
and then Nkind (Unit1) /= N_Subunit
then
diff --git a/gcc/ada/sem_ch8.ads b/gcc/ada/sem_ch8.ads
index 2a517c2..b1a2b9e 100644
--- a/gcc/ada/sem_ch8.ads
+++ b/gcc/ada/sem_ch8.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index 82bf021..effc858 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -133,8 +133,8 @@ package body Sem_Ch9 is
-- when Lock_Free_Given is True.
begin
- pragma Assert (Nkind_In (N, N_Protected_Type_Declaration,
- N_Protected_Body));
+ pragma Assert
+ (Nkind (N) in N_Protected_Type_Declaration | N_Protected_Body);
-- The lock-free implementation is currently enabled through a debug
-- flag. When Lock_Free_Given is True, an aspect Lock_Free forces the
@@ -569,7 +569,7 @@ package body Sem_Ch9 is
if Ekind (Id) = E_Component then
Comp_Id := Id;
- elsif Ekind_In (Id, E_Constant, E_Variable)
+ elsif Ekind (Id) in E_Constant | E_Variable
and then Present (Prival_Link (Id))
then
Comp_Id := Prival_Link (Id);
@@ -706,7 +706,6 @@ package body Sem_Ch9 is
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("abort statement is not allowed", N);
T_Name := First (Names (N));
while Present (T_Name) loop
@@ -777,7 +776,6 @@ package body Sem_Ch9 is
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("accept statement is not allowed", N);
-- Entry name is initialized to Any_Id. It should get reset to the
-- matching entry entity. An error is signalled if it is not reset.
@@ -917,12 +915,12 @@ package body Sem_Ch9 is
end loop;
end;
- if Ekind (E) = E_Entry_Family then
+ if Ekind (Entry_Nam) = E_Entry_Family then
if No (Index) then
Error_Msg_N ("missing entry index in accept for entry family", N);
else
- Analyze_And_Resolve (Index, Entry_Index_Type (E));
- Apply_Range_Check (Index, Entry_Index_Type (E));
+ Analyze_And_Resolve (Index, Entry_Index_Type (Entry_Nam));
+ Apply_Scalar_Range_Check (Index, Entry_Index_Type (Entry_Nam));
end if;
elsif Present (Index) then
@@ -1019,7 +1017,6 @@ package body Sem_Ch9 is
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("select statement is not allowed", N);
Check_Restriction (Max_Asynchronous_Select_Nesting, N);
Check_Restriction (No_Select_Statements, N);
@@ -1065,7 +1062,6 @@ package body Sem_Ch9 is
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("select statement is not allowed", N);
Check_Restriction (No_Select_Statements, N);
-- Ada 2005 (AI-345): The trigger may be a dispatching call
@@ -1117,7 +1113,7 @@ package body Sem_Ch9 is
Analyze_List (Pragmas_Before (N));
end if;
- if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then
+ if Nkind (Parent (N)) in N_Selective_Accept | N_Timed_Entry_Call then
Expr := Expression (Delay_Statement (N));
-- Defer full analysis until the statement is expanded, to insure
@@ -1163,7 +1159,6 @@ package body Sem_Ch9 is
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("delay statement is not allowed", N);
Check_Restriction (No_Relative_Delay, N);
Check_Restriction (No_Delay, N);
Check_Potentially_Blocking_Operation (N);
@@ -1189,7 +1184,6 @@ package body Sem_Ch9 is
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("delay statement is not allowed", N);
Check_Restriction (No_Delay, N);
Check_Potentially_Blocking_Operation (N);
Analyze_And_Resolve (E);
@@ -1303,7 +1297,7 @@ package body Sem_Ch9 is
Set_Analyzed (Def, False);
-- Keep the original subtree to ensure a properly
- -- formed tree (e.g. for ASIS use).
+ -- formed tree.
Rewrite
(Discrete_Subtype_Definition (Index_Spec), Def);
@@ -1505,7 +1499,6 @@ package body Sem_Ch9 is
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("entry call is not allowed", N);
if Present (Pragmas_Before (N)) then
Analyze_List (Pragmas_Before (N));
@@ -1956,7 +1949,6 @@ package body Sem_Ch9 is
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("protected definition is not allowed", N);
Analyze_Declarations (Visible_Declarations (N));
if Present (Private_Declarations (N))
@@ -1974,7 +1966,7 @@ package body Sem_Ch9 is
Item_Id := First_Entity (Prot_Typ);
while Present (Item_Id) loop
- if Ekind_In (Item_Id, E_Function, E_Procedure) then
+ if Ekind (Item_Id) in E_Function | E_Procedure then
Set_Convention (Item_Id, Convention_Protected);
else
Propagate_Concurrent_Flags (Prot_Typ, Etype (Item_Id));
@@ -2258,6 +2250,11 @@ package body Sem_Ch9 is
Propagate_Invariant_Attributes (T, From_Typ => Def_Id);
+ -- Propagate predicate-related attributes from the private type to
+ -- the protected type.
+
+ Propagate_Predicate_Attributes (T, From_Typ => Def_Id);
+
-- Create corresponding record now, because some private dependents
-- may be subtypes of the partial view.
@@ -2312,7 +2309,6 @@ package body Sem_Ch9 is
Warnings => True);
Tasking_Used := True;
- Check_SPARK_05_Restriction ("requeue statement is not allowed", N);
Check_Restriction (No_Requeue_Statements, N);
Check_Unreachable_Code (N);
@@ -2321,7 +2317,7 @@ package body Sem_Ch9 is
Enclosing := Scope_Stack.Table (J).Entity;
exit when Is_Entry (Enclosing);
- if not Ekind_In (Enclosing, E_Block, E_Loop) then
+ if Ekind (Enclosing) not in E_Block | E_Loop then
Error_Msg_N ("requeue must appear within accept or entry body", N);
return;
end if;
@@ -2554,7 +2550,7 @@ package body Sem_Ch9 is
-- perform an unconditional goto so that any further
-- references will not occur anyway.
- if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then
+ if Ekind (Ent) in E_Out_Parameter | E_In_Out_Parameter then
Set_Never_Set_In_Source (Ent, False);
Set_Is_True_Constant (Ent, False);
end if;
@@ -2606,7 +2602,6 @@ package body Sem_Ch9 is
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("select statement is not allowed", N);
Check_Restriction (No_Select_Statements, N);
-- Loop to analyze alternatives
@@ -2993,6 +2988,24 @@ package body Sem_Ch9 is
else
Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
end if;
+
+ -- The entity list of the current scope now includes entities in
+ -- the spec as well as the body. Their declarations will become
+ -- part of the statement sequence of the task body procedure that
+ -- is built during expansion. Indicate that aspect specifications
+ -- for these entities need not be rechecked. The guards on
+ -- Check_Aspect_At_End_Of_Declarations are not sufficient to
+ -- suppress these checks, because the declarations come from source.
+
+ declare
+ Priv : Entity_Id := First_Private_Entity (Spec_Id);
+
+ begin
+ while Present (Priv) loop
+ Set_Has_Delayed_Aspects (Priv, False);
+ Next_Entity (Priv);
+ end loop;
+ end;
end if;
-- Mark all handlers as not suitable for local raise optimization,
@@ -3050,7 +3063,6 @@ package body Sem_Ch9 is
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("task definition is not allowed", N);
if Present (Visible_Declarations (N)) then
Analyze_Declarations (Visible_Declarations (N));
@@ -3239,6 +3251,11 @@ package body Sem_Ch9 is
Propagate_Invariant_Attributes (T, From_Typ => Def_Id);
+ -- Propagate predicate-related attributes from the private type to
+ -- task type.
+
+ Propagate_Predicate_Attributes (T, From_Typ => Def_Id);
+
-- Create corresponding record now, because some private dependents
-- may be subtypes of the partial view.
@@ -3292,7 +3309,6 @@ package body Sem_Ch9 is
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("select statement is not allowed", N);
Check_Restriction (No_Select_Statements, N);
-- Ada 2005 (AI-345): The trigger may be a dispatching call
@@ -3454,7 +3470,7 @@ package body Sem_Ch9 is
begin
pragma Assert
- (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration));
+ (Nkind (N) in N_Protected_Type_Declaration | N_Task_Type_Declaration);
if Present (Interface_List (N)) then
Set_Is_Tagged_Type (T);
@@ -3462,7 +3478,7 @@ package body Sem_Ch9 is
-- The primitive operations of a tagged synchronized type are placed
-- on the Corresponding_Record for proper dispatching, but are
-- attached to the synchronized type itself when expansion is
- -- disabled, for ASIS use.
+ -- disabled.
Set_Direct_Primitive_Operations (T, New_Elmt_List);
diff --git a/gcc/ada/sem_ch9.ads b/gcc/ada/sem_ch9.ads
index 035378a..abd3c09 100644
--- a/gcc/ada/sem_ch9.ads
+++ b/gcc/ada/sem_ch9.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb
index 177902f..cb93fdb 100644
--- a/gcc/ada/sem_dim.adb
+++ b/gcc/ada/sem_dim.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -40,7 +40,6 @@ with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
-with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
@@ -377,10 +376,6 @@ package body Sem_Dim is
procedure Set_Symbol (E : Entity_Id; Val : String_Id);
-- Associate a symbol representation of a dimension vector with a subtype
- function String_From_Numeric_Literal (N : Node_Id) return String_Id;
- -- Return the string that corresponds to the numeric litteral N as it
- -- appears in the source.
-
function Symbol_Of (E : Entity_Id) return String_Id;
-- E denotes a subtype with a dimension. Return the symbol representation
-- of the dimension vector.
@@ -628,8 +623,8 @@ package body Sem_Dim is
-- Named symbol argument
if No (Symbol_Expr)
- or else not Nkind_In (Symbol_Expr, N_Character_Literal,
- N_String_Literal)
+ or else Nkind (Symbol_Expr) not in
+ N_Character_Literal | N_String_Literal
then
Symbol_Expr := Empty;
@@ -649,8 +644,8 @@ package body Sem_Dim is
-- Verify symbol expression is a string or a character
- if not Nkind_In (Symbol_Expr, N_Character_Literal,
- N_String_Literal)
+ if Nkind (Symbol_Expr) not in
+ N_Character_Literal | N_String_Literal
then
Symbol_Expr := Empty;
Error_Msg_N
@@ -661,8 +656,8 @@ package body Sem_Dim is
-- Special error if no Symbol choice but expression is string
-- or character.
- elsif Nkind_In (Expression (Assoc), N_Character_Literal,
- N_String_Literal)
+ elsif Nkind (Expression (Assoc)) in
+ N_Character_Literal | N_String_Literal
then
Num_Choices := Num_Choices + 1;
Error_Msg_N
@@ -681,7 +676,7 @@ package body Sem_Dim is
-- Skip the symbol expression when present
if Present (Symbol_Expr) and then Num_Choices = 0 then
- Expr := Next (Expr);
+ Next (Expr);
end if;
Position := Low_Position_Bound;
@@ -1044,8 +1039,8 @@ package body Sem_Dim is
-- Check the second argument for each dimension aggregate is
-- a string or a character.
- if not Nkind_In (Unit_Symbol, N_String_Literal,
- N_Character_Literal)
+ if Nkind (Unit_Symbol) not in
+ N_String_Literal | N_Character_Literal
then
Error_Msg_N
("expected unit symbol (string or character)",
@@ -1077,8 +1072,8 @@ package body Sem_Dim is
-- Check the third argument for each dimension aggregate is
-- a string or a character.
- if not Nkind_In (Dim_Symbol, N_String_Literal,
- N_Character_Literal)
+ if Nkind (Dim_Symbol) not in
+ N_String_Literal | N_Character_Literal
then
Error_Msg_N
("expected dimension symbol (string or character)",
@@ -1148,13 +1143,11 @@ package body Sem_Dim is
return;
elsif not Comes_From_Source (N) then
- if Nkind_In (N, N_Explicit_Dereference,
- N_Identifier,
- N_Object_Declaration,
- N_Subtype_Declaration)
+ if Nkind (N) not in N_Explicit_Dereference
+ | N_Identifier
+ | N_Object_Declaration
+ | N_Subtype_Declaration
then
- null;
- else
return;
end if;
end if;
@@ -1446,9 +1439,8 @@ package body Sem_Dim is
return;
end if;
- if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract)
- or else N_Kind in N_Multiplying_Operator
- or else N_Kind in N_Op_Compare
+ if N_Kind in N_Op_Add | N_Op_Expon | N_Op_Subtract
+ | N_Multiplying_Operator | N_Op_Compare
then
declare
L : constant Node_Id := Left_Opnd (N);
@@ -1464,7 +1456,7 @@ package body Sem_Dim is
begin
-- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case
- if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then
+ if N_Kind in N_Op_Add | N_Op_Mod | N_Op_Rem | N_Op_Subtract then
-- Check both operands have same dimension
@@ -1480,7 +1472,7 @@ package body Sem_Dim is
-- N_Op_Multiply or N_Op_Divide case
- elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then
+ elsif N_Kind in N_Op_Multiply | N_Op_Divide then
-- Check at least one operand is not dimensionless
@@ -1598,13 +1590,13 @@ package body Sem_Dim is
-- literal is treated as if its dimension matches the type
-- dimension.
- elsif Nkind_In (Original_Node (L), N_Integer_Literal,
- N_Real_Literal)
+ elsif Nkind (Original_Node (L)) in
+ N_Integer_Literal | N_Real_Literal
then
Dim_Warning_For_Numeric_Literal (L, Etype (R));
- elsif Nkind_In (Original_Node (R), N_Integer_Literal,
- N_Real_Literal)
+ elsif Nkind (Original_Node (R)) in
+ N_Integer_Literal | N_Real_Literal
then
Dim_Warning_For_Numeric_Literal (R, Etype (L));
@@ -1880,8 +1872,8 @@ package body Sem_Dim is
-- dimensionless to indicate the literal is treated as if its
-- dimension matches the type dimension.
- if Nkind_In (Original_Node (Expr), N_Real_Literal,
- N_Integer_Literal)
+ if Nkind (Original_Node (Expr)) in
+ N_Real_Literal | N_Integer_Literal
then
Dim_Warning_For_Numeric_Literal (Expr, Etyp);
@@ -2070,8 +2062,8 @@ package body Sem_Dim is
if Present (Expr)
and then Dims_Of_Typ /= Dimensions_Of (Expr)
- and then Nkind_In (Original_Node (Expr), N_Real_Literal,
- N_Integer_Literal)
+ and then Nkind (Original_Node (Expr)) in
+ N_Real_Literal | N_Integer_Literal
then
Dim_Warning_For_Numeric_Literal (Expr, Etype (Typ));
end if;
@@ -2110,7 +2102,7 @@ package body Sem_Dim is
Check_Error_Detected;
return;
- elsif Ekind_In (Id, E_Constant, E_Named_Real)
+ elsif Ekind (Id) in E_Constant | E_Named_Real
and then Exists (Dimensions_Of (Id))
then
Set_Dimensions (N, Dimensions_Of (Id));
@@ -2247,8 +2239,8 @@ package body Sem_Dim is
-- not dimensionless to indicate the literal is treated as if
-- its dimension matches the type dimension.
- if Nkind_In (Original_Node (Expr), N_Real_Literal,
- N_Integer_Literal)
+ if Nkind (Original_Node (Expr)) in
+ N_Real_Literal | N_Integer_Literal
then
Dim_Warning_For_Numeric_Literal (Expr, Etyp);
@@ -2590,16 +2582,6 @@ package body Sem_Dim is
Result := No_Rational;
end if;
- -- Provide minimal semantic information on dimension expressions,
- -- even though they have no run-time existence. This is for use by
- -- ASIS tools, in particular pretty-printing. If generating code
- -- standard operator resolution will take place.
-
- if ASIS_Mode then
- Set_Entity (N, Standard_Op_Minus);
- Set_Etype (N, Standard_Integer);
- end if;
-
return Result;
end Process_Minus;
@@ -2626,16 +2608,6 @@ package body Sem_Dim is
Result := Left_Rat / Right_Rat;
end if;
- -- Provide minimal semantic information on dimension expressions,
- -- even though they have no run-time existence. This is for use by
- -- ASIS tools, in particular pretty-printing. If generating code
- -- standard operator resolution will take place.
-
- if ASIS_Mode then
- Set_Entity (N, Standard_Op_Divide);
- Set_Etype (N, Standard_Integer);
- end if;
-
return Result;
end Process_Divide;
@@ -3760,63 +3732,6 @@ package body Sem_Dim is
Symbol_Table.Set (E, Val);
end Set_Symbol;
- ---------------------------------
- -- String_From_Numeric_Literal --
- ---------------------------------
-
- function String_From_Numeric_Literal (N : Node_Id) return String_Id is
- Loc : constant Source_Ptr := Sloc (N);
- Sbuffer : constant Source_Buffer_Ptr :=
- Source_Text (Get_Source_File_Index (Loc));
- Src_Ptr : Source_Ptr := Loc;
-
- C : Character := Sbuffer (Src_Ptr);
- -- Current source program character
-
- function Belong_To_Numeric_Literal (C : Character) return Boolean;
- -- Return True if C belongs to a numeric literal
-
- -------------------------------
- -- Belong_To_Numeric_Literal --
- -------------------------------
-
- function Belong_To_Numeric_Literal (C : Character) return Boolean is
- begin
- case C is
- when '0' .. '9'
- | '_' | '.' | 'e' | '#' | 'A' | 'B' | 'C' | 'D' | 'E' | 'F'
- =>
- return True;
-
- -- Make sure '+' or '-' is part of an exponent.
-
- when '+' | '-' =>
- declare
- Prev_C : constant Character := Sbuffer (Src_Ptr - 1);
- begin
- return Prev_C = 'e' or else Prev_C = 'E';
- end;
-
- -- All other character doesn't belong to a numeric literal
-
- when others =>
- return False;
- end case;
- end Belong_To_Numeric_Literal;
-
- -- Start of processing for String_From_Numeric_Literal
-
- begin
- Start_String;
- while Belong_To_Numeric_Literal (C) loop
- Store_String_Char (C);
- Src_Ptr := Src_Ptr + 1;
- C := Sbuffer (Src_Ptr);
- end loop;
-
- return End_String;
- end String_From_Numeric_Literal;
-
---------------
-- Symbol_Of --
---------------
diff --git a/gcc/ada/sem_dim.ads b/gcc/ada/sem_dim.ads
index 8c41de8..0f9d603 100644
--- a/gcc/ada/sem_dim.ads
+++ b/gcc/ada/sem_dim.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index b04b863..67a8cdf 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Debug; use Debug;
with Elists; use Elists;
@@ -292,7 +293,7 @@ package body Sem_Disp is
Next_Formal (Formal);
end loop;
- if Ekind_In (Subp, E_Function, E_Generic_Function) then
+ if Ekind (Subp) in E_Function | E_Generic_Function then
Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
if Present (Ctrl_Type) then
@@ -620,7 +621,7 @@ package body Sem_Disp is
Par := Parent (Par);
end if;
- if Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement)
+ if Nkind (Par) in N_Function_Call | N_Procedure_Call_Statement
and then Is_Entity_Name (Name (Par))
then
declare
@@ -683,7 +684,7 @@ package body Sem_Disp is
-- For equality operators, one of the operands must be
-- statically or dynamically tagged.
- elsif Nkind_In (Par, N_Op_Eq, N_Op_Ne) then
+ elsif Nkind (Par) in N_Op_Eq | N_Op_Ne then
if N = Right_Opnd (Par)
and then Is_Tag_Indeterminate (Left_Opnd (Par))
then
@@ -992,7 +993,7 @@ package body Sem_Disp is
-- Start of processing for Check_Dispatching_Operation
begin
- if not Ekind_In (Subp, E_Function, E_Procedure) then
+ if Ekind (Subp) not in E_Function | E_Procedure then
return;
-- The Default_Initial_Condition procedure is not a primitive subprogram
@@ -1408,7 +1409,7 @@ package body Sem_Disp is
-- visible operation that may be declared in a partial view when
-- the full view is controlled.
- if Nam_In (Chars (Subp), Name_Initialize, Name_Adjust, Name_Finalize)
+ if Chars (Subp) in Name_Initialize | Name_Adjust | Name_Finalize
and then Is_Controlled (Tagged_Type)
and then not Is_Visibly_Controlled (Tagged_Type)
and then not Is_Inherited_Public_Operation (Ovr_Subp)
@@ -1482,22 +1483,6 @@ package body Sem_Disp is
end if;
end if;
- -- If the tagged type is a concurrent type then we must be compiling
- -- with no code generation (we are either compiling a generic unit or
- -- compiling under -gnatc mode) because we have previously tested that
- -- no serious errors has been reported. In this case we do not add the
- -- primitive to the list of primitives of Tagged_Type but we leave the
- -- primitive decorated as a dispatching operation to be able to analyze
- -- and report errors associated with the Object.Operation notation.
-
- elsif Is_Concurrent_Type (Tagged_Type) then
- pragma Assert (not Expander_Active);
-
- -- Attach operation to list of primitives of the synchronized type
- -- itself, for ASIS use.
-
- Add_Dispatching_Operation (Tagged_Type, Subp);
-
-- If no old subprogram, then we add this as a dispatching operation,
-- but we avoid doing this if an error was posted, to prevent annoying
-- cascaded errors.
@@ -1584,10 +1569,10 @@ package body Sem_Disp is
Set_DT_Position_Value (Subp, No_Uint);
elsif Has_Controlled_Component (Tagged_Type)
- and then Nam_In (Chars (Subp), Name_Initialize,
- Name_Adjust,
- Name_Finalize,
- Name_Finalize_Address)
+ and then Chars (Subp) in Name_Initialize
+ | Name_Adjust
+ | Name_Finalize
+ | Name_Finalize_Address
then
declare
F_Node : constant Node_Id := Freeze_Node (Tagged_Type);
@@ -1652,6 +1637,42 @@ package body Sem_Disp is
end;
end if;
+ -- AI12-0279: If the Yield aspect is specified for a dispatching
+ -- subprogram that inherits the aspect, the specified value shall
+ -- be confirming.
+
+ if Is_Dispatching_Operation (Subp)
+ and then Is_Primitive_Wrapper (Subp)
+ and then Present (Wrapped_Entity (Subp))
+ and then Comes_From_Source (Wrapped_Entity (Subp))
+ and then Present (Overridden_Operation (Subp))
+ and then Has_Yield_Aspect (Overridden_Operation (Subp))
+ /= Has_Yield_Aspect (Wrapped_Entity (Subp))
+ then
+ declare
+ W_Ent : constant Entity_Id := Wrapped_Entity (Subp);
+ W_Decl : constant Node_Id := Parent (W_Ent);
+ Asp : Node_Id;
+
+ begin
+ if Present (Aspect_Specifications (W_Decl)) then
+ Asp := First (Aspect_Specifications (W_Decl));
+ while Present (Asp) loop
+ if Chars (Identifier (Asp)) = Name_Yield then
+ Error_Msg_Name_1 := Name_Yield;
+ Error_Msg_N
+ ("specification of inherited aspect% can only confirm "
+ & "parent value", Asp);
+ end if;
+
+ Next (Asp);
+ end loop;
+ end if;
+
+ Set_Has_Yield_Aspect (Wrapped_Entity (Subp));
+ end;
+ end if;
+
-- For similarity with record extensions, in Ada 9X the language should
-- have disallowed adding visible operations to a tagged type after
-- deriving a private extension from it. Report a warning if this
@@ -1989,7 +2010,7 @@ package body Sem_Disp is
Ctrl_Type : Entity_Id;
begin
- if Ekind_In (Subp, E_Function, E_Procedure)
+ if Ekind (Subp) in E_Function | E_Procedure
and then Present (DTC_Entity (Subp))
then
return Scope (DTC_Entity (Subp));
@@ -2564,14 +2585,6 @@ package body Sem_Disp is
Prim : Node_Id;
begin
- -- Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but
- -- we do it unconditionally in Ada 95 now, since this is our pragma).
-
- if No_Return (Prev_Op) and then not No_Return (New_Op) then
- Error_Msg_N ("procedure & must have No_Return pragma", New_Op);
- Error_Msg_N ("\since overridden procedure has No_Return", New_Op);
- end if;
-
-- If there is no previous operation to override, the type declaration
-- was malformed, and an error must have been emitted already.
@@ -2682,7 +2695,6 @@ package body Sem_Disp is
Set_Alias (Prev_Op, New_Op);
Set_DTC_Entity (Prev_Op, Empty);
Set_Has_Controlling_Result (New_Op, Has_Controlling_Result (Prev_Op));
- return;
end if;
end Override_Dispatching_Operation;
diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads
index fd399a3..993ec10 100644
--- a/gcc/ada/sem_disp.ads
+++ b/gcc/ada/sem_disp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -64,11 +64,11 @@ package Sem_Disp is
-- this call actually do???
procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id);
- -- Add Old_Subp to the list of primitive operations of the corresponding
- -- tagged type if it is the full view of a private tagged type. The Alias
- -- of Old_Subp is adjusted to point to the inherited procedure of the
- -- full view because it is always this one which has to be called.
- -- What is Subp used for???
+ -- No action performed if Subp is not an alias of a dispatching operation.
+ -- Add Old_Subp (if not already present) to the list of primitives of the
+ -- tagged type T of Subp if T is the full view of a private tagged type.
+ -- The Alias of Old_Subp is adjusted to point to the inherited procedure
+ -- of the full view because it is always this one which has to be called.
function Covered_Interface_Op (Prim : Entity_Id) return Entity_Id;
-- Returns the interface primitive that Prim covers, when its controlling
diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb
index c1d6e72..4ee6e8b 100644
--- a/gcc/ada/sem_dist.adb
+++ b/gcc/ada/sem_dist.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -746,13 +746,12 @@ package body Sem_Dist is
-- we are generating code.
if Comes_From_Source (P)
+ and then Expander_Active
and then Is_Record_Type (ET)
- and then (Is_Remote_Call_Interface (ET)
- or else Is_Remote_Types (ET))
+ and then (Is_Remote_Call_Interface (ET) or else Is_Remote_Types (ET))
and then Present (Corresponding_Remote_Type (ET))
- and then Nkind_In (Parent (Parent (P)), N_Procedure_Call_Statement,
- N_Indexed_Component)
- and then Expander_Active
+ and then Nkind (Parent (Parent (P))) in
+ N_Procedure_Call_Statement | N_Indexed_Component
then
RAS_E_Dereference (P);
return True;
diff --git a/gcc/ada/sem_dist.ads b/gcc/ada/sem_dist.ads
index 836464f..cf40429 100644
--- a/gcc/ada/sem_dist.ads
+++ b/gcc/ada/sem_dist.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
index f3cac46..78108e9 100644
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -75,8 +75,8 @@ package body Sem_Elab is
-- The access-before-elaboration (ABE) mechanism implemented in this unit
-- has the following objectives:
--
- -- * Diagnose at compile-time or install run-time checks to prevent ABE
- -- access to data and behaviour.
+ -- * Diagnose at compile time or install run-time checks to prevent ABE
+ -- access to data and behavior.
--
-- The high-level idea is to accurately diagnose ABE issues within a
-- single unit because the ABE mechanism can inspect the whole unit.
@@ -111,7 +111,7 @@ package body Sem_Elab is
-- * Dynamic model - This is the most permissive of the three models.
-- When the dynamic model is in effect, the mechanism diagnoses and
-- installs run-time checks to detect ABE issues in the main unit.
- -- The behaviour of this model is identical to that specified by the
+ -- The behavior of this model is identical to that specified by the
-- Ada RM. This model is enabled with switch -gnatE.
--
-- Static model - This is the middle ground of the three models. When
@@ -122,7 +122,7 @@ package body Sem_Elab is
-- the prior elaboration of withed units. This is the default model.
--
-- * SPARK model - This is the most conservative of the three models and
- -- impelements the semantics defined in SPARK RM 7.7. The SPARK model
+ -- implements the semantics defined in SPARK RM 7.7. The SPARK model
-- is in effect only when a context resides in a SPARK_Mode On region,
-- otherwise the mechanism falls back to one of the previous models.
--
@@ -186,7 +186,7 @@ package body Sem_Elab is
--
-- * Library level - A type of enclosing level. A scenario or target is at
-- the library level if it appears in a package library unit, ignoring
- -- enclosng packages.
+ -- enclosing packages.
--
-- * Non-library-level encapsulator - A construct that cannot be elaborated
-- on its own and requires elaboration by a top-level scenario.
@@ -400,7 +400,7 @@ package body Sem_Elab is
-- capture the target and relevant attributes of the original call.
--
-- The diagnostics of the ABE mechanism depend on accurate source locations
- -- to determine the spacial relation of nodes.
+ -- to determine the spatial relation of nodes.
-----------------------------------------
-- Suppression of elaboration warnings --
@@ -590,7 +590,7 @@ package body Sem_Elab is
-- -gnatH legacy elaboration checking mode enabled
--
-- When this switch is in effect, the pre-18.x ABE model becomes
- -- the defacto ABE model. This ammounts to cutting off all entry
+ -- the de facto ABE model. This amounts to cutting off all entry
-- points into the new ABE mechanism, and giving full control to
-- the old ABE mechanism.
--
@@ -1952,6 +1952,18 @@ package body Sem_Elab is
pragma Inline (Compilation_Unit);
-- Return the N_Compilation_Unit node of unit Unit_Id
+ function Elaboration_Phase_Active return Boolean;
+ pragma Inline (Elaboration_Phase_Active);
+ -- Determine whether the elaboration phase of the compilation has started
+
+ procedure Error_Preelaborated_Call (N : Node_Id);
+ -- Give an error or warning for a non-static/non-preelaborable call in a
+ -- preelaborated unit.
+
+ procedure Finalize_All_Data_Structures;
+ pragma Inline (Finalize_All_Data_Structures);
+ -- Destroy all internal data structures
+
function Find_Enclosing_Instance (N : Node_Id) return Node_Id;
pragma Inline (Find_Enclosing_Instance);
-- Find the declaration or body of the nearest expanded instance which
@@ -1972,14 +1984,6 @@ package body Sem_Elab is
-- Return the type of subprogram Subp_Id's first formal parameter. If the
-- subprogram lacks formal parameters, return Empty.
- function Elaboration_Phase_Active return Boolean;
- pragma Inline (Elaboration_Phase_Active);
- -- Determine whether the elaboration phase of the compilation has started
-
- procedure Finalize_All_Data_Structures;
- pragma Inline (Finalize_All_Data_Structures);
- -- Destroy all internal data structures
-
function Has_Body (Pack_Decl : Node_Id) return Boolean;
pragma Inline (Has_Body);
-- Determine whether package declaration Pack_Decl has a corresponding body
@@ -2605,7 +2609,7 @@ package body Sem_Elab is
Par := Parent (Call);
while Present (Par) loop
- if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then
+ if Nkind (Par) in N_Package_Body | N_Package_Declaration then
return Defining_Entity (Par);
elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then
@@ -2954,11 +2958,10 @@ package body Sem_Elab is
-- task objects found in the declarations.
else
- pragma Assert (Nkind_In (Context, N_Block_Statement,
- N_Entry_Body,
- N_Protected_Body,
- N_Subprogram_Body,
- N_Task_Body));
+ pragma Assert
+ (Nkind (Context) in
+ N_Block_Statement | N_Entry_Body | N_Protected_Body |
+ N_Subprogram_Body | N_Task_Body);
Traverse_List
(List => Declarations (Context),
@@ -2981,10 +2984,9 @@ package body Sem_Elab is
-- When the name denotes an array or record component, find the whole
-- object.
- while Nkind_In (Nam, N_Explicit_Dereference,
- N_Indexed_Component,
- N_Selected_Component,
- N_Slice)
+ while Nkind (Nam) in
+ N_Explicit_Dereference | N_Indexed_Component |
+ N_Selected_Component | N_Slice
loop
Nam := Prefix (Nam);
end loop;
@@ -3294,8 +3296,8 @@ package body Sem_Elab is
elsif (Debug_Flag_Underscore_A
or else Restriction_Active
(No_Entry_Calls_In_Elaboration_Code))
- and then Nkind_In (Original_Node (Scen), N_Accept_Statement,
- N_Selective_Accept)
+ and then Nkind (Original_Node (Scen)) in
+ N_Accept_Statement | N_Selective_Accept
then
return Abandon;
@@ -3329,18 +3331,18 @@ package body Sem_Elab is
-- until expansion transforms the node and relocates the contents.
-- Examine these lists in case expansion is disabled.
- elsif Nkind_In (Scen, N_And_Then, N_Or_Else) then
+ elsif Nkind (Scen) in N_And_Then | N_Or_Else then
Traverse_List (Actions (Scen));
- elsif Nkind_In (Scen, N_Elsif_Part, N_Iteration_Scheme) then
+ elsif Nkind (Scen) in N_Elsif_Part | N_Iteration_Scheme then
Traverse_List (Condition_Actions (Scen));
elsif Nkind (Scen) = N_If_Expression then
Traverse_List (Then_Actions (Scen));
Traverse_List (Else_Actions (Scen));
- elsif Nkind_In (Scen, N_Component_Association,
- N_Iterated_Component_Association)
+ elsif Nkind (Scen) in
+ N_Component_Association | N_Iterated_Component_Association
then
Traverse_List (Loop_Actions (Scen));
@@ -3511,8 +3513,7 @@ package body Sem_Elab is
-- contexts because nested calls has not been relocated to their
-- final context.
- if Nkind_In (Par, N_Aspect_Specification,
- N_Generic_Association)
+ if Nkind (Par) in N_Aspect_Specification | N_Generic_Association
then
return True;
@@ -3540,9 +3541,9 @@ package body Sem_Elab is
-- To qualify, the node must appear immediately within a source call
-- which invokes a source target.
- if Nkind_In (Outer_Call, N_Entry_Call_Statement,
- N_Function_Call,
- N_Procedure_Call_Statement)
+ if Nkind (Outer_Call) in N_Entry_Call_Statement
+ | N_Function_Call
+ | N_Procedure_Call_Statement
and then Comes_From_Source (Outer_Call)
then
Outer_Nam := Call_Name (Outer_Call);
@@ -3572,9 +3573,9 @@ package body Sem_Elab is
return
Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
and then not Comes_From_Source (Subp_Decl)
- and then Nkind_In (Context, N_Function_Specification,
- N_Package_Specification,
- N_Procedure_Specification)
+ and then Nkind (Context) in N_Function_Specification
+ | N_Package_Specification
+ | N_Procedure_Specification
and then Present (Generic_Parent (Context));
end Is_Generic_Formal_Subp;
@@ -3594,12 +3595,6 @@ package body Sem_Elab is
if Legacy_Elaboration_Checks then
return;
- -- Nothing to do for ASIS because ABE checks and diagnostics are not
- -- performed in this mode.
-
- elsif ASIS_Mode then
- return;
-
-- Nothing to do when the call is being preanalyzed as the marker will
-- be inserted in the wrong place.
@@ -3614,10 +3609,10 @@ package body Sem_Elab is
-- Nothing to do when the input does not denote a call or a requeue
- elsif not Nkind_In (N, N_Entry_Call_Statement,
- N_Function_Call,
- N_Procedure_Call_Statement,
- N_Requeue_Statement)
+ elsif Nkind (N) not in N_Entry_Call_Statement
+ | N_Function_Call
+ | N_Procedure_Call_Statement
+ | N_Requeue_Statement
then
return;
@@ -3626,7 +3621,7 @@ package body Sem_Elab is
-- elaboration) is in effect.
elsif Debug_Flag_Underscore_E
- and then Nkind_In (N, N_Entry_Call_Statement, N_Requeue_Statement)
+ and then Nkind (N) in N_Entry_Call_Statement | N_Requeue_Statement
then
return;
@@ -3687,6 +3682,11 @@ package body Sem_Elab is
then
return;
+ -- Static expression functions require no ABE processing
+
+ elsif Is_Static_Function (Subp_Id) then
+ return;
+
-- Source calls to source targets are always considered because they
-- reflect the original call graph.
@@ -3737,8 +3737,9 @@ package body Sem_Elab is
(Marker, Find_Enclosing_Level (N) = Declaration_Level);
Set_Is_Dispatching_Call
- (Marker, Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
- and then Present (Controlling_Argument (N)));
+ (Marker,
+ Nkind (N) in N_Function_Call | N_Procedure_Call_Statement
+ and then Present (Controlling_Argument (N)));
Set_Is_Elaboration_Checks_OK_Node
(Marker, Is_Elaboration_Checks_OK_Node (N));
@@ -3751,6 +3752,15 @@ package body Sem_Elab is
Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N));
Set_Target (Marker, Subp_Id);
+ -- Ada 2020 (AI12-0175): Calls to certain functions that are essentially
+ -- unchecked conversions are preelaborable.
+
+ if Ada_Version >= Ada_2020 then
+ Set_Is_Preelaborable_Call (Marker, Is_Preelaborable_Construct (N));
+ else
+ Set_Is_Preelaborable_Call (Marker, False);
+ end if;
+
-- The marker is inserted prior to the original call. This placement has
-- several desirable effects:
@@ -3937,13 +3947,6 @@ package body Sem_Elab is
Finalize_All_Data_Structures;
return;
- -- Nothing to do for ASIS because ABE checks and diagnostics are not
- -- performed in this mode.
-
- elsif ASIS_Mode then
- Finalize_All_Data_Structures;
- return;
-
-- Nothing to do when the elaboration phase of the compiler is not
-- active.
@@ -4532,8 +4535,8 @@ package body Sem_Elab is
-- statement due to expansion activities.
if Nkind (Comp_Unit) = N_Null_Statement
- and then Nkind_In (Original_Node (Comp_Unit), N_Protected_Body,
- N_Task_Body)
+ and then Nkind (Original_Node (Comp_Unit)) in
+ N_Protected_Body | N_Task_Body
then
Comp_Unit := Parent (Comp_Unit);
pragma Assert (Nkind (Comp_Unit) = N_Subunit);
@@ -4549,9 +4552,8 @@ package body Sem_Elab is
-- the instantiated subprogram.
if Nkind (Comp_Unit) = N_Package_Specification
- and then Nkind_In (Original_Node (Parent (Comp_Unit)),
- N_Function_Instantiation,
- N_Procedure_Instantiation)
+ and then Nkind (Original_Node (Parent (Comp_Unit))) in
+ N_Function_Instantiation | N_Procedure_Instantiation
then
Comp_Unit := Parent (Parent (Comp_Unit));
@@ -4891,6 +4893,8 @@ package body Sem_Elab is
(Marker, Elaboration_Checks_OK (Attr_Rep));
Set_Is_Elaboration_Warnings_OK_Node
(Marker, Elaboration_Warnings_OK (Attr_Rep));
+ Set_Is_Preelaborable_Call
+ (Marker, False);
Set_Is_Source_Call
(Marker, Comes_From_Source (Attr));
Set_Is_SPARK_Mode_On_Node
@@ -5684,7 +5688,7 @@ package body Sem_Elab is
-- Ensure that the unit with the target body is elaborated prior to
-- the main unit. The implicit Elaborate[_All] is generated only when
- -- the call has elaboration checks enabled. This behaviour parallels
+ -- the call has elaboration checks enabled. This behavior parallels
-- that of the old ABE mechanism.
if Elaboration_Checks_OK (Call_Rep) then
@@ -6084,7 +6088,7 @@ package body Sem_Elab is
-- Ensure that the unit with the generic body is elaborated prior
-- to the main unit. No implicit pragma has to be generated if the
- -- instantiation has elaboration checks suppressed. This behaviour
+ -- instantiation has elaboration checks suppressed. This behavior
-- parallels that of the old ABE mechanism.
if Elaboration_Checks_OK (Inst_Rep) then
@@ -7024,7 +7028,7 @@ package body Sem_Elab is
-- Enter encapsulators by inspecting their declarations and/or
-- statements.
- if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then
+ if Nkind (Curr) in N_Block_Statement | N_Package_Body then
Enter_Handled_Body (Curr);
elsif Nkind (Curr) = N_Package_Declaration then
@@ -7055,7 +7059,7 @@ package body Sem_Elab is
-- amount of work, but has the beneficial effect of computing
-- the early call regions of all preceding bodies.
- elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then
+ elsif Nkind (Curr) in N_Entry_Body | N_Subprogram_Body then
Start :=
Find_Early_Call_Region
(Body_Decl => Curr,
@@ -7091,9 +7095,9 @@ package body Sem_Elab is
-- visible declarations -> upper level
-- visible declarations -> terminate
- if Nkind_In (Context, N_Package_Specification,
- N_Protected_Definition,
- N_Task_Definition)
+ if Nkind (Context) in N_Package_Specification
+ | N_Protected_Definition
+ | N_Task_Definition
then
Transition_Spec_Declarations (Context, Curr);
@@ -7113,12 +7117,12 @@ package body Sem_Elab is
-- declarations -> corresponding package spec (Elab_Body)
-- declarations -> terminate
- elsif Nkind_In (Context, N_Block_Statement,
- N_Entry_Body,
- N_Package_Body,
- N_Protected_Body,
- N_Subprogram_Body,
- N_Task_Body)
+ elsif Nkind (Context) in N_Block_Statement
+ | N_Entry_Body
+ | N_Package_Body
+ | N_Protected_Body
+ | N_Subprogram_Body
+ | N_Task_Body
then
Transition_Body_Declarations (Context, Curr);
@@ -7423,12 +7427,14 @@ package body Sem_Elab is
-- The search must come from the statements of certain bodies or
-- statements.
- pragma Assert (Nkind_In (Bod, N_Block_Statement,
- N_Entry_Body,
- N_Package_Body,
- N_Protected_Body,
- N_Subprogram_Body,
- N_Task_Body));
+ pragma Assert
+ (Nkind (Bod) in
+ N_Block_Statement |
+ N_Entry_Body |
+ N_Package_Body |
+ N_Protected_Body |
+ N_Subprogram_Body |
+ N_Task_Body);
-- The search must come from the statements of the handled
-- sequence.
@@ -7824,7 +7830,7 @@ package body Sem_Elab is
begin
-- Nothing to do if the pragma is not related to elaboration
- if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then
+ if Prag_Nam not in Name_Elaborate | Name_Elaborate_All then
return;
-- Nothing to do when the pragma is illegal
@@ -7999,7 +8005,7 @@ package body Sem_Elab is
-- body -> spec
if Present (Unit_Id)
- and then Nkind_In (Unit_Id, N_Package_Body, N_Subprogram_Body)
+ and then Nkind (Unit_Id) in N_Package_Body | N_Subprogram_Body
then
Find_Elaboration_Context (Parent (Unit_Id));
@@ -8019,10 +8025,10 @@ package body Sem_Elab is
-- parent spec -> grandparent spec and so on
if Present (Unit_Id)
- and then Nkind_In (Unit_Id, N_Generic_Package_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Package_Declaration,
- N_Subprogram_Declaration)
+ and then Nkind (Unit_Id) in N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Package_Declaration
+ | N_Subprogram_Declaration
then
Find_Elaboration_Context (Parent (Unit_Id));
@@ -8103,12 +8109,12 @@ package body Sem_Elab is
Prag_Nam : Name_Id;
In_State : Processing_In_State)
is
- pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All));
+ pragma Assert (Prag_Nam in Name_Elaborate | Name_Elaborate_All);
begin
-- Nothing to do when the need for prior elaboration came from a
-- partial finalization routine which occurs in an initialization
- -- context. This behaviour parallels that of the old ABE mechanism.
+ -- context. This behavior parallels that of the old ABE mechanism.
if In_State.Within_Partial_Finalization then
return;
@@ -8574,7 +8580,7 @@ package body Sem_Elab is
Req_Nam : Name_Id;
In_State : Processing_In_State)
is
- pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All));
+ pragma Assert (Req_Nam in Name_Elaborate | Name_Elaborate_All);
Main_Id : constant Entity_Id := Main_Unit_Entity;
Unit_Id : constant Entity_Id := Find_Top_Unit (Targ_Id);
@@ -8770,8 +8776,7 @@ package body Sem_Elab is
-- requirement.
if Present (Unit_Prag)
- and then Nam_In (Pragma_Name (Unit_Prag), Name_Elaborate_All,
- Req_Nam)
+ and then Pragma_Name (Unit_Prag) in Name_Elaborate_All | Req_Nam
then
Req_Met := True;
@@ -8851,6 +8856,29 @@ package body Sem_Elab is
return Elaboration_Phase = Active;
end Elaboration_Phase_Active;
+ ------------------------------
+ -- Error_Preelaborated_Call --
+ ------------------------------
+
+ procedure Error_Preelaborated_Call (N : Node_Id) is
+ begin
+ -- This is a warning in GNAT mode allowing such calls to be used in the
+ -- predefined library units with appropriate care.
+
+ Error_Msg_Warn := GNAT_Mode;
+
+ -- Ada 2020 (AI12-0175): Calls to certain functions that are essentially
+ -- unchecked conversions are preelaborable.
+
+ if Ada_Version >= Ada_2020 then
+ Error_Msg_N
+ ("<<non-preelaborable call not allowed in preelaborated unit", N);
+ else
+ Error_Msg_N
+ ("<<non-static call not allowed in preelaborated unit", N);
+ end if;
+ end Error_Preelaborated_Call;
+
----------------------------------
-- Finalize_All_Data_Structures --
----------------------------------
@@ -8877,10 +8905,10 @@ package body Sem_Elab is
Par := N;
while Present (Par) loop
- if Nkind_In (Par, N_Package_Body,
- N_Package_Declaration,
- N_Subprogram_Body,
- N_Subprogram_Declaration)
+ if Nkind (Par) in N_Package_Body
+ | N_Package_Declaration
+ | N_Subprogram_Body
+ | N_Subprogram_Declaration
and then Is_Generic_Instance (Unique_Defining_Entity (Par))
then
return Par;
@@ -8953,10 +8981,10 @@ package body Sem_Elab is
-- but are later relocated in a different context retain their original
-- declaration level.
- if Nkind_In (N, N_Call_Marker,
- N_Function_Instantiation,
- N_Package_Instantiation,
- N_Procedure_Instantiation)
+ if Nkind (N) in N_Call_Marker
+ | N_Function_Instantiation
+ | N_Package_Instantiation
+ | N_Procedure_Instantiation
and then Is_Declaration_Level_Node (N)
then
return Declaration_Level;
@@ -8977,7 +9005,7 @@ package body Sem_Elab is
-- they are always elaborated when the enclosing context is invoked
-- or elaborated.
- elsif Nkind_In (Curr, N_Package_Body, N_Package_Declaration) then
+ elsif Nkind (Curr) in N_Package_Body | N_Package_Declaration then
null;
-- The current construct is a block statement
@@ -9009,9 +9037,8 @@ package body Sem_Elab is
-- The current construct is a declaration-level encapsulator
- elsif Nkind_In (Curr, N_Entry_Body,
- N_Subprogram_Body,
- N_Task_Body)
+ elsif Nkind (Curr) in
+ N_Entry_Body | N_Subprogram_Body | N_Task_Body
then
-- If the traversal came from the handled sequence of statments,
-- then the node cannot possibly appear at any level. This is
@@ -9099,8 +9126,8 @@ package body Sem_Elab is
-- that of the "related instance".
elsif Nkind (N) = N_Package_Declaration
- and then Nkind_In (Orig_N, N_Function_Instantiation,
- N_Procedure_Instantiation)
+ and then Nkind (Orig_N) in
+ N_Function_Instantiation | N_Procedure_Instantiation
and then Nkind (Context) = N_Compilation_Unit
then
return Related_Instance (Defining_Entity (N));
@@ -9111,8 +9138,8 @@ package body Sem_Elab is
elsif Nkind (N) = N_Subunit
and then Nkind (Proper_Body (N)) = N_Null_Statement
- and then Nkind_In (Original_Node (Proper_Body (N)), N_Protected_Body,
- N_Task_Body)
+ and then Nkind (Original_Node (Proper_Body (N))) in
+ N_Protected_Body | N_Task_Body
then
return Defining_Entity (Original_Node (Proper_Body (N)));
@@ -9138,7 +9165,7 @@ package body Sem_Elab is
-- Handle various combinations of concurrent and private types
loop
- if Ekind_In (Typ, E_Protected_Type, E_Task_Type)
+ if Ekind (Typ) in E_Protected_Type | E_Task_Type
and then Present (Anonymous_Object (Typ))
then
Typ := Anonymous_Object (Typ);
@@ -9216,10 +9243,11 @@ package body Sem_Elab is
Target_Decl : Node_Id;
Target_Body : Node_Id) return Boolean
is
+ Spec : Node_Id;
begin
-- Avoid cascaded errors if there were previous serious infractions.
-- As a result the scenario will not be treated as a guaranteed ABE.
- -- This behaviour parallels that of the old ABE mechanism.
+ -- This behavior parallels that of the old ABE mechanism.
if Serious_Errors_Detected > 0 then
return False;
@@ -9236,12 +9264,20 @@ package body Sem_Elab is
return Earlier_In_Extended_Unit (N, Target_Body);
-- Otherwise the body has not been encountered yet. The scenario
- -- is a guaranteed ABE since the body will appear later. It is
- -- assumed that the caller has already ensured that the scenario
- -- is ABE-safe because optional bodies are not considered here.
+ -- is a guaranteed ABE since the body will appear later, unless
+ -- this is a null specification, which can occur if expansion is
+ -- disabled (e.g. -gnatc or GNATprove mode). It is assumed that
+ -- the caller has already ensured that the scenario is ABE-safe
+ -- because optional bodies are not considered here.
else
- return True;
+ Spec := Specification (Target_Decl);
+
+ if Nkind (Spec) /= N_Procedure_Specification
+ or else not Null_Present (Spec)
+ then
+ return True;
+ end if;
end if;
end if;
@@ -9544,7 +9580,7 @@ package body Sem_Elab is
Error_Msg_N ("\Program_Error will be raised at run time", Call);
end if;
- -- Mark the call as a guarnateed ABE
+ -- Mark the call as a guaranteed ABE
Set_Is_Known_Guaranteed_ABE (Call);
@@ -10872,13 +10908,10 @@ package body Sem_Elab is
elsif Is_Task_Type (Id) then
Rec := Create_Task_Rep (Id);
- elsif Ekind_In (Id, E_Constant, E_Variable) then
+ elsif Ekind (Id) in E_Constant | E_Variable then
Rec := Create_Variable_Rep (Id);
- elsif Ekind_In (Id, E_Entry,
- E_Function,
- E_Operator,
- E_Procedure)
+ elsif Ekind (Id) in E_Entry | E_Function | E_Operator | E_Procedure
then
Rec := Create_Subprogram_Rep (Id);
@@ -11907,6 +11940,7 @@ package body Sem_Elab is
Set_Is_Elaboration_Checks_OK_Node (Marker, False);
Set_Is_Elaboration_Warnings_OK_Node (Marker, False);
Set_Is_Ignored_Ghost_Node (Marker, False);
+ Set_Is_Preelaborable_Call (Marker, False);
Set_Is_Source_Call (Marker, False);
Set_Is_SPARK_Mode_On_Node (Marker, False);
@@ -11946,6 +11980,7 @@ package body Sem_Elab is
Set_Is_Elaboration_Checks_OK_Node (Marker, False);
Set_Is_Elaboration_Warnings_OK_Node (Marker, False);
Set_Is_Ignored_Ghost_Node (Marker, False);
+ Set_Is_Preelaborable_Call (Marker, False);
Set_Is_Source_Call (Marker, False);
Set_Is_SPARK_Mode_On_Node (Marker, False);
@@ -12053,14 +12088,13 @@ package body Sem_Elab is
-- The main unit is a body
- if Ekind_In (Main_Unit_Id, E_Package_Body,
- E_Subprogram_Body)
+ if Ekind (Main_Unit_Id) in E_Package_Body | E_Subprogram_Body
then
return In_Body;
-- The main unit is a stand-alone subprogram body
- elsif Ekind_In (Main_Unit_Id, E_Function, E_Procedure)
+ elsif Ekind (Main_Unit_Id) in E_Function | E_Procedure
and then Nkind (Unit_Declaration_Node (Main_Unit_Id)) =
N_Subprogram_Body
then
@@ -12075,8 +12109,7 @@ package body Sem_Elab is
-- Otherwise the node is in the complementary unit of the main
-- unit. The main unit is a body, the node is in the spec.
- elsif Ekind_In (Main_Unit_Id, E_Package_Body,
- E_Subprogram_Body)
+ elsif Ekind (Main_Unit_Id) in E_Package_Body | E_Subprogram_Body
then
return In_Spec;
@@ -12301,8 +12334,8 @@ package body Sem_Elab is
-- Protected type
- elsif Nkind_In (Decl, N_Protected_Type_Declaration,
- N_Single_Protected_Declaration)
+ elsif Nkind (Decl) in N_Protected_Type_Declaration
+ | N_Single_Protected_Declaration
then
Process_Protected_Type_Declaration
(Prot_Decl => Decl,
@@ -12310,8 +12343,8 @@ package body Sem_Elab is
-- Subprogram or entry
- elsif Nkind_In (Decl, N_Entry_Declaration,
- N_Subprogram_Declaration)
+ elsif Nkind (Decl) in N_Entry_Declaration
+ | N_Subprogram_Declaration
then
Process_Subprogram_Declaration
(Subp_Decl => Decl,
@@ -12335,8 +12368,8 @@ package body Sem_Elab is
-- Task type
- elsif Nkind_In (Decl, N_Single_Task_Declaration,
- N_Task_Type_Declaration)
+ elsif Nkind (Decl) in N_Single_Task_Declaration
+ | N_Task_Type_Declaration
then
Process_Task_Type_Declaration
(Task_Decl => Decl,
@@ -12456,7 +12489,7 @@ package body Sem_Elab is
-- Nothing to do for an abstract subprogram because it has no body to
-- examine.
- elsif Ekind_In (Subp_Id, E_Function, E_Procedure)
+ elsif Ekind (Subp_Id) in E_Function | E_Procedure
and then Is_Abstract_Subprogram (Subp_Id)
then
return;
@@ -12472,7 +12505,7 @@ package body Sem_Elab is
-- DFS traversal into its barrier function and body.
if In_Extended_Main_Code_Unit (Subp_Id) then
- if Ekind_In (Subp_Id, E_Entry, E_Entry_Family, E_Procedure) then
+ if Ekind (Subp_Id) in E_Entry | E_Entry_Family | E_Procedure then
Traverse_Invocation_Body
(N => Barrier_Body_Declaration (Subp_Rep),
In_State => In_State);
@@ -12852,8 +12885,8 @@ package body Sem_Elab is
-- Process the entries of the task type because they represent valid
-- entry points into the task body.
- if Nkind_In (Task_Decl, N_Single_Task_Declaration,
- N_Task_Type_Declaration)
+ if Nkind (Task_Decl) in N_Single_Task_Declaration
+ | N_Task_Type_Declaration
then
Task_Def := Task_Definition (Task_Decl);
@@ -13151,10 +13184,8 @@ package body Sem_Elab is
-- Entry, operator, or subprogram call. This case must come last
-- because most invocations above are variations of this case.
- elsif Ekind_In (Targ_Id, E_Entry,
- E_Function,
- E_Operator,
- E_Procedure)
+ elsif Ekind (Targ_Id) in
+ E_Entry | E_Function | E_Operator | E_Procedure
then
Extra := Empty;
Kind := Call;
@@ -13771,6 +13802,11 @@ package body Sem_Elab is
if not Is_Source_Call (Call) then
return;
+ -- Nothing to do when the call is preelaborable by definition
+
+ elsif Is_Preelaborable_Call (Call) then
+ return;
+
-- Library-level calls are always considered because they are part of
-- the associated unit's elaboration actions.
@@ -13792,13 +13828,10 @@ package body Sem_Elab is
return;
end if;
- -- The call appears within a preelaborated unit. Emit a warning only
- -- for internal uses, otherwise this is an error.
+ -- If the call appears within a preelaborated unit, give an error
if In_Preelaborated_Context (Call) then
- Error_Msg_Warn := GNAT_Mode;
- Error_Msg_N
- ("<<non-static call not allowed in preelaborated unit", Call);
+ Error_Preelaborated_Call (Call);
end if;
end Check_Preelaborated_Call;
@@ -13826,7 +13859,7 @@ package body Sem_Elab is
-- be on another machine.
if Ekind (Body_Id) = E_Package_Body
- and then Ekind_In (Spec_Id, E_Generic_Package, E_Package)
+ and then Is_Package_Or_Generic_Package (Spec_Id)
and then (Is_Remote_Call_Interface (Spec_Id)
or else Is_Remote_Types (Spec_Id))
then
@@ -14030,12 +14063,6 @@ package body Sem_Elab is
if Legacy_Elaboration_Checks then
return;
- -- Nothing to do for ASIS because ABE checks and diagnostics are not
- -- performed in this mode.
-
- elsif ASIS_Mode then
- return;
-
-- Nothing to do when the scenario is being preanalyzed
elsif Preanalysis_Active then
@@ -14423,9 +14450,7 @@ package body Sem_Elab is
begin
-- An abstract subprogram does not have a body
- if Ekind_In (Subp_Id, E_Function,
- E_Operator,
- E_Procedure)
+ if Ekind (Subp_Id) in E_Function | E_Operator | E_Procedure
and then Is_Abstract_Subprogram (Subp_Id)
then
return True;
@@ -14473,9 +14498,8 @@ package body Sem_Elab is
Formal_Id : Entity_Id;
begin
- pragma Assert (Nam_In (Subp_Nam, Name_Adjust,
- Name_Finalize,
- Name_Initialize));
+ pragma Assert
+ (Subp_Nam in Name_Adjust | Name_Finalize | Name_Initialize);
-- To qualify, the subprogram must denote a source procedure with
-- name Adjust, Finalize, or Initialize where the sole formal is
@@ -14663,7 +14687,7 @@ package body Sem_Elab is
-- protected type.
return
- Ekind_In (Id, E_Function, E_Procedure)
+ Ekind (Id) in E_Function | E_Procedure
and then Is_Protected_Type (Non_Private_View (Scope (Id)));
end Is_Protected_Subp;
@@ -14677,7 +14701,7 @@ package body Sem_Elab is
-- Protected_Subprogram set.
return
- Ekind_In (Id, E_Function, E_Procedure)
+ Ekind (Id) in E_Function | E_Procedure
and then Present (Protected_Subprogram (Id));
end Is_Protected_Body_Subp;
@@ -14729,7 +14753,7 @@ package body Sem_Elab is
-- is hidden within an anonymous package, and is a generic instance.
return
- Ekind_In (Id, E_Function, E_Procedure)
+ Ekind (Id) in E_Function | E_Procedure
and then Is_Hidden (Id)
and then Is_Generic_Instance (Id);
end Is_Subprogram_Inst;
@@ -14798,7 +14822,7 @@ package body Sem_Elab is
-- The attribute name must be one of the 'Access forms. Note that
-- 'Unchecked_Access cannot apply to a subprogram.
- and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access);
+ and then Nam in Name_Access | Name_Unrestricted_Access;
end Is_Suitable_Access_Taken;
----------------------
@@ -14926,7 +14950,7 @@ package body Sem_Elab is
return False;
-- Assignments are ignored in GNAT mode on the assumption that
- -- they are ABE-safe. This behaviour parallels that of the old
+ -- they are ABE-safe. This behavior parallels that of the old
-- ABE mechanism.
elsif GNAT_Mode then
@@ -15832,10 +15856,10 @@ package body Sem_Elab is
-- Bodies
- if Nkind_In (N, N_Package_Body,
- N_Protected_Body,
- N_Subprogram_Body,
- N_Task_Body)
+ if Nkind (N) in N_Package_Body
+ | N_Protected_Body
+ | N_Subprogram_Body
+ | N_Task_Body
then
Spec_Id := Corresponding_Spec (N);
@@ -15855,13 +15879,13 @@ package body Sem_Elab is
-- Declarations
- elsif Nkind_In (N, N_Entry_Declaration,
- N_Generic_Package_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Package_Declaration,
- N_Protected_Type_Declaration,
- N_Subprogram_Declaration,
- N_Task_Type_Declaration)
+ elsif Nkind (N) in N_Entry_Declaration
+ | N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Package_Declaration
+ | N_Protected_Type_Declaration
+ | N_Subprogram_Declaration
+ | N_Task_Type_Declaration
then
Spec_Decl := N;
@@ -15935,12 +15959,12 @@ package body Sem_Elab is
begin
return
- Nkind_In (Decl, N_Generic_Package_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Package_Declaration,
- N_Protected_Type_Declaration,
- N_Subprogram_Declaration,
- N_Task_Type_Declaration)
+ Nkind (Decl) in N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Package_Declaration
+ | N_Protected_Type_Declaration
+ | N_Subprogram_Declaration
+ | N_Task_Type_Declaration
and then Present (Corresponding_Body (Decl))
and then Nkind (Parent (Unit_Declaration_Node
(Corresponding_Body (Decl)))) = N_Subunit;
@@ -16809,8 +16833,8 @@ package body Sem_Elab is
if Nkind (Decl) = N_Subprogram_Body then
Body_Acts_As_Spec := True;
- elsif Nkind_In (Decl, N_Subprogram_Declaration,
- N_Subprogram_Body_Stub)
+ elsif Nkind (Decl) in
+ N_Subprogram_Declaration | N_Subprogram_Body_Stub
or else Inst_Case
then
Body_Acts_As_Spec := False;
@@ -17486,8 +17510,7 @@ package body Sem_Elab is
P := Parent (N);
while Present (P) loop
- if Nkind_In (P, N_Parameter_Specification,
- N_Component_Declaration)
+ if Nkind (P) in N_Parameter_Specification | N_Component_Declaration
then
return;
@@ -17525,17 +17548,17 @@ package body Sem_Elab is
-- Complain if ref that comes from source in preelaborated unit
-- and we are not inside a subprogram (i.e. we are in elab code).
+ -- Ada 2020 (AI12-0175): Calls to certain functions that are
+ -- essentially unchecked conversions are preelaborable.
+
if Comes_From_Source (N)
and then In_Preelaborated_Unit
and then not In_Inlined_Body
and then Nkind (N) /= N_Attribute_Reference
+ and then not (Ada_Version >= Ada_2020
+ and then Is_Preelaborable_Construct (N))
then
- -- This is a warning in GNAT mode allowing such calls to be
- -- used in the predefined library with appropriate care.
-
- Error_Msg_Warn := GNAT_Mode;
- Error_Msg_N
- ("<<non-static call not allowed in preelaborated unit", N);
+ Error_Preelaborated_Call (N);
return;
end if;
@@ -17582,8 +17605,8 @@ package body Sem_Elab is
-- Filter out case of default expressions, where we do not
-- do the check at this stage.
- if Nkind_In (P, N_Parameter_Specification,
- N_Component_Declaration)
+ if Nkind (P) in
+ N_Parameter_Specification | N_Component_Declaration
then
return;
end if;
@@ -17594,10 +17617,10 @@ package body Sem_Elab is
if Nkind (P) = N_Protected_Body then
return;
- elsif Nkind_In (P, N_Subprogram_Body,
- N_Task_Body,
- N_Block_Statement,
- N_Entry_Body)
+ elsif Nkind (P) in N_Subprogram_Body
+ | N_Task_Body
+ | N_Block_Statement
+ | N_Entry_Body
then
if L = Declarations (P) then
exit;
@@ -17820,10 +17843,7 @@ package body Sem_Elab is
-- then there is nothing to do (we do not know what is being assigned),
-- but otherwise this is an assignment to the prefix.
- if Nkind_In (N, N_Indexed_Component,
- N_Selected_Component,
- N_Slice)
- then
+ if Nkind (N) in N_Indexed_Component | N_Selected_Component | N_Slice then
if not Is_Access_Type (Etype (Prefix (N))) then
Check_Elab_Assign (Prefix (N));
end if;
@@ -18248,9 +18268,9 @@ package body Sem_Elab is
-- If not function or procedure call, instantiation, or 'Access, then
-- ignore call (this happens in some error cases and rewriting cases).
- elsif not Nkind_In (N, N_Attribute_Reference,
- N_Function_Call,
- N_Procedure_Call_Statement)
+ elsif Nkind (N) not in N_Attribute_Reference
+ | N_Function_Call
+ | N_Procedure_Call_Statement
and then not Inst_Case
then
return;
@@ -18350,8 +18370,8 @@ package body Sem_Elab is
-- code, do not trace past an accept statement, because the rendez-
-- vous will happen after elaboration.
- if Nkind_In (Original_Node (N), N_Accept_Statement,
- N_Selective_Accept)
+ if Nkind (Original_Node (N)) in
+ N_Accept_Statement | N_Selective_Accept
and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code)
then
return Abandon;
@@ -18384,8 +18404,8 @@ package body Sem_Elab is
elsif not Debug_Flag_Dot_UU
and then Nkind (N) = N_Attribute_Reference
- and then Nam_In (Attribute_Name (N), Name_Access,
- Name_Unrestricted_Access)
+ and then
+ Attribute_Name (N) in Name_Access | Name_Unrestricted_Access
and then Is_Entity_Name (Prefix (N))
and then Is_Subprogram (Entity (Prefix (N)))
then
@@ -18466,7 +18486,7 @@ package body Sem_Elab is
Sbody := Unit_Declaration_Node (E);
- if not Nkind_In (Sbody, N_Subprogram_Body, N_Package_Body) then
+ if Nkind (Sbody) not in N_Subprogram_Body | N_Package_Body then
Ebody := Corresponding_Body (Sbody);
if No (Ebody) then
@@ -18560,7 +18580,7 @@ package body Sem_Elab is
-- Check we have an If statement or a null statement (happens
-- when the If has been expanded to be True).
- exit when not Nkind_In (P, N_If_Statement, N_Null_Statement);
+ exit when Nkind (P) not in N_If_Statement | N_Null_Statement;
-- Our special case will be indicated either by the pragma
-- coming from an aspect ...
@@ -18721,9 +18741,9 @@ package body Sem_Elab is
-- A rather specific check. For Finalize/Adjust/Initialize, if
-- the type has Warnings_Off set, suppress the warning.
- if Nam_In (Chars (E), Name_Adjust,
- Name_Finalize,
- Name_Initialize)
+ if Chars (E) in Name_Adjust
+ | Name_Finalize
+ | Name_Initialize
and then Present (First_Formal (E))
then
declare
@@ -18813,7 +18833,7 @@ package body Sem_Elab is
Comp := First_Component (Typ);
while Present (Comp) loop
Add_Task_Proc (Etype (Comp));
- Comp := Next_Component (Comp);
+ Next_Component (Comp);
end loop;
end if;
@@ -19341,7 +19361,7 @@ package body Sem_Elab is
function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is
begin
- return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
+ return Nkind (N) in N_Function_Call | N_Procedure_Call_Statement
-- Always return False if debug flag -gnatd.G is set
@@ -19508,7 +19528,7 @@ package body Sem_Elab is
S1 := Scop1;
while S1 /= Standard_Standard
and then not Is_Compilation_Unit (S1)
- and then Ekind_In (S1, E_Package, E_Protected_Type, E_Block)
+ and then Ekind (S1) in E_Package | E_Protected_Type | E_Block
loop
S1 := Scope (S1);
end loop;
@@ -19518,7 +19538,7 @@ package body Sem_Elab is
S2 := Scop2;
while S2 /= Standard_Standard
and then not Is_Compilation_Unit (S2)
- and then Ekind_In (S2, E_Package, E_Protected_Type, E_Block)
+ and then Ekind (S2) in E_Package | E_Protected_Type | E_Block
loop
S2 := Scope (S2);
end loop;
@@ -19643,7 +19663,7 @@ package body Sem_Elab is
-- Check for case of body entity
-- Why is the check for E_Void needed???
- if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then
+ if Ekind (E) in E_Void | E_Subprogram_Body | E_Package_Body then
Decl := E;
loop
diff --git a/gcc/ada/sem_elab.ads b/gcc/ada/sem_elab.ads
index f47d525..a703a8a 100644
--- a/gcc/ada/sem_elab.ads
+++ b/gcc/ada/sem_elab.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb
index 9fd1f6b..d693a8d 100644
--- a/gcc/ada/sem_elim.adb
+++ b/gcc/ada/sem_elim.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -428,7 +428,7 @@ package body Sem_Elim is
-- Check for case of subprogram
- elsif Ekind_In (E, E_Function, E_Procedure) then
+ elsif Ekind (E) in E_Function | E_Procedure then
-- If Source_Location present, then see if it matches
diff --git a/gcc/ada/sem_elim.ads b/gcc/ada/sem_elim.ads
index 741a1f8..cb1bf8b 100644
--- a/gcc/ada/sem_elim.ads
+++ b/gcc/ada/sem_elim.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index a082847..8c13abc 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -45,6 +45,7 @@ with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Elab; use Sem_Elab;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Type; use Sem_Type;
@@ -131,6 +132,11 @@ package body Sem_Eval is
-- Range membership may either be statically known to be in range or out
-- of range, or not statically known. Used for Test_In_Range below.
+ Checking_For_Potentially_Static_Expression : Boolean := False;
+ -- Global flag that is set True during Analyze_Static_Expression_Function
+ -- in order to verify that the result expression of a static expression
+ -- function is a potentially static function (see RM202x 6.8(5.3)).
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -166,6 +172,9 @@ package body Sem_Eval is
-- discrete, real, or string type and must be a compile-time-known value
-- (it is an error to make the call if these conditions are not met).
+ procedure Eval_Intrinsic_Call (N : Node_Id; E : Entity_Id);
+ -- Evaluate a call N to an intrinsic subprogram E.
+
function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
-- Check whether an arithmetic operation with universal operands which is a
-- rewritten function call with an explicit scope indication is ambiguous:
@@ -174,6 +183,22 @@ package body Sem_Eval is
-- (e.g. in the expression of a type conversion). If ambiguous, emit an
-- error and return Empty, else return the result type of the operator.
+ procedure Fold_Dummy (N : Node_Id; Typ : Entity_Id);
+ -- Rewrite N as a constant dummy value in the relevant type if possible.
+
+ procedure Fold_Shift
+ (N : Node_Id;
+ Left : Node_Id;
+ Right : Node_Id;
+ Op : Node_Kind;
+ Static : Boolean := False;
+ Check_Elab : Boolean := False);
+ -- Rewrite N as the result of evaluating Left <shift op> Right if possible.
+ -- Op represents the shift operation.
+ -- Static indicates whether the resulting node should be marked static.
+ -- Check_Elab indicates whether checks for elaboration calls should be
+ -- inserted when relevant.
+
function From_Bits (B : Bits; T : Entity_Id) return Uint;
-- Converts a bit string of length B'Length to a Uint value to be used for
-- a target of type T, which is a modular type. This procedure includes the
@@ -324,8 +349,9 @@ package body Sem_Eval is
-----------------------------------------------
procedure Check_Expression_Against_Static_Predicate
- (Expr : Node_Id;
- Typ : Entity_Id)
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Static_Failure_Is_Error : Boolean := False)
is
begin
-- Nothing to do if expression is not known at compile time, or the
@@ -383,18 +409,28 @@ package body Sem_Eval is
-- Here we know that the predicate will fail
-- Special case of static expression failing a predicate (other than one
- -- that was explicitly specified with a Dynamic_Predicate aspect). This
- -- is the case where the expression is no longer considered static.
+ -- that was explicitly specified with a Dynamic_Predicate aspect). If
+ -- the expression comes from a qualified_expression or type_conversion
+ -- this is an error (Static_Failure_Is_Error); otherwise we only issue
+ -- a warning and the expression is no longer considered static.
if Is_Static_Expression (Expr)
and then not Has_Dynamic_Predicate_Aspect (Typ)
then
- Error_Msg_NE
- ("??static expression fails static predicate check on &",
- Expr, Typ);
- Error_Msg_N
- ("\??expression is no longer considered static", Expr);
- Set_Is_Static_Expression (Expr, False);
+ if Static_Failure_Is_Error then
+ Error_Msg_NE
+ ("static expression fails static predicate check on &",
+ Expr, Typ);
+
+ else
+ Error_Msg_NE
+ ("??static expression fails static predicate check on &",
+ Expr, Typ);
+ Error_Msg_N
+ ("\??expression is no longer considered static", Expr);
+
+ Set_Is_Static_Expression (Expr, False);
+ end if;
-- In all other cases, this is just a warning that a test will fail.
-- It does not matter if the expression is static or not, or if the
@@ -403,6 +439,15 @@ package body Sem_Eval is
else
Error_Msg_NE
("??expression fails predicate check on &", Expr, Typ);
+
+ -- Force a check here, which is potentially a redundant check, but
+ -- this ensures a check will be done in cases where the expression
+ -- is folded, and since this is definitely a failure, extra checks
+ -- are OK.
+
+ Insert_Action (Expr,
+ Make_Predicate_Check
+ (Typ, Duplicate_Subexpr (Expr)), Suppress => All_Checks);
end if;
end Check_Expression_Against_Static_Predicate;
@@ -575,14 +620,14 @@ package body Sem_Eval is
-- mode since the actual target compiler may provide a wider
-- range.
- if CodePeer_Mode and then T = RTE (RE_Priority) then
+ if CodePeer_Mode and then Is_RTE (T, RE_Priority) then
Set_Do_Range_Check (N, False);
-- Determine if the out-of-range violation constitutes a warning
-- or an error based on context, according to RM 4.9 (34/3).
- elsif Nkind_In (Original_Node (N), N_Type_Conversion,
- N_Qualified_Expression)
+ elsif Nkind (Original_Node (N)) in
+ N_Type_Conversion | N_Qualified_Expression
and then Comes_From_Source (Original_Node (N))
then
Apply_Compile_Time_Constraint_Error
@@ -619,6 +664,15 @@ package body Sem_Eval is
end if;
end Check_String_Literal_Length;
+ --------------------------------------------
+ -- Checking_Potentially_Static_Expression --
+ --------------------------------------------
+
+ function Checking_Potentially_Static_Expression return Boolean is
+ begin
+ return Checking_For_Potentially_Static_Expression;
+ end Checking_Potentially_Static_Expression;
+
--------------------
-- Choice_Matches --
--------------------
@@ -904,7 +958,7 @@ package body Sem_Eval is
-- Fixup only required for First/Last attribute reference
if Nkind (N) = N_Attribute_Reference
- and then Nam_In (Attribute_Name (N), Name_First, Name_Last)
+ and then Attribute_Name (N) in Name_First | Name_Last
then
Xtyp := Etype (Prefix (N));
@@ -954,7 +1008,7 @@ package body Sem_Eval is
Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
for J in 2 .. Subs loop
- Indx := Next_Index (Indx);
+ Next_Index (Indx);
end loop;
end if;
@@ -981,7 +1035,7 @@ package body Sem_Eval is
(Is_Known_Valid (Entity (Opnd))
or else Ekind (Entity (Opnd)) = E_In_Parameter
or else
- (Ekind (Entity (Opnd)) in Object_Kind
+ (Is_Object (Entity (Opnd))
and then Present (Current_Value (Entity (Opnd))))))
or else Is_OK_Static_Expression (Opnd);
end Is_Known_Valid_Operand;
@@ -1057,8 +1111,8 @@ package body Sem_Eval is
-- Values are the same if they refer to the same entity and the
-- entity is nonvolatile.
- elsif Nkind_In (Lf, N_Identifier, N_Expanded_Name)
- and then Nkind_In (Rf, N_Identifier, N_Expanded_Name)
+ elsif Nkind (Lf) in N_Identifier | N_Expanded_Name
+ and then Nkind (Rf) in N_Identifier | N_Expanded_Name
and then Entity (Lf) = Entity (Rf)
-- If the entity is a discriminant, the two expressions may be
@@ -1100,9 +1154,9 @@ package body Sem_Eval is
elsif Nkind (Lf) = N_Attribute_Reference
and then Attribute_Name (Lf) = Attribute_Name (Rf)
- and then Nam_In (Attribute_Name (Lf), Name_First, Name_Last)
- and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name)
- and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name)
+ and then Attribute_Name (Lf) in Name_First | Name_Last
+ and then Nkind (Prefix (Lf)) in N_Identifier | N_Expanded_Name
+ and then Nkind (Prefix (Rf)) in N_Identifier | N_Expanded_Name
and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
then
@@ -1795,11 +1849,8 @@ package body Sem_Eval is
-- Other literals and NULL are known at compile time
- elsif
- Nkind_In (K, N_Character_Literal,
- N_Real_Literal,
- N_String_Literal,
- N_Null)
+ elsif K in
+ N_Character_Literal | N_Real_Literal | N_String_Literal | N_Null
then
return True;
end if;
@@ -1814,6 +1865,13 @@ package body Sem_Eval is
exception
when others =>
+ -- With debug flag K we will get an exception unless an error has
+ -- already occurred (useful for debugging).
+
+ if Debug_Flag_K then
+ Check_Error_Detected;
+ end if;
+
return False;
end Compile_Time_Known_Value;
@@ -2176,9 +2234,8 @@ package body Sem_Eval is
-- Only the latter case is handled here, predefined operators are
-- constant-folded elsewhere.
- -- If the function is itself inherited (see 7423-001) the literal of
- -- the parent type must be explicitly converted to the return type
- -- of the function.
+ -- If the function is itself inherited the literal of the parent type must
+ -- be explicitly converted to the return type of the function.
procedure Eval_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
@@ -2204,6 +2261,23 @@ package body Sem_Eval is
Resolve (N, Typ);
end if;
+
+ elsif Nkind (N) = N_Function_Call
+ and then Is_Entity_Name (Name (N))
+ and then Is_Intrinsic_Subprogram (Entity (Name (N)))
+ then
+ Eval_Intrinsic_Call (N, Entity (Name (N)));
+
+ -- Ada 202x (AI12-0075): If checking for potentially static expressions
+ -- is enabled and we have a call to a static function, substitute a
+ -- static value for the call, to allow folding the expression. This
+ -- supports checking the requirement of RM 6.8(5.3/5) in
+ -- Analyze_Expression_Function.
+
+ elsif Checking_Potentially_Static_Expression
+ and then Is_Static_Function_Call (N)
+ then
+ Fold_Dummy (N, Typ);
end if;
end Eval_Call;
@@ -2484,6 +2558,18 @@ package body Sem_Eval is
return;
end if;
+
+ -- Ada 202x (AI12-0075): If checking for potentially static expressions
+ -- is enabled and we have a reference to a formal parameter of mode in,
+ -- substitute a static value for the reference, to allow folding the
+ -- expression. This supports checking the requirement of RM 6.8(5.3/5)
+ -- in Analyze_Expression_Function.
+
+ elsif Ekind (Def_Id) = E_In_Parameter
+ and then Checking_Potentially_Static_Expression
+ and then Is_Static_Function (Scope (Def_Id))
+ then
+ Fold_Dummy (N, Etype (Def_Id));
end if;
-- Fall through if the name is not static
@@ -2605,7 +2691,7 @@ package body Sem_Eval is
-- Similarly if the indexed component appears as the prefix of an
-- attribute we don't want to evaluate it, because at least for
- -- some cases of attributes we need the identify (e.g. Access, Size)
+ -- some cases of attributes we need the identify (e.g. Access, Size).
elsif Nkind (Parent (N)) = N_Attribute_Reference then
return;
@@ -2741,11 +2827,11 @@ package body Sem_Eval is
-- so we can safely ignore these cases.
return
- Nkind_In (Context, N_Attribute_Definition_Clause,
- N_Attribute_Reference,
- N_Modular_Type_Definition,
- N_Number_Declaration,
- N_Signed_Integer_Type_Definition);
+ Nkind (Context) in N_Attribute_Definition_Clause
+ | N_Attribute_Reference
+ | N_Modular_Type_Definition
+ | N_Number_Declaration
+ | N_Signed_Integer_Type_Definition;
end In_Any_Integer_Context;
-- Local variables
@@ -2768,10 +2854,10 @@ package body Sem_Eval is
-- Check_Non_Static_Context on an expanded literal may lead to spurious
-- and misleading warnings.
- if (Nkind_In (Par, N_Case_Expression_Alternative, N_If_Expression)
- or else Nkind (Parent (N)) not in N_Subexpr)
- and then (not Nkind_In (Par, N_Case_Expression_Alternative,
- N_If_Expression)
+ if (Nkind (Par) in N_Case_Expression_Alternative | N_If_Expression
+ or else Nkind (Par) not in N_Subexpr)
+ and then (Nkind (Par) not in N_Case_Expression_Alternative
+ | N_If_Expression
or else Comes_From_Source (N))
and then not In_Any_Integer_Context (Par)
then
@@ -2787,6 +2873,80 @@ package body Sem_Eval is
end if;
end Eval_Integer_Literal;
+ -------------------------
+ -- Eval_Intrinsic_Call --
+ -------------------------
+
+ procedure Eval_Intrinsic_Call (N : Node_Id; E : Entity_Id) is
+
+ procedure Eval_Shift (N : Node_Id; E : Entity_Id; Op : Node_Kind);
+ -- Evaluate an intrinsic shift call N on the given subprogram E.
+ -- Op is the kind for the shift node.
+
+ ----------------
+ -- Eval_Shift --
+ ----------------
+
+ procedure Eval_Shift (N : Node_Id; E : Entity_Id; Op : Node_Kind) is
+ Left : constant Node_Id := First_Actual (N);
+ Right : constant Node_Id := Next_Actual (Left);
+ Static : constant Boolean := Is_Static_Function (E);
+
+ begin
+ if Static then
+ if Checking_Potentially_Static_Expression then
+ Fold_Dummy (N, Etype (N));
+ return;
+ end if;
+ end if;
+
+ Fold_Shift
+ (N, Left, Right, Op, Static => Static, Check_Elab => not Static);
+ end Eval_Shift;
+
+ Nam : Name_Id;
+
+ begin
+ -- Nothing to do if the intrinsic is handled by the back end.
+
+ if Present (Interface_Name (E)) then
+ return;
+ end if;
+
+ -- Intrinsic calls as part of a static function is a language extension.
+
+ if Checking_Potentially_Static_Expression
+ and then not Extensions_Allowed
+ then
+ return;
+ end if;
+
+ -- If we have a renaming, expand the call to the original operation,
+ -- which must itself be intrinsic, since renaming requires matching
+ -- conventions and this has already been checked.
+
+ if Present (Alias (E)) then
+ Eval_Intrinsic_Call (N, Alias (E));
+ return;
+ end if;
+
+ -- If the intrinsic subprogram is generic, gets its original name
+
+ if Present (Parent (E))
+ and then Present (Generic_Parent (Parent (E)))
+ then
+ Nam := Chars (Generic_Parent (Parent (E)));
+ else
+ Nam := Chars (E);
+ end if;
+
+ case Nam is
+ when Name_Shift_Left => Eval_Shift (N, E, N_Op_Shift_Left);
+ when Name_Shift_Right => Eval_Shift (N, E, N_Op_Shift_Right);
+ when others => null;
+ end case;
+ end Eval_Intrinsic_Call;
+
---------------------
-- Eval_Logical_Op --
---------------------
@@ -2826,7 +2986,9 @@ package body Sem_Eval is
To_Bits (Right_Int, Right_Bits);
-- Note: should really be able to use array ops instead of
- -- these loops, but they weren't working at the time ???
+ -- these loops, but they break the build with a cryptic error
+ -- during the bind of gnat1 likely due to a wrong computation
+ -- of a date or checksum.
if Nkind (N) = N_Op_And then
for J in Left_Bits'Range loop
@@ -3106,7 +3268,7 @@ package body Sem_Eval is
-------------------------------
-- A qualified expression is potentially static if its subtype mark denotes
- -- a static subtype and its expression is potentially static (RM 4.9 (11)).
+ -- a static subtype and its expression is potentially static (RM 4.9 (10)).
procedure Eval_Qualified_Expression (N : Node_Id) is
Operand : constant Node_Id := Expression (N);
@@ -3129,7 +3291,7 @@ package body Sem_Eval is
then
Check_Non_Static_Context (Operand);
- -- If operand is known to raise constraint_error, set the flag on the
+ -- If operand is known to raise Constraint_Error, set the flag on the
-- expression so it does not get optimized away.
if Nkind (Operand) = N_Raise_Constraint_Error then
@@ -3137,6 +3299,14 @@ package body Sem_Eval is
end if;
return;
+
+ -- Also return if a semantic error has been posted on the node, as we
+ -- don't want to fold in that case (for GNATprove, the node might lead
+ -- to Constraint_Error but won't have been replaced with a raise node
+ -- or marked as raising CE).
+
+ elsif Error_Posted (N) then
+ return;
end if;
-- If not foldable we are done
@@ -3153,14 +3323,15 @@ package body Sem_Eval is
return;
end if;
- -- Here we will fold, save Print_In_Hex indication
-
- Hex := Nkind (Operand) = N_Integer_Literal
- and then Print_In_Hex (Operand);
-
-- Fold the result of qualification
if Is_Discrete_Type (Target_Type) then
+
+ -- Save Print_In_Hex indication
+
+ Hex := Nkind (Operand) = N_Integer_Literal
+ and then Print_In_Hex (Operand);
+
Fold_Uint (N, Expr_Value (Operand), Stat);
-- Preserve Print_In_Hex indication
@@ -3221,8 +3392,9 @@ package body Sem_Eval is
------------------------
-- Relational operations are static functions, so the result is static if
- -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
- -- the result is never static, even if the operands are.
+ -- both operands are static (RM 4.9(7), 4.9(20)), except that up to Ada
+ -- 2012, for strings the result is never static, even if the operands are.
+ -- The string case was relaxed in Ada 2020, see AI12-0201.
-- However, for internally generated nodes, we allow string equality and
-- inequality to be static. This is because we rewrite A in "ABC" as an
@@ -3545,7 +3717,7 @@ package body Sem_Eval is
if Is_Array_Type (Left_Typ)
and then Left_Typ /= Any_Composite
and then Number_Dimensions (Left_Typ) = 1
- and then Nkind_In (N, N_Op_Eq, N_Op_Ne)
+ and then Nkind (N) in N_Op_Eq | N_Op_Ne
then
if Raises_Constraint_Error (Left)
or else
@@ -3563,7 +3735,13 @@ package body Sem_Eval is
and then Right_Len /= Uint_Minus_1
and then Left_Len /= Right_Len
then
- Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
+ -- AI12-0201: comparison of string is static in Ada 202x
+
+ Fold_Uint
+ (N,
+ Test (Nkind (N) = N_Op_Ne),
+ Static => Ada_Version >= Ada_2020
+ and then Is_String_Type (Left_Typ));
Warn_On_Known_Condition (N);
return;
end if;
@@ -3582,16 +3760,23 @@ package body Sem_Eval is
Test_Expression_Is_Foldable
(N, Left, Right, Is_Static_Expression, Fold);
- -- Only comparisons of scalars can give static results. A comparison
- -- of strings never yields a static result, even if both operands are
- -- static strings, except that as noted above, we allow equality and
+ -- Comparisons of scalars can give static results.
+ -- In addition starting with Ada 202x (AI12-0201), comparison of
+ -- strings can also give static results, and as noted above, we also
+ -- allow for earlier Ada versions internally generated equality and
-- inequality for strings.
-
- if Is_String_Type (Left_Typ)
- and then not Comes_From_Source (N)
- and then Nkind_In (N, N_Op_Eq, N_Op_Ne)
- then
- null;
+ -- ??? The Comes_From_Source test below isn't correct and will accept
+ -- some cases that are illegal in Ada 2012. and before. Now that
+ -- Ada 202x has relaxed the rules, this doesn't really matter.
+
+ if Is_String_Type (Left_Typ) then
+ if Ada_Version < Ada_2020
+ and then (Comes_From_Source (N)
+ or else Nkind (N) not in N_Op_Eq | N_Op_Ne)
+ then
+ Is_Static_Expression := False;
+ Set_Is_Static_Expression (N, False);
+ end if;
elsif not Is_Scalar_Type (Left_Typ) then
Is_Static_Expression := False;
@@ -3632,16 +3817,13 @@ package body Sem_Eval is
-- Eval_Shift --
----------------
- -- Shift operations are intrinsic operations that can never be static, so
- -- the only processing required is to perform the required check for a non
- -- static context for the two operands.
-
- -- Actually we could do some compile time evaluation here some time ???
-
procedure Eval_Shift (N : Node_Id) is
begin
- Check_Non_Static_Context (Left_Opnd (N));
- Check_Non_Static_Context (Right_Opnd (N));
+ -- This procedure is only called for compiler generated code (e.g.
+ -- packed arrays), so there is nothing to do except attempting to fold
+ -- the expression.
+
+ Fold_Shift (N, Left_Opnd (N), Right_Opnd (N), Nkind (N));
end Eval_Shift;
------------------------
@@ -3834,8 +4016,11 @@ package body Sem_Eval is
end if;
-- If original node was a type conversion, then result if non-static
+ -- up to Ada 2012. AI12-0201 changes that with Ada 202x.
- if Nkind (Original_Node (N)) = N_Type_Conversion then
+ if Nkind (Original_Node (N)) = N_Type_Conversion
+ and then Ada_Version <= Ada_2012
+ then
Set_Is_Static_Expression (N, False);
return;
end if;
@@ -3918,6 +4103,7 @@ package body Sem_Eval is
-- A type conversion is potentially static if its subtype mark is for a
-- static scalar subtype, and its operand expression is potentially static
-- (RM 4.9(10)).
+ -- Also add support for static string types.
procedure Eval_Type_Conversion (N : Node_Id) is
Operand : constant Node_Id := Expression (N);
@@ -3991,10 +4177,14 @@ package body Sem_Eval is
-- following type test, fixed-point counts as real unless the flag
-- Conversion_OK is set, in which case it counts as integer.
- -- Fold conversion, case of string type. The result is not static
+ -- Fold conversion, case of string type. The result is static starting
+ -- with Ada 202x (AI12-0201).
if Is_String_Type (Target_Type) then
- Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
+ Fold_Str
+ (N,
+ Strval (Get_String_Val (Operand)),
+ Static => Ada_Version >= Ada_2020);
return;
-- Fold conversion, case of integer target type
@@ -4011,8 +4201,13 @@ package body Sem_Eval is
-- Real to integer conversion
- else
+ elsif To_Be_Treated_As_Real (Source_Type) then
Result := UR_To_Uint (Expr_Value_R (Operand));
+
+ -- Enumeration to integer conversion, aka 'Enum_Rep
+
+ else
+ Result := Expr_Rep_Value (Operand);
end if;
-- If fixed-point type (Conversion_OK must be set), then the
@@ -4056,7 +4251,6 @@ package body Sem_Eval is
if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
Out_Of_Range (N);
end if;
-
end Eval_Type_Conversion;
-------------------
@@ -4203,10 +4397,16 @@ package body Sem_Eval is
pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
return Corresponding_Integer_Value (N);
- -- Otherwise must be character literal
+ -- The NULL access value
- else
- pragma Assert (Kind = N_Character_Literal);
+ elsif Kind = N_Null then
+ pragma Assert (Is_Access_Type (Underlying_Type (Etype (N)))
+ or else Error_Posted (N));
+ return Uint_0;
+
+ -- Character literal
+
+ elsif Kind = N_Character_Literal then
Ent := Entity (N);
-- Since Character literals of type Standard.Character don't have any
@@ -4220,6 +4420,15 @@ package body Sem_Eval is
else
return Enumeration_Rep (Ent);
end if;
+
+ -- Unchecked conversion, which can come from System'To_Address (X)
+ -- where X is a static integer expression. Recursively evaluate X.
+
+ elsif Kind = N_Unchecked_Type_Conversion then
+ return Expr_Rep_Value (Expression (N));
+
+ else
+ raise Program_Error;
end if;
end Expr_Rep_Value;
@@ -4532,6 +4741,96 @@ package body Sem_Eval is
end if;
end Flag_Non_Static_Expr;
+ ----------------
+ -- Fold_Dummy --
+ ----------------
+
+ procedure Fold_Dummy (N : Node_Id; Typ : Entity_Id) is
+ begin
+ if Is_Integer_Type (Typ) then
+ Fold_Uint (N, Uint_1, Static => True);
+
+ elsif Is_Real_Type (Typ) then
+ Fold_Ureal (N, Ureal_1, Static => True);
+
+ elsif Is_Enumeration_Type (Typ) then
+ Fold_Uint
+ (N,
+ Expr_Value (Type_Low_Bound (Base_Type (Typ))),
+ Static => True);
+
+ elsif Is_String_Type (Typ) then
+ Fold_Str
+ (N,
+ Strval (Make_String_Literal (Sloc (N), "")),
+ Static => True);
+ end if;
+ end Fold_Dummy;
+
+ ----------------
+ -- Fold_Shift --
+ ----------------
+
+ procedure Fold_Shift
+ (N : Node_Id;
+ Left : Node_Id;
+ Right : Node_Id;
+ Op : Node_Kind;
+ Static : Boolean := False;
+ Check_Elab : Boolean := False)
+ is
+ Typ : constant Entity_Id := Etype (Left);
+
+ procedure Check_Elab_Call;
+ -- Add checks related to calls in elaboration code
+
+ ---------------------
+ -- Check_Elab_Call --
+ ---------------------
+
+ procedure Check_Elab_Call is
+ begin
+ if Check_Elab then
+ if Legacy_Elaboration_Checks then
+ Check_Elab_Call (N);
+ end if;
+
+ Build_Call_Marker (N);
+ end if;
+ end Check_Elab_Call;
+
+ begin
+ -- Evaluate logical shift operators on binary modular types
+
+ if Is_Modular_Integer_Type (Typ)
+ and then not Non_Binary_Modulus (Typ)
+ and then Compile_Time_Known_Value (Left)
+ and then Compile_Time_Known_Value (Right)
+ then
+ if Op = N_Op_Shift_Left then
+ Check_Elab_Call;
+
+ -- Fold Shift_Left (X, Y) by computing (X * 2**Y) rem modulus
+
+ Fold_Uint
+ (N,
+ (Expr_Value (Left) * (Uint_2 ** Expr_Value (Right)))
+ rem Modulus (Typ),
+ Static => Static);
+
+ elsif Op = N_Op_Shift_Right then
+ Check_Elab_Call;
+
+ -- Fold Shift_Right (X, Y) by computing X / 2**Y
+
+ Fold_Uint
+ (N,
+ Expr_Value (Left) / (Uint_2 ** Expr_Value (Right)),
+ Static => Static);
+ end if;
+ end if;
+ end Fold_Shift;
+
--------------
-- Fold_Str --
--------------
@@ -4579,8 +4878,8 @@ package body Sem_Eval is
return;
end if;
- -- If we are folding a named number, retain the entity in the literal,
- -- for ASIS use.
+ -- If we are folding a named number, retain the entity in the literal
+ -- in the original tree.
if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer then
Ent := Entity (N);
@@ -4594,8 +4893,8 @@ package body Sem_Eval is
-- For a result of type integer, substitute an N_Integer_Literal node
-- for the result of the compile time evaluation of the expression.
- -- For ASIS use, set a link to the original named number when not in
- -- a generic context.
+ -- Set a link to the original named number when not in a generic context
+ -- for reference in the original tree.
if Is_Integer_Type (Typ) then
Rewrite (N, Make_Integer_Literal (Loc, Val));
@@ -4641,8 +4940,8 @@ package body Sem_Eval is
return;
end if;
- -- If we are folding a named number, retain the entity in the literal,
- -- for ASIS use.
+ -- If we are folding a named number, retain the entity in the literal
+ -- in the original tree.
if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real then
Ent := Entity (N);
@@ -4652,7 +4951,7 @@ package body Sem_Eval is
Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
- -- Set link to original named number, for ASIS use
+ -- Set link to original named number
Set_Original_Entity (N, Ent);
@@ -4703,7 +5002,7 @@ package body Sem_Eval is
function Get_String_Val (N : Node_Id) return Node_Id is
begin
- if Nkind_In (N, N_String_Literal, N_Character_Literal) then
+ if Nkind (N) in N_String_Literal | N_Character_Literal then
return N;
else
pragma Assert (Is_Entity_Name (N));
@@ -4821,14 +5120,14 @@ package body Sem_Eval is
exception
when others =>
-
- -- Debug flag K disables this behavior (useful for debugging)
+ -- With debug flag K we will get an exception unless an error has
+ -- already occurred (useful for debugging).
if Debug_Flag_K then
- raise;
- else
- return False;
+ Check_Error_Detected;
end if;
+
+ return False;
end In_Subrange_Of;
-----------------
@@ -5555,45 +5854,125 @@ package body Sem_Eval is
end if;
end Out_Of_Range;
+ ---------------------------
+ -- Predicates_Compatible --
+ ---------------------------
+
+ function Predicates_Compatible (T1, T2 : Entity_Id) return Boolean is
+
+ function T2_Rep_Item_Applies_To_T1 (Nam : Name_Id) return Boolean;
+ -- Return True if the rep item for Nam is either absent on T2 or also
+ -- applies to T1.
+
+ -------------------------------
+ -- T2_Rep_Item_Applies_To_T1 --
+ -------------------------------
+
+ function T2_Rep_Item_Applies_To_T1 (Nam : Name_Id) return Boolean is
+ Rep_Item : constant Node_Id := Get_Rep_Item (T2, Nam);
+
+ begin
+ return No (Rep_Item) or else Get_Rep_Item (T1, Nam) = Rep_Item;
+ end T2_Rep_Item_Applies_To_T1;
+
+ -- Start of processing for Predicates_Compatible
+
+ begin
+ if Ada_Version < Ada_2012 then
+ return True;
+
+ -- If T2 has no predicates, there is no compatibility issue
+
+ elsif not Has_Predicates (T2) then
+ return True;
+
+ -- T2 has predicates, if T1 has none then we defer to the static check
+
+ elsif not Has_Predicates (T1) then
+ null;
+
+ -- Both T2 and T1 have predicates, check that all predicates that apply
+ -- to T2 apply also to T1 (RM 4.9.1(9/3)).
+
+ elsif T2_Rep_Item_Applies_To_T1 (Name_Static_Predicate)
+ and then T2_Rep_Item_Applies_To_T1 (Name_Dynamic_Predicate)
+ and then T2_Rep_Item_Applies_To_T1 (Name_Predicate)
+ then
+ return True;
+ end if;
+
+ -- Implement the static check prescribed by RM 4.9.1(10/3)
+
+ if Is_Static_Subtype (T1) and then Is_Static_Subtype (T2) then
+ -- We just need to query Interval_Lists for discrete types
+
+ if Is_Discrete_Type (T1) and then Is_Discrete_Type (T2) then
+ declare
+ Interval_List1 : constant Interval_Lists.Discrete_Interval_List
+ := Interval_Lists.Type_Intervals (T1);
+ Interval_List2 : constant Interval_Lists.Discrete_Interval_List
+ := Interval_Lists.Type_Intervals (T2);
+ begin
+ return Interval_Lists.Is_Subset (Interval_List1, Interval_List2)
+ and then not (Has_Predicates (T1)
+ and then not Predicate_Checks_Suppressed (T2)
+ and then Predicate_Checks_Suppressed (T1));
+ end;
+
+ else
+ -- TBD: Implement Interval_Lists for real types
+
+ return False;
+ end if;
+
+ -- If either subtype is not static, the predicates are not compatible
+
+ else
+ return False;
+ end if;
+ end Predicates_Compatible;
+
----------------------
-- Predicates_Match --
----------------------
function Predicates_Match (T1, T2 : Entity_Id) return Boolean is
- Pred1 : Node_Id;
- Pred2 : Node_Id;
+
+ function Have_Same_Rep_Item (Nam : Name_Id) return Boolean;
+ -- Return True if T1 and T2 have the same rep item for Nam
+
+ ------------------------
+ -- Have_Same_Rep_Item --
+ ------------------------
+
+ function Have_Same_Rep_Item (Nam : Name_Id) return Boolean is
+ begin
+ return Get_Rep_Item (T1, Nam) = Get_Rep_Item (T2, Nam);
+ end Have_Same_Rep_Item;
+
+ -- Start of processing for Predicates_Match
begin
if Ada_Version < Ada_2012 then
return True;
- -- Both types must have predicates or lack them
+ -- If T2 has no predicates, match if and only if T1 has none
- elsif Has_Predicates (T1) /= Has_Predicates (T2) then
+ elsif not Has_Predicates (T2) then
+ return not Has_Predicates (T1);
+
+ -- T2 has predicates, no match if T1 has none
+
+ elsif not Has_Predicates (T1) then
return False;
- -- Check matching predicates
+ -- Both T2 and T1 have predicates, check that they all come
+ -- from the same declarations.
else
- Pred1 :=
- Get_Rep_Item
- (T1, Name_Static_Predicate, Check_Parents => False);
- Pred2 :=
- Get_Rep_Item
- (T2, Name_Static_Predicate, Check_Parents => False);
-
- -- Subtypes statically match if the predicate comes from the
- -- same declaration, which can only happen if one is a subtype
- -- of the other and has no explicit predicate.
-
- -- Suppress warnings on order of actuals, which is otherwise
- -- triggered by one of the two calls below.
-
- pragma Warnings (Off);
- return Pred1 = Pred2
- or else (No (Pred1) and then Is_Subtype_Of (T1, T2))
- or else (No (Pred2) and then Is_Subtype_Of (T2, T1));
- pragma Warnings (On);
+ return Have_Same_Rep_Item (Name_Static_Predicate)
+ and then Have_Same_Rep_Item (Name_Dynamic_Predicate)
+ and then Have_Same_Rep_Item (Name_Predicate);
end if;
end Predicates_Match;
@@ -5793,6 +6172,21 @@ package body Sem_Eval is
Set_Is_Static_Expression (N, Stat);
end Rewrite_In_Raise_CE;
+ ------------------------------------------------
+ -- Set_Checking_Potentially_Static_Expression --
+ ------------------------------------------------
+
+ procedure Set_Checking_Potentially_Static_Expression (Value : Boolean) is
+ begin
+ -- Verify that we're not currently checking for a potentially static
+ -- expression unless we're disabling such checking.
+
+ pragma Assert
+ (not Checking_For_Potentially_Static_Expression or else not Value);
+
+ Checking_For_Potentially_Static_Expression := Value;
+ end Set_Checking_Potentially_Static_Expression;
+
---------------------
-- String_Type_Len --
---------------------
@@ -5822,9 +6216,19 @@ package body Sem_Eval is
Formal_Derived_Matching : Boolean := False) return Boolean
is
begin
+ -- A type is always statically compatible with itself
+
+ if T1 = T2 then
+ return True;
+
+ -- Not compatible if predicates are not compatible
+
+ elsif not Predicates_Compatible (T1, T2) then
+ return False;
+
-- Scalar types
- if Is_Scalar_Type (T1) then
+ elsif Is_Scalar_Type (T1) then
-- Definitely compatible if we match
@@ -6031,6 +6435,29 @@ package body Sem_Eval is
elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
+ -- Handle derivations of private subtypes. For example S1 statically
+ -- matches the full view of T1 in the following example:
+
+ -- type T1(<>) is new Root with private;
+ -- subtype S1 is new T1;
+ -- overriding proc P1 (P : S1);
+ -- private
+ -- type T1 (D : Disc) is new Root with ...
+
+ if Ekind (T2) = E_Record_Subtype_With_Private
+ and then not Has_Discriminants (T2)
+ and then Partial_View_Has_Unknown_Discr (T1)
+ and then Etype (T2) = T1
+ then
+ return True;
+
+ elsif Ekind (T1) = E_Record_Subtype_With_Private
+ and then not Has_Discriminants (T1)
+ and then Partial_View_Has_Unknown_Discr (T2)
+ and then Etype (T1) = T2
+ then
+ return True;
+
-- Because of view exchanges in multiple instantiations, conformance
-- checking might try to match a partial view of a type with no
-- discriminants with a full view that has defaulted discriminants.
@@ -6038,7 +6465,7 @@ package body Sem_Eval is
-- which must exist because we know that the two subtypes have the
-- same base type.
- if Has_Discriminants (T1) /= Has_Discriminants (T2) then
+ elsif Has_Discriminants (T1) /= Has_Discriminants (T2) then
if In_Instance then
if Is_Private_Type (T2)
and then Present (Full_View (T2))
@@ -6163,8 +6590,8 @@ package body Sem_Eval is
if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then
return False;
- elsif Ekind_In (T1, E_Access_Subprogram_Type,
- E_Anonymous_Access_Subprogram_Type)
+ elsif Ekind (T1) in E_Access_Subprogram_Type
+ | E_Anonymous_Access_Subprogram_Type
then
return
Subtype_Conformant
@@ -6872,9 +7299,8 @@ package body Sem_Eval is
-- Flag array cases
elsif Is_Array_Type (E) then
- if not Nam_In (Attribute_Name (N), Name_First,
- Name_Last,
- Name_Length)
+ if Attribute_Name (N)
+ not in Name_First | Name_Last | Name_Length
then
Error_Msg_N
("!static array attribute must be Length, First, or Last "
diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads
index 0a2bc64..76e4bdf 100644
--- a/gcc/ada/sem_eval.ads
+++ b/gcc/ada/sem_eval.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -125,15 +125,18 @@ package Sem_Eval is
-----------------
procedure Check_Expression_Against_Static_Predicate
- (Expr : Node_Id;
- Typ : Entity_Id);
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Static_Failure_Is_Error : Boolean := False);
-- Determine whether an arbitrary expression satisfies the static predicate
-- of a type. The routine does nothing if Expr is not known at compile time
- -- or Typ lacks a static predicate, otherwise it may emit a warning if the
- -- expression is prohibited by the predicate. If the expression is a static
- -- expression and it fails a predicate that was not explicitly stated to be
- -- a dynamic predicate, then an additional warning is given, and the flag
- -- Is_Static_Expression is reset on Expr.
+ -- or Typ lacks a static predicate; otherwise it may emit a warning if the
+ -- expression is prohibited by the predicate, or if Static_Failure_Is_Error
+ -- is True then an error will be flagged. If the expression is a static
+ -- expression, it fails a predicate that was not explicitly stated to be
+ -- a dynamic predicate, and Static_Failure_Is_Error is False, then an
+ -- additional warning is given, and the flag Is_Static_Expression is reset
+ -- on Expr.
procedure Check_Non_Static_Context (N : Node_Id);
-- Deals with the special check required for a static expression that
@@ -162,6 +165,14 @@ package Sem_Eval is
-- In the former case, if the target type, Ttyp is constrained, then a
-- check is made to see if the string literal is of appropriate length.
+ function Checking_Potentially_Static_Expression return Boolean;
+ -- Returns True if the checking for potentially static expressions is
+ -- enabled; otherwise returns False.
+
+ procedure Set_Checking_Potentially_Static_Expression (Value : Boolean);
+ -- Enables checking for potentially static expressions if Value is True,
+ -- and disables such checking if Value is False.
+
type Compare_Result is (LT, LE, EQ, GT, GE, NE, Unknown);
subtype Compare_GE is Compare_Result range EQ .. GE;
subtype Compare_LE is Compare_Result range LT .. EQ;
@@ -276,7 +287,9 @@ package Sem_Eval is
-- or character literals. In the latter two cases, the value returned is
-- the Pos value in the relevant enumeration type. It can also be used for
-- fixed-point values, in which case it returns the corresponding integer
- -- value. It cannot be used for floating-point values.
+ -- value, but it cannot be used for floating-point values. Finally, it can
+ -- also be used for the Null access value, as well as for the result of an
+ -- unchecked conversion of the aforementioned handled values.
function Expr_Value_E (N : Node_Id) return Entity_Id;
-- Returns the folded value of the expression. This function is called in
@@ -414,8 +427,6 @@ package Sem_Eval is
-- for compile time evaluation purposes. Use Compile_Time_Known_Value
-- instead (see section on "Compile-Time Known Values" above).
- -- WARNING: There is a matching C declaration of this subprogram in fe.h
-
function Is_OK_Static_Range (N : Node_Id) return Boolean;
-- Determines if range is static, as defined in RM 4.9(26), and also checks
-- that neither bound of the range raises constraint error, thus ensuring
@@ -476,11 +487,17 @@ package Sem_Eval is
-- it cannot (because the value of Lo or Hi is not known at compile time)
-- then it returns False.
+ function Predicates_Compatible (T1, T2 : Entity_Id) return Boolean;
+ -- In Ada 2012, subtypes are statically compatible if the predicates are
+ -- compatible as well. This function performs the required check that
+ -- predicates are compatible. Split from Subtypes_Statically_Compatible
+ -- so that it can be used in specializing error messages.
+
function Predicates_Match (T1, T2 : Entity_Id) return Boolean;
- -- In Ada 2012, subtypes statically match if their static predicates
- -- match as well. This function performs the required check that
- -- predicates match. Separated out from Subtypes_Statically_Match so
- -- that it can be used in specializing error messages.
+ -- In Ada 2012, subtypes statically match if their predicates match as
+ -- as well. This function performs the required check that predicates
+ -- match. Separated out from Subtypes_Statically_Match so that it can
+ -- be used in specializing error messages.
function Subtypes_Statically_Compatible
(T1 : Entity_Id;
diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb
index 0b308f7..15bb146 100644
--- a/gcc/ada/sem_intr.adb
+++ b/gcc/ada/sem_intr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -76,7 +76,7 @@ package body Sem_Intr is
procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is
begin
- if not Ekind_In (E, E_Function, E_Generic_Function) then
+ if Ekind (E) not in E_Function | E_Generic_Function then
Errint
("intrinsic exception subprogram must be a function", E, N);
@@ -129,9 +129,9 @@ package body Sem_Intr is
-- literal is legal even in Ada 83 mode, where such literals are
-- not static.
- if Nam_In (Cnam, Name_Import_Address,
- Name_Import_Largest_Value,
- Name_Import_Value)
+ if Cnam in Name_Import_Address
+ | Name_Import_Largest_Value
+ | Name_Import_Value
then
if Etype (Arg1) = Any_Type
or else Raises_Constraint_Error (Arg1)
@@ -190,13 +190,14 @@ package body Sem_Intr is
begin
-- Arithmetic operators
- if Nam_In (Nam, Name_Op_Add, Name_Op_Subtract, Name_Op_Multiply,
- Name_Op_Divide, Name_Op_Rem, Name_Op_Mod, Name_Op_Abs)
+ if Nam in Name_Op_Add | Name_Op_Subtract | Name_Op_Multiply |
+ Name_Op_Divide | Name_Op_Rem | Name_Op_Mod |
+ Name_Op_Abs
then
T1 := Etype (First_Formal (E));
if No (Next_Formal (First_Formal (E))) then
- if Nam_In (Nam, Name_Op_Add, Name_Op_Subtract, Name_Op_Abs) then
+ if Nam in Name_Op_Add | Name_Op_Subtract | Name_Op_Abs then
T2 := T1;
-- Previous error in declaration
@@ -231,8 +232,8 @@ package body Sem_Intr is
-- Comparison operators
- elsif Nam_In (Nam, Name_Op_Eq, Name_Op_Ge, Name_Op_Gt, Name_Op_Le,
- Name_Op_Lt, Name_Op_Ne)
+ elsif Nam in Name_Op_Eq | Name_Op_Ge | Name_Op_Gt | Name_Op_Le |
+ Name_Op_Lt | Name_Op_Ne
then
T1 := Etype (First_Formal (E));
@@ -327,8 +328,8 @@ package body Sem_Intr is
-- Shift cases. We allow user specification of intrinsic shift operators
-- for any numeric types.
- elsif Nam_In (Nam, Name_Rotate_Left, Name_Rotate_Right, Name_Shift_Left,
- Name_Shift_Right, Name_Shift_Right_Arithmetic)
+ elsif Nam in Name_Rotate_Left | Name_Rotate_Right | Name_Shift_Left |
+ Name_Shift_Right | Name_Shift_Right_Arithmetic
then
Check_Shift (E, N);
@@ -344,9 +345,9 @@ package body Sem_Intr is
-- Exception functions
- elsif Nam_In (Nam, Name_Exception_Information,
- Name_Exception_Message,
- Name_Exception_Name)
+ elsif Nam in Name_Exception_Information
+ | Name_Exception_Message
+ | Name_Exception_Name
then
Check_Exception_Function (E, N);
@@ -357,13 +358,13 @@ package body Sem_Intr is
-- Source_Location and navigation functions
- elsif Nam_In (Nam, Name_File,
- Name_Line,
- Name_Source_Location,
- Name_Enclosing_Entity,
- Name_Compilation_ISO_Date,
- Name_Compilation_Date,
- Name_Compilation_Time)
+ elsif Nam in Name_File
+ | Name_Line
+ | Name_Source_Location
+ | Name_Enclosing_Entity
+ | Name_Compilation_ISO_Date
+ | Name_Compilation_Date
+ | Name_Compilation_Time
then
null;
@@ -388,7 +389,7 @@ package body Sem_Intr is
Ptyp2 : Node_Id;
begin
- if not Ekind_In (E, E_Function, E_Generic_Function) then
+ if Ekind (E) not in E_Function | E_Generic_Function then
Errint ("intrinsic shift subprogram must be a function", E, N);
return;
end if;
diff --git a/gcc/ada/sem_intr.ads b/gcc/ada/sem_intr.ads
index bb36931..224008c 100644
--- a/gcc/ada/sem_intr.ads
+++ b/gcc/ada/sem_intr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb
index cbe786c..4130cd8 100644
--- a/gcc/ada/sem_mech.adb
+++ b/gcc/ada/sem_mech.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -181,11 +181,10 @@ package body Sem_Mech is
-- C --
-------
- -- Note: Assembler, C++, Stdcall also use C conventions
+ -- Note: Assembler and Stdcall also use C conventions
when Convention_Assembler
- | Convention_C
- | Convention_CPP
+ | Convention_C_Family
| Convention_Stdcall
=>
-- The following values are passed by copy
@@ -231,8 +230,8 @@ package body Sem_Mech is
-- OUT and IN OUT parameters of record types are passed
-- by reference regardless of pragmas (RM B.3 (69/2)).
- elsif Ekind_In (Formal, E_Out_Parameter,
- E_In_Out_Parameter)
+ elsif Ekind (Formal) in
+ E_Out_Parameter | E_In_Out_Parameter
then
Set_Mechanism (Formal, By_Reference);
diff --git a/gcc/ada/sem_mech.ads b/gcc/ada/sem_mech.ads
index c66d9e2..81b8c25 100644
--- a/gcc/ada/sem_mech.ads
+++ b/gcc/ada/sem_mech.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 2369d64..b7148d80 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -697,8 +697,8 @@ package body Sem_Prag is
elsif Ekind (Item_Id) = E_Constant then
Add_Str_To_Name_Buffer ("constant");
- elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
- E_Generic_In_Parameter)
+ elsif Ekind (Item_Id) in
+ E_Generic_In_Out_Parameter | E_Generic_In_Parameter
then
Add_Str_To_Name_Buffer ("generic parameter");
@@ -972,32 +972,32 @@ package body Sem_Prag is
-- Constants
- if Ekind_In (Item_Id, E_Constant, E_Loop_Parameter)
+ if Ekind (Item_Id) in E_Constant | E_Loop_Parameter
or else
-- Current instances of concurrent types
- Ekind_In (Item_Id, E_Protected_Type, E_Task_Type)
+ Ekind (Item_Id) in E_Protected_Type | E_Task_Type
or else
-- Formal parameters
- Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
- E_Generic_In_Parameter,
- E_In_Parameter,
- E_In_Out_Parameter,
- E_Out_Parameter)
+ Ekind (Item_Id) in E_Generic_In_Out_Parameter
+ | E_Generic_In_Parameter
+ | E_In_Parameter
+ | E_In_Out_Parameter
+ | E_Out_Parameter
or else
-- States, variables
- Ekind_In (Item_Id, E_Abstract_State, E_Variable)
+ Ekind (Item_Id) in E_Abstract_State | E_Variable
then
-- A [generic] function is not allowed to have Output
-- items in its dependency relations. Note that "null"
-- and attribute 'Result are still valid items.
- if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
+ if Ekind (Spec_Id) in E_Function | E_Generic_Function
and then not Is_Input
then
SPARK_Msg_N
@@ -1009,7 +1009,7 @@ package body Sem_Prag is
-- they behave as objects in the context of pragma
-- [Refined_]Depends.
- if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
+ if Ekind (Item_Id) in E_Protected_Type | E_Task_Type then
-- This use is legal as long as the concurrent type is
-- the current instance of an enclosing type.
@@ -1144,9 +1144,9 @@ package body Sem_Prag is
Ref => Item);
end if;
- if Ekind_In (Item_Id, E_Abstract_State,
- E_Constant,
- E_Variable)
+ if Ekind (Item_Id) in E_Abstract_State
+ | E_Constant
+ | E_Variable
and then Present (Encapsulating_State (Item_Id))
then
Append_New_Elmt (Item_Id, Constits_Seen);
@@ -1222,7 +1222,7 @@ package body Sem_Prag is
procedure Check_Function_Return is
begin
- if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
+ if Ekind (Spec_Id) in E_Function | E_Generic_Function
and then not Result_Seen
then
SPARK_Msg_NE
@@ -1269,9 +1269,9 @@ package body Sem_Prag is
Adjusted_Kind : Entity_Kind := Ekind (Item_Id);
begin
- if Ekind_In (Item_Id, E_Constant,
- E_Generic_In_Parameter,
- E_In_Parameter)
+ if Ekind (Item_Id) in E_Constant
+ | E_Generic_In_Parameter
+ | E_In_Parameter
and then Is_Access_Type (Etype (Item_Id))
then
Adjusted_Kind := E_Variable;
@@ -2001,6 +2001,11 @@ package body Sem_Prag is
Push_Scope (Spec_Id);
if Ekind (Spec_Id) = E_Task_Type then
+
+ -- Task discriminants cannot appear in the [Refined_]Depends
+ -- contract, but must be present for the analysis so that we
+ -- can reject them with an informative error message.
+
if Has_Discriminants (Spec_Id) then
Install_Discriminants (Spec_Id);
end if;
@@ -2031,11 +2036,9 @@ package body Sem_Prag is
-- Do not normalize a clause if errors were detected (count
-- of Serious_Errors has increased) because the inputs and/or
- -- outputs may denote illegal items. Normalization is disabled
- -- in ASIS mode as it alters the tree by introducing new nodes
- -- similar to expansion.
+ -- outputs may denote illegal items.
- if Serious_Errors_Detected = Errors and then not ASIS_Mode then
+ if Serious_Errors_Detected = Errors then
Normalize_Clause (Clause);
end if;
@@ -2119,13 +2122,16 @@ package body Sem_Prag is
if Prag_Id /= Pragma_No_Caching
and then not Is_Effectively_Volatile (Obj_Id)
then
- if No_Caching_Enabled (Obj_Id) then
+ if Ekind (Obj_Id) = E_Variable
+ and then No_Caching_Enabled (Obj_Id)
+ then
SPARK_Msg_N
("illegal combination of external property % and property "
& """No_Caching"" (SPARK RM 7.1.2(6))", N);
else
SPARK_Msg_N
- ("external property % must apply to a volatile object", N);
+ ("external property % must apply to a volatile type or object",
+ N);
end if;
-- Pragma No_Caching should only apply to volatile variables of
@@ -2274,7 +2280,7 @@ package body Sem_Prag is
-- the current instance of an enclosing protected or task type
-- (SPARK RM 6.1.4).
- elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
+ elsif Ekind (Item_Id) in E_Protected_Type | E_Task_Type then
if Is_CCT_Instance (Item_Id, Spec_Id) then
-- Pragma [Refined_]Global associated with a protected
@@ -2361,10 +2367,10 @@ package body Sem_Prag is
-- The only legal references are those to abstract states,
-- objects and various kinds of constants (SPARK RM 6.1.4(4)).
- elsif not Ekind_In (Item_Id, E_Abstract_State,
- E_Constant,
- E_Loop_Parameter,
- E_Variable)
+ elsif Ekind (Item_Id) not in E_Abstract_State
+ | E_Constant
+ | E_Loop_Parameter
+ | E_Variable
then
SPARK_Msg_N
("global item must denote object, state or current "
@@ -2408,7 +2414,7 @@ package body Sem_Prag is
-- nonvolatile function (SPARK RM 7.1.3(8)).
elsif Is_External_State (Item_Id)
- and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
+ and then Ekind (Spec_Id) in E_Function | E_Generic_Function
and then not Is_Volatile_Function (Spec_Id)
then
SPARK_Msg_NE
@@ -2435,7 +2441,7 @@ package body Sem_Prag is
-- Unless it is of an access type, a constant is a read-only
-- item, therefore it cannot act as an output.
- if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
+ if Global_Mode in Name_In_Out | Name_Output then
SPARK_Msg_NE
("constant & cannot act as output", Item, Item_Id);
return;
@@ -2448,7 +2454,7 @@ package body Sem_Prag is
-- A loop parameter is a read-only item, therefore it cannot
-- act as an output.
- if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
+ if Global_Mode in Name_In_Out | Name_Output then
SPARK_Msg_NE
("loop parameter & cannot act as output",
Item, Item_Id);
@@ -2466,7 +2472,7 @@ package body Sem_Prag is
-- An effectively volatile object cannot appear as a global
-- item of a nonvolatile function (SPARK RM 7.1.3(8)).
- if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
+ if Ekind (Spec_Id) in E_Function | E_Generic_Function
and then not Is_Volatile_Function (Spec_Id)
then
Error_Msg_NE
@@ -2509,7 +2515,7 @@ package body Sem_Prag is
-- Verify that an output does not appear as an input in an
-- enclosing subprogram.
- if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
+ if Global_Mode in Name_In_Out | Name_Output then
Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
end if;
@@ -2540,7 +2546,7 @@ package body Sem_Prag is
Ref => Item);
end if;
- if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
+ if Ekind (Item_Id) in E_Abstract_State | E_Constant | E_Variable
and then Present (Encapsulating_State (Item_Id))
then
Append_New_Elmt (Item_Id, Constits_Seen);
@@ -2644,7 +2650,7 @@ package body Sem_Prag is
procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
begin
- if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
+ if Ekind (Spec_Id) in E_Function | E_Generic_Function then
SPARK_Msg_N
("global mode & is not applicable to functions", Mode);
end if;
@@ -2664,9 +2670,9 @@ package body Sem_Prag is
-- Single global item declaration
- elsif Nkind_In (List, N_Expanded_Name,
- N_Identifier,
- N_Selected_Component)
+ elsif Nkind (List) in N_Expanded_Name
+ | N_Identifier
+ | N_Selected_Component
then
Analyze_Global_Item (List, Global_Mode);
@@ -2792,6 +2798,11 @@ package body Sem_Prag is
Push_Scope (Spec_Id);
if Ekind (Spec_Id) = E_Task_Type then
+
+ -- Task discriminants cannot appear in the [Refined_]Global
+ -- contract, but must be present for the analysis so that we
+ -- can reject them with an informative error message.
+
if Has_Discriminants (Spec_Id) then
Install_Discriminants (Spec_Id);
end if;
@@ -2897,7 +2908,7 @@ package body Sem_Prag is
-- Verify the legality of a single initialization item followed by a
-- list of input items.
- procedure Collect_States_And_Objects;
+ procedure Collect_States_And_Objects (Pack_Decl : Node_Id);
-- Inspect the visible declarations of the related package and gather
-- the entities of all abstract states and objects in States_And_Objs.
@@ -2916,9 +2927,8 @@ package body Sem_Prag is
Item_Id := Entity_Of (Item);
if Present (Item_Id)
- and then Ekind_In (Item_Id, E_Abstract_State,
- E_Constant,
- E_Variable)
+ and then Ekind (Item_Id) in
+ E_Abstract_State | E_Constant | E_Variable
then
-- When the initialization item is undefined, it appears as
-- Any_Id. Do not continue with the analysis of the item.
@@ -3028,16 +3038,16 @@ package body Sem_Prag is
Input_Id := Entity_Of (Input);
if Present (Input_Id)
- and then Ekind_In (Input_Id, E_Abstract_State,
- E_Constant,
- E_Generic_In_Out_Parameter,
- E_Generic_In_Parameter,
- E_In_Parameter,
- E_In_Out_Parameter,
- E_Out_Parameter,
- E_Protected_Type,
- E_Task_Type,
- E_Variable)
+ and then Ekind (Input_Id) in E_Abstract_State
+ | E_Constant
+ | E_Generic_In_Out_Parameter
+ | E_Generic_In_Parameter
+ | E_In_Parameter
+ | E_In_Out_Parameter
+ | E_Out_Parameter
+ | E_Protected_Type
+ | E_Task_Type
+ | E_Variable
then
-- The input cannot denote states or objects declared
-- within the related package (SPARK RM 7.1.5(4)).
@@ -3050,12 +3060,12 @@ package body Sem_Prag is
-- it is allowed for an initialization item to depend
-- on an input item.
- if Ekind_In (Input_Id, E_Generic_In_Out_Parameter,
- E_Generic_In_Parameter)
+ if Ekind (Input_Id) in E_Generic_In_Out_Parameter
+ | E_Generic_In_Parameter
then
null;
- elsif Ekind_In (Input_Id, E_Constant, E_Variable)
+ elsif Ekind (Input_Id) in E_Constant | E_Variable
and then Present (Corresponding_Generic_Association
(Declaration_Node (Input_Id)))
then
@@ -3087,9 +3097,9 @@ package body Sem_Prag is
Append_New_Elmt (Input_Id, States_Seen);
end if;
- if Ekind_In (Input_Id, E_Abstract_State,
- E_Constant,
- E_Variable)
+ if Ekind (Input_Id) in E_Abstract_State
+ | E_Constant
+ | E_Variable
and then Present (Encapsulating_State (Input_Id))
then
Append_New_Elmt (Input_Id, Constits_Seen);
@@ -3166,15 +3176,21 @@ package body Sem_Prag is
-- Collect_States_And_Objects --
--------------------------------
- procedure Collect_States_And_Objects is
- Pack_Spec : constant Node_Id := Specification (Pack_Decl);
- Decl : Node_Id;
+ procedure Collect_States_And_Objects (Pack_Decl : Node_Id) is
+ Pack_Spec : constant Node_Id := Specification (Pack_Decl);
+ Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
+ Decl : Node_Id;
+ State_Elmt : Elmt_Id;
begin
-- Collect the abstract states defined in the package (if any)
- if Present (Abstract_States (Pack_Id)) then
- States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id));
+ if Has_Non_Null_Abstract_State (Pack_Id) then
+ State_Elmt := First_Elmt (Abstract_States (Pack_Id));
+ while Present (State_Elmt) loop
+ Append_New_Elmt (Node (State_Elmt), States_And_Objs);
+ Next_Elmt (State_Elmt);
+ end loop;
end if;
-- Collect all objects that appear in the visible declarations of the
@@ -3184,11 +3200,14 @@ package body Sem_Prag is
Decl := First (Visible_Declarations (Pack_Spec));
while Present (Decl) loop
if Comes_From_Source (Decl)
- and then Nkind_In (Decl, N_Object_Declaration,
- N_Object_Renaming_Declaration)
+ and then Nkind (Decl) in N_Object_Declaration
+ | N_Object_Renaming_Declaration
then
Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
+ elsif Nkind (Decl) = N_Package_Declaration then
+ Collect_States_And_Objects (Decl);
+
elsif Is_Single_Concurrent_Type_Declaration (Decl) then
Append_New_Elmt
(Anonymous_Object (Defining_Entity (Decl)),
@@ -3228,7 +3247,7 @@ package body Sem_Prag is
-- Initialize the various lists used during analysis
- Collect_States_And_Objects;
+ Collect_States_And_Objects (Pack_Decl);
if Present (Expressions (Inits)) then
Init := First (Expressions (Inits));
@@ -3488,7 +3507,7 @@ package body Sem_Prag is
-- Only abstract states and variables can act as constituents of an
-- encapsulating single concurrent type.
- if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
+ if Ekind (Item_Id) in E_Abstract_State | E_Variable then
null;
-- The constituent is a constant
@@ -3531,9 +3550,9 @@ package body Sem_Prag is
-- the single concurrent type (SPARK RM 9(3)).
if Item_Context = Encap_Context then
- if Nkind_In (Item_Context, N_Package_Specification,
- N_Protected_Definition,
- N_Task_Definition)
+ if Nkind (Item_Context) in N_Package_Specification
+ | N_Protected_Definition
+ | N_Task_Definition
then
Prv_Decls := Private_Declarations (Item_Context);
Vis_Decls := Visible_Declarations (Item_Context);
@@ -3618,9 +3637,8 @@ package body Sem_Prag is
Encap_Id := Empty;
Legal := False;
- if Nkind_In (Encap, N_Expanded_Name,
- N_Identifier,
- N_Selected_Component)
+ if Nkind (Encap) in
+ N_Expanded_Name | N_Identifier | N_Selected_Component
then
Analyze (Encap);
Resolve_State (Encap);
@@ -3769,7 +3787,8 @@ package body Sem_Prag is
Arg2 : Node_Id;
Arg3 : Node_Id;
Arg4 : Node_Id;
- -- First four pragma arguments (pragma argument association nodes, or
+ Arg5 : Node_Id;
+ -- First five pragma arguments (pragma argument association nodes, or
-- Empty if the corresponding argument does not exist).
type Name_List is array (Natural range <>) of Name_Id;
@@ -3780,12 +3799,6 @@ package body Sem_Prag is
-- Local Subprograms --
-----------------------
- function Acc_First (N : Node_Id) return Node_Id;
- -- Helper function to iterate over arguments given to OpenAcc pragmas
-
- function Acc_Next (N : Node_Id) return Node_Id;
- -- Helper function to iterate over arguments given to OpenAcc pragmas
-
procedure Ada_2005_Pragma;
-- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
-- Ada 95 mode, these are implementation defined pragmas, so should be
@@ -4329,92 +4342,9 @@ package body Sem_Prag is
procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
-- Activate the set of configuration pragmas and restrictions that make
-- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
- -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
- -- which is used for error messages on any constructs violating the
- -- profile.
-
- procedure Validate_Acc_Condition_Clause (Clause : Node_Id);
- -- Make sure the argument of a given Acc_If clause is a Boolean
-
- procedure Validate_Acc_Data_Clause (Clause : Node_Id);
- -- Make sure the argument of an OpenAcc data clause (e.g. Copy, Copyin,
- -- Copyout...) is an identifier or an aggregate of identifiers.
-
- procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id);
- -- Make sure the argument of an OpenAcc clause is an Integer expression
-
- procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id);
- -- Make sure the argument of an OpenAcc clause is an Integer expression
- -- or a list of Integer expressions.
-
- procedure Validate_Acc_Loop_Collapse (Clause : Node_Id);
- -- Make sure that the parent loop of the Acc_Loop(Collapse => N) pragma
- -- contains at least N-1 nested loops.
-
- procedure Validate_Acc_Loop_Gang (Clause : Node_Id);
- -- Make sure the argument of the Gang clause of a Loop directive is
- -- either an integer expression or a (Static => integer expressions)
- -- aggregate.
-
- procedure Validate_Acc_Loop_Vector (Clause : Node_Id);
- -- When this procedure is called in a construct offloaded by an
- -- Acc_Kernels pragma, makes sure that a Vector_Length clause does
- -- not exist on said pragma. In all cases, make sure the argument
- -- is an Integer expression.
-
- procedure Validate_Acc_Loop_Worker (Clause : Node_Id);
- -- When this procedure is called in a construct offloaded by an
- -- Acc_Parallel pragma, makes sure that no argument has been given.
- -- When this procedure is called in a construct offloaded by an
- -- Acc_Kernels pragma and if Loop_Worker was given an argument,
- -- makes sure that the Num_Workers clause does not appear on the
- -- Acc_Kernels pragma and that the argument is an integer.
-
- procedure Validate_Acc_Name_Reduction (Clause : Node_Id);
- -- Make sure the reduction clause is an aggregate made of a string
- -- representing a supported reduction operation (i.e. "+", "*", "and",
- -- "or", "min" or "max") and either an identifier or aggregate of
- -- identifiers.
-
- procedure Validate_Acc_Size_Expressions (Clause : Node_Id);
- -- Makes sure that Clause is either an integer expression or an
- -- association with a Static as name and a list of integer expressions
- -- or "*" strings on the right hand side.
-
- ---------------
- -- Acc_First --
- ---------------
-
- function Acc_First (N : Node_Id) return Node_Id is
- begin
- if Nkind (N) = N_Aggregate then
- if Present (Expressions (N)) then
- return First (Expressions (N));
-
- elsif Present (Component_Associations (N)) then
- return Expression (First (Component_Associations (N)));
- end if;
- end if;
-
- return N;
- end Acc_First;
-
- --------------
- -- Acc_Next --
- --------------
-
- function Acc_Next (N : Node_Id) return Node_Id is
- begin
- if Nkind (Parent (N)) = N_Component_Association then
- return Expression (Next (Parent (N)));
-
- elsif Nkind (Parent (N)) = N_Aggregate then
- return Next (N);
-
- else
- return Empty;
- end if;
- end Acc_Next;
+ -- GNAT_Ravenscar_EDF, Jorvik, or Ravenscar. N is the corresponding
+ -- pragma node, which is used for error messages on any constructs
+ -- violating the profile.
---------------------
-- Ada_2005_Pragma --
@@ -4698,12 +4628,12 @@ package body Sem_Prag is
-- original pragma name by routine Original_Aspect_Pragma_Name.
if Comes_From_Source (N) then
- if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
+ if Pname in Name_Pre | Name_Pre_Class then
Is_Pre_Post := True;
Set_Class_Present (N, Pname = Name_Pre_Class);
Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
- elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
+ elsif Pname in Name_Post | Name_Post_Class then
Is_Pre_Post := True;
Set_Class_Present (N, Pname = Name_Post_Class);
Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
@@ -4714,7 +4644,7 @@ package body Sem_Prag is
-- in a body. Pragmas Precondition and Postcondition were introduced
-- before aspects and are not subject to the same aspect-like rules.
- if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
+ if Pname in Name_Precondition | Name_Postcondition then
Duplicates_OK := True;
In_Body_OK := True;
end if;
@@ -4838,7 +4768,18 @@ package body Sem_Prag is
then
null;
- -- Otherwise the placement is illegal
+ -- For Ada 2020, pre/postconditions can appear on formal subprograms
+
+ elsif Nkind (Subp_Decl) = N_Formal_Concrete_Subprogram_Declaration
+ and then Ada_Version >= Ada_2020
+ then
+ null;
+
+ -- An access-to-subprogram type can have pre/postconditions, but
+ -- these are transferred to the generated subprogram wrapper and
+ -- analyzed there.
+
+ -- Otherwise the placement of the pragma is illegal
else
Pragma_Misplaced;
@@ -4860,9 +4801,9 @@ package body Sem_Prag is
-- Fully analyze the pragma when it appears inside an entry or
-- subprogram body because it cannot benefit from forward references.
- if Nkind_In (Subp_Decl, N_Entry_Body,
- N_Subprogram_Body,
- N_Subprogram_Body_Stub)
+ if Nkind (Subp_Decl) in N_Entry_Body
+ | N_Subprogram_Body
+ | N_Subprogram_Body_Stub
then
-- The legality checks of pragmas Precondition and Postcondition
-- are affected by the SPARK mode in effect and the volatility of
@@ -4902,11 +4843,9 @@ package body Sem_Prag is
Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
- if not Nkind_In (Body_Decl, N_Entry_Body,
- N_Subprogram_Body,
- N_Subprogram_Body_Stub,
- N_Task_Body,
- N_Task_Body_Stub)
+ if Nkind (Body_Decl) not in
+ N_Entry_Body | N_Subprogram_Body | N_Subprogram_Body_Stub |
+ N_Task_Body | N_Task_Body_Stub
then
Pragma_Misplaced;
return;
@@ -4939,10 +4878,10 @@ package body Sem_Prag is
-- When dealing with protected entries or protected subprograms, use
-- the enclosing protected type as the proper context.
- if Ekind_In (Spec_Id, E_Entry,
- E_Entry_Family,
- E_Function,
- E_Procedure)
+ if Ekind (Spec_Id) in E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Procedure
and then Ekind (Scope (Spec_Id)) = E_Protected_Type
then
Spec_Decl := Declaration_Node (Scope (Spec_Id));
@@ -4964,7 +4903,7 @@ package body Sem_Prag is
Mark_Ghost_Pragma (N, Spec_Id);
- if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
+ if Pname in Name_Refined_Depends | Name_Refined_Global then
Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
end if;
end Analyze_Refined_Depends_Global_Post;
@@ -5529,7 +5468,7 @@ package body Sem_Prag is
begin
Check_Arg_Is_Identifier (Argx);
- if not Nam_In (Chars (Argx), N1, N2) then
+ if Chars (Argx) not in N1 | N2 then
Error_Msg_Name_2 := N1;
Error_Msg_Name_3 := N2;
Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
@@ -5545,7 +5484,7 @@ package body Sem_Prag is
begin
Check_Arg_Is_Identifier (Argx);
- if not Nam_In (Chars (Argx), N1, N2, N3) then
+ if Chars (Argx) not in N1 | N2 | N3 then
Error_Pragma_Arg ("invalid argument for pragma%", Argx);
end if;
end Check_Arg_Is_One_Of;
@@ -5559,7 +5498,7 @@ package body Sem_Prag is
begin
Check_Arg_Is_Identifier (Argx);
- if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
+ if Chars (Argx) not in N1 | N2 | N3 | N4 then
Error_Pragma_Arg ("invalid argument for pragma%", Argx);
end if;
end Check_Arg_Is_One_Of;
@@ -5573,7 +5512,7 @@ package body Sem_Prag is
begin
Check_Arg_Is_Identifier (Argx);
- if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
+ if Chars (Argx) not in N1 | N2 | N3 | N4 | N5 then
Error_Pragma_Arg ("invalid argument for pragma%", Argx);
end if;
end Check_Arg_Is_One_Of;
@@ -5956,7 +5895,7 @@ package body Sem_Prag is
-- For a single protected or a single task object, the error is
-- issued on the original entity.
- if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
+ if Ekind (Id) in E_Task_Type | E_Protected_Type then
Id := Defining_Identifier (Original_Node (Parent (Id)));
end if;
@@ -5965,7 +5904,18 @@ package body Sem_Prag is
then
Error_Msg_NE ("aspect% for & previously given#", N, Id);
else
- Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
+ -- If -gnatwr is set, warn in case of a duplicate pragma
+ -- [No_]Inline which is suspicious but not an error, generate
+ -- an error for other pragmas.
+
+ if Pragma_Name (N) in Name_Inline | Name_No_Inline then
+ if Warn_On_Redundant_Constructs then
+ Error_Msg_NE
+ ("?r?pragma% for & duplicates pragma#", N, Id);
+ end if;
+ else
+ Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
+ end if;
end if;
raise Pragma_Exit;
@@ -6384,9 +6334,8 @@ package body Sem_Prag is
if Nkind (Original_Node (Stmt)) = N_Pragma then
return
- Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)),
- Name_Loop_Invariant,
- Name_Loop_Variant);
+ Pragma_Name_Unmapped (Original_Node (Stmt))
+ in Name_Loop_Invariant | Name_Loop_Variant;
else
return False;
end if;
@@ -6511,9 +6460,7 @@ package body Sem_Prag is
elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
exit;
- elsif Nkind_In (P, N_Package_Specification,
- N_Block_Statement)
- then
+ elsif Nkind (P) in N_Package_Specification | N_Block_Statement then
return;
-- Note: the following tests seem a little peculiar, because
@@ -6522,10 +6469,8 @@ package body Sem_Prag is
-- sequence, so the only way we get here is by being in the
-- declarative part of the body.
- elsif Nkind_In (P, N_Subprogram_Body,
- N_Package_Body,
- N_Task_Body,
- N_Entry_Body)
+ elsif Nkind (P) in
+ N_Subprogram_Body | N_Package_Body | N_Task_Body | N_Entry_Body
then
return;
end if;
@@ -7023,9 +6968,9 @@ package body Sem_Prag is
if Nkind (P) = N_Compilation_Unit then
Unit_Kind := Nkind (Unit (P));
- if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
- N_Package_Declaration)
- or else Unit_Kind in N_Generic_Declaration
+ if Unit_Kind in N_Subprogram_Declaration
+ | N_Package_Declaration
+ | N_Generic_Declaration
then
Unit_Name := Defining_Entity (Unit (P));
@@ -7562,7 +7507,7 @@ package body Sem_Prag is
-- Attribute belongs on the base type. If the view of the type is
-- currently private, it also belongs on the underlying type.
- -- In Ada_2020, the pragma can apply to a formal type, for which
+ -- In Ada 2020, the pragma can apply to a formal type, for which
-- there may be no underlying type.
if Prag_Id = Pragma_Atomic
@@ -7731,11 +7676,12 @@ package body Sem_Prag is
if SPARK_Mode = On
and then Prag_Id = Pragma_Volatile
- and then not Nkind_In (Original_Node (Decl),
- N_Full_Type_Declaration,
- N_Object_Declaration,
- N_Single_Protected_Declaration,
- N_Single_Task_Declaration)
+ and then Nkind (Original_Node (Decl)) not in
+ N_Full_Type_Declaration |
+ N_Formal_Type_Declaration |
+ N_Object_Declaration |
+ N_Single_Protected_Declaration |
+ N_Single_Task_Declaration
then
Error_Pragma_Arg
("argument of pragma % must denote a full type or object "
@@ -7750,23 +7696,60 @@ package body Sem_Prag is
procedure Process_Compile_Time_Warning_Or_Error is
P : Node_Id := Parent (N);
Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
+
begin
- -- In GNATprove mode, pragmas Compile_Time_Error and
+ Check_Arg_Count (2);
+ Check_No_Identifiers;
+ Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
+ Analyze_And_Resolve (Arg1x, Standard_Boolean);
+
+ -- In GNATprove mode, pragma Compile_Time_Error is translated as
+ -- a Check pragma in GNATprove mode, handled as an assumption in
+ -- GNATprove. This is correct as the compiler will issue an error
+ -- if the condition cannot be statically evaluated to False.
-- Compile_Time_Warning are ignored, as the analyzer may not have the
-- same information as the compiler (in particular regarding size of
- -- objects decided in gigi) so it makes no sense to issue an error or
- -- warning in GNATprove.
+ -- objects decided in gigi) so it makes no sense to issue a warning
+ -- in GNATprove.
if GNATprove_Mode then
- Rewrite (N, Make_Null_Statement (Loc));
+ if Prag_Id = Pragma_Compile_Time_Error then
+ declare
+ New_Args : List_Id;
+ begin
+ -- Implement Compile_Time_Error by generating
+ -- a corresponding Check pragma:
+
+ -- pragma Check (name, condition);
+
+ -- where name is the identifier matching the pragma name. So
+ -- rewrite pragma in this manner and analyze the result.
+
+ New_Args := New_List
+ (Make_Pragma_Argument_Association
+ (Loc,
+ Expression => Make_Identifier (Loc, Pname)),
+ Make_Pragma_Argument_Association
+ (Sloc (Arg1x),
+ Expression => Arg1x));
+
+ -- Rewrite as Check pragma
+
+ Rewrite (N,
+ Make_Pragma (Loc,
+ Chars => Name_Check,
+ Pragma_Argument_Associations => New_Args));
+
+ Analyze (N);
+ end;
+
+ else
+ Rewrite (N, Make_Null_Statement (Loc));
+ end if;
+
return;
end if;
- Check_Arg_Count (2);
- Check_No_Identifiers;
- Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
- Analyze_And_Resolve (Arg1x, Standard_Boolean);
-
-- If the condition is known at compile time (now), validate it now.
-- Otherwise, register the expression for validation after the back
-- end has been called, because it might be known at compile time
@@ -7780,7 +7763,7 @@ package body Sem_Prag is
else
while Present (P) and then Nkind (P) not in N_Generic_Declaration
loop
- if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then
+ if Nkind (P) in N_Package_Body | N_Subprogram_Body then
P := Corresponding_Spec (P);
else
P := Parent (P);
@@ -7926,17 +7909,17 @@ package body Sem_Prag is
then
-- Give error if same as our pragma or Export/Convention
- if Nam_In (Pragma_Name_Unmapped (Decl),
- Name_Export,
- Name_Convention,
- Pragma_Name_Unmapped (N))
+ if Pragma_Name_Unmapped (Decl)
+ in Name_Export
+ | Name_Convention
+ | Pragma_Name_Unmapped (N)
then
exit;
-- Case of Import/Interface or the other way round
- elsif Nam_In (Pragma_Name_Unmapped (Decl),
- Name_Interface, Name_Import)
+ elsif Pragma_Name_Unmapped (Decl)
+ in Name_Interface | Name_Import
then
-- Here we know that we have Import and Interface. It
-- doesn't matter which way round they are. See if
@@ -7995,59 +7978,24 @@ package body Sem_Prag is
Error_Pragma_Arg
("cannot change convention for overridden dispatching "
& "operation", Arg1);
- end if;
-
- -- Special checks for Convention_Stdcall
-
- if C = Convention_Stdcall then
-
- -- A dispatching call is not allowed. A dispatching subprogram
- -- cannot be used to interface to the Win32 API, so in fact
- -- this check does not impose any effective restriction.
-
- if Is_Dispatching_Operation (E) then
- Error_Msg_Sloc := Sloc (E);
-
- -- Note: make this unconditional so that if there is more
- -- than one call to which the pragma applies, we get a
- -- message for each call. Also don't use Error_Pragma,
- -- so that we get multiple messages.
-
- Error_Msg_N
- ("dispatching subprogram# cannot use Stdcall convention!",
- Arg1);
-
- -- Several allowed cases
-
- elsif Is_Subprogram_Or_Generic_Subprogram (E)
-
- -- A variable is OK
-
- or else Ekind (E) = E_Variable
-
- -- A component as well. The entity does not have its Ekind
- -- set until the enclosing record declaration is fully
- -- analyzed.
- or else Nkind (Parent (E)) = N_Component_Declaration
+ -- Special check for convention Stdcall: a dispatching call is not
+ -- allowed. A dispatching subprogram cannot be used to interface
+ -- to the Win32 API, so this check actually does not impose any
+ -- effective restriction.
- -- An access to subprogram is also allowed
-
- or else
- (Is_Access_Type (E)
- and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
-
- -- Allow internal call to set convention of subprogram type
-
- or else Ekind (E) = E_Subprogram_Type
- then
- null;
+ elsif Is_Dispatching_Operation (E)
+ and then C = Convention_Stdcall
+ then
+ -- Note: make this unconditional so that if there is more
+ -- than one call to which the pragma applies, we get a
+ -- message for each call. Also don't use Error_Pragma,
+ -- so that we get multiple messages.
- else
- Error_Pragma_Arg
- ("second argument of pragma% must be subprogram (type)",
- Arg2);
- end if;
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_N
+ ("dispatching subprogram# cannot use Stdcall convention!",
+ Get_Pragma_Arg (Arg1));
end if;
-- Set the convention
@@ -8058,26 +8006,38 @@ package body Sem_Prag is
-- For the case of a record base type, also set the convention of
-- any anonymous access types declared in the record which do not
-- currently have a specified convention.
+ -- Similarly for an array base type and anonymous access types
+ -- components.
- if Is_Record_Type (E) and then Is_Base_Type (E) then
- declare
- Comp : Node_Id;
+ if Is_Base_Type (E) then
+ if Is_Record_Type (E) then
+ declare
+ Comp : Node_Id;
- begin
- Comp := First_Component (E);
- while Present (Comp) loop
- if Present (Etype (Comp))
- and then Ekind_In (Etype (Comp),
- E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
- and then not Has_Convention_Pragma (Comp)
- then
- Set_Convention (Comp, C);
- end if;
+ begin
+ Comp := First_Component (E);
+ while Present (Comp) loop
+ if Present (Etype (Comp))
+ and then
+ Ekind (Etype (Comp)) in
+ E_Anonymous_Access_Type |
+ E_Anonymous_Access_Subprogram_Type
+ and then not Has_Convention_Pragma (Comp)
+ then
+ Set_Convention (Comp, C);
+ end if;
- Next_Component (Comp);
- end loop;
- end;
+ Next_Component (Comp);
+ end loop;
+ end;
+
+ elsif Is_Array_Type (E)
+ and then Ekind (Component_Type (E)) in
+ E_Anonymous_Access_Type |
+ E_Anonymous_Access_Subprogram_Type
+ then
+ Set_Convention (Designated_Type (Component_Type (E)), C);
+ end if;
end if;
-- Deal with incomplete/private type case, where underlying type
@@ -8139,6 +8099,7 @@ package body Sem_Prag is
E : Entity_Id;
E1 : Entity_Id;
Id : Node_Id;
+ Subp : Entity_Id;
-- Start of processing for Process_Convention
@@ -8235,8 +8196,8 @@ package body Sem_Prag is
E := Alias (E);
- elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
- N_Private_Extension_Declaration)
+ elsif Nkind (Parent (E)) in
+ N_Full_Type_Declaration | N_Private_Extension_Declaration
and then Scope (E) = Scope (Alias (E))
then
E := Alias (E);
@@ -8260,7 +8221,7 @@ package body Sem_Prag is
-- Check that we are not applying this to a named constant
- if Ekind_In (E, E_Named_Integer, E_Named_Real) then
+ if Ekind (E) in E_Named_Integer | E_Named_Real then
Error_Msg_Name_1 := Pname;
Error_Msg_N
("cannot apply pragma% to named constant!",
@@ -8310,13 +8271,115 @@ package body Sem_Prag is
Error_Pragma_Arg
("second argument of pragma% must be a subprogram", Arg2);
end if;
+
+ -- Special checks for C_Variadic_n
+
+ elsif C in Convention_C_Variadic then
+
+ -- Several allowed cases
+
+ if Is_Subprogram_Or_Generic_Subprogram (E) then
+ Subp := E;
+
+ -- An access to subprogram is also allowed
+
+ elsif Is_Access_Type (E)
+ and then Ekind (Designated_Type (E)) = E_Subprogram_Type
+ then
+ Subp := Designated_Type (E);
+
+ -- Allow internal call to set convention of subprogram type
+
+ elsif Ekind (E) = E_Subprogram_Type then
+ Subp := E;
+
+ else
+ Error_Pragma_Arg
+ ("argument of pragma% must be subprogram or access type",
+ Arg2);
+ Subp := Empty;
+ end if;
+
+ -- ISO C requires a named parameter before the ellipsis, so a
+ -- variadic C function taking 0 fixed parameter cannot exist.
+
+ if C = Convention_C_Variadic_0 then
+
+ Error_Msg_N
+ ("??C_Variadic_0 cannot be used for an 'I'S'O C function",
+ Get_Pragma_Arg (Arg2));
+
+ -- Now check the number of parameters of the subprogram and give
+ -- an error if it is lower than n.
+
+ elsif Present (Subp) then
+ declare
+ Minimum : constant Nat :=
+ Convention_Id'Pos (C) -
+ Convention_Id'Pos (Convention_C_Variadic_0);
+
+ Count : Nat;
+ Formal : Entity_Id;
+
+ begin
+ Count := 0;
+ Formal := First_Formal (Subp);
+ while Present (Formal) loop
+ Count := Count + 1;
+ Next_Formal (Formal);
+ end loop;
+
+ if Count < Minimum then
+ Error_Msg_Uint_1 := UI_From_Int (Minimum);
+ Error_Pragma_Arg
+ ("argument of pragma% must have at least"
+ & "^ parameters", Arg2);
+ end if;
+ end;
+ end if;
+
+ -- Special checks for Stdcall
+
+ elsif C = Convention_Stdcall then
+
+ -- Several allowed cases
+
+ if Is_Subprogram_Or_Generic_Subprogram (E)
+
+ -- A variable is OK
+
+ or else Ekind (E) = E_Variable
+
+ -- A component as well. The entity does not have its Ekind
+ -- set until the enclosing record declaration is fully
+ -- analyzed.
+
+ or else Nkind (Parent (E)) = N_Component_Declaration
+
+ -- An access to subprogram is also allowed
+
+ or else
+ (Is_Access_Type (E)
+ and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
+
+ -- Allow internal call to set convention of subprogram type
+
+ or else Ekind (E) = E_Subprogram_Type
+ then
+ null;
+
+ else
+ Error_Pragma_Arg
+ ("argument of pragma% must be subprogram or access type",
+ Arg2);
+ end if;
end if;
+ Set_Convention_From_Pragma (E);
+
-- Deal with non-subprogram cases
if not Is_Subprogram_Or_Generic_Subprogram (E) then
- Set_Convention_From_Pragma (E);
-
if Is_Type (E) then
-- The pragma must apply to a first subtype, but it can also
@@ -8344,9 +8407,6 @@ package body Sem_Prag is
-- compilation unit.
else
- Comp_Unit := Get_Source_Unit (E);
- Set_Convention_From_Pragma (E);
-
-- Treat a pragma Import as an implicit body, and pragma import
-- as implicit reference (for navigation in GNAT Studio).
@@ -8391,6 +8451,7 @@ package body Sem_Prag is
-- Otherwise Loop through the homonyms of the pragma argument's
-- entity, an apply convention to those in the current scope.
+ Comp_Unit := Get_Source_Unit (E);
E1 := Ent;
loop
@@ -8516,7 +8577,7 @@ package body Sem_Prag is
Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
Def_Id := Entity (Arg_Internal);
- if not Ekind_In (Def_Id, E_Constant, E_Variable) then
+ if Ekind (Def_Id) not in E_Constant | E_Variable then
Error_Pragma_Arg
("pragma% must designate an object", Arg_Internal);
end if;
@@ -8741,8 +8802,8 @@ package body Sem_Prag is
Match := False;
elsif Etype (Def_Id) /= Standard_Void_Type
- and then Nam_In (Pname, Name_Export_Procedure,
- Name_Import_Procedure)
+ and then
+ Pname in Name_Export_Procedure | Name_Import_Procedure
then
Match := False;
@@ -9000,7 +9061,8 @@ package body Sem_Prag is
Set_Mechanism_Value
(Formal, Expression (Massoc));
- -- Set entity on identifier (needed by ASIS)
+ -- Set entity on identifier for proper tree
+ -- structure.
Set_Entity (Choice, Formal);
@@ -9152,7 +9214,7 @@ package body Sem_Prag is
-- Various error checks
- if Ekind_In (Def_Id, E_Variable, E_Constant) then
+ if Ekind (Def_Id) in E_Variable | E_Constant then
-- We do not permit Import to apply to a renaming declaration
@@ -9651,9 +9713,9 @@ package body Sem_Prag is
-- pragma Inline_Always (Proc);
-- end Pack;
- elsif Nkind_In (Context, N_Package_Specification,
- N_Protected_Definition,
- N_Task_Definition)
+ elsif Nkind (Context) in N_Package_Specification
+ | N_Protected_Definition
+ | N_Task_Definition
and then Init_List = Visible_Declarations (Context)
and then Prag_List = Private_Declarations (Context)
then
@@ -9918,15 +9980,6 @@ package body Sem_Prag is
then
Error_Msg_N
("Inline cannot apply to a formal subprogram", N);
-
- -- If Subp is a renaming, it is the renamed entity that
- -- will appear in any call, and be inlined. However, for
- -- ASIS uses it is convenient to indicate that the renaming
- -- itself is an inlined subprogram, so that some gnatcheck
- -- rules can be applied in the absence of expansion.
-
- elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
- Set_Inline_Flags (Subp);
end if;
end if;
@@ -10079,6 +10132,18 @@ package body Sem_Prag is
Applies := True;
else
+ -- Check for RM 13.1(9.2/4): If a [...] aspect_specification
+ -- is given that directly specifies an aspect of an entity,
+ -- then it is illegal to give another [...]
+ -- aspect_specification that directly specifies the same
+ -- aspect of the entity.
+ -- We only check Subp directly as per "directly specifies"
+ -- above and because the case of pragma Inline is really
+ -- special given its pre aspect usage.
+
+ Check_Duplicate_Pragma (Subp);
+ Record_Rep_Item (Subp, N);
+
Make_Inline (Subp);
-- For the pragma case, climb homonym chain. This is
@@ -10090,8 +10155,8 @@ package body Sem_Prag is
while Present (Homonym (Subp))
and then Scope (Homonym (Subp)) = Current_Scope
loop
- Make_Inline (Homonym (Subp));
Subp := Homonym (Subp);
+ Make_Inline (Subp);
end loop;
end if;
end if;
@@ -10461,25 +10526,36 @@ package body Sem_Prag is
else
Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
end if;
+
+ -- Special processing for No_Tasking restriction placed in
+ -- a configuration pragmas file.
+
+ elsif R_Id = No_Tasking and then No (Cunit (Main_Unit)) then
+ Set_Global_No_Tasking;
end if;
- -- If this is a warning, then set the warning unless we already
- -- have a real restriction active (we never want a warning to
- -- override a real restriction).
+ Set_Restriction (R_Id, N, Warn);
- if Warn then
- if not Restriction_Active (R_Id) then
- Set_Restriction (R_Id, N);
- Restriction_Warnings (R_Id) := True;
- end if;
+ if R_Id = No_Dynamic_CPU_Assignment
+ or else R_Id = No_Tasks_Unassigned_To_CPU
+ then
+ -- These imply No_Dependence =>
+ -- "System.Multiprocessors.Dispatching_Domains".
+ -- This is not strictly what the AI says, but it eliminates
+ -- the need for run-time checks, which are undesirable in
+ -- this context.
+
+ Set_Restriction_No_Dependence
+ (Sel_Comp
+ (Sel_Comp ("system", "multiprocessors", Loc),
+ "dispatching_domains"),
+ Warn);
+ end if;
- -- If real restriction case, then set it and make sure that the
- -- restriction warning flag is off, since a real restriction
- -- always overrides a warning.
+ if R_Id = No_Tasks_Unassigned_To_CPU then
+ -- Likewise, imply No_Dynamic_CPU_Assignment
- else
- Set_Restriction (R_Id, N);
- Restriction_Warnings (R_Id) := False;
+ Set_Restriction (No_Dynamic_CPU_Assignment, N, Warn);
end if;
-- Check for obsolescent restrictions in Ada 2005 mode
@@ -10623,26 +10699,7 @@ package body Sem_Prag is
("pragma ignored, value too large??", Arg);
end if;
- -- Warning case. If the real restriction is active, then we
- -- ignore the request, since warning never overrides a real
- -- restriction. Otherwise we set the proper warning. Note that
- -- this circuit sets the warning again if it is already set,
- -- which is what we want, since the constant may have changed.
-
- if Warn then
- if not Restriction_Active (R_Id) then
- Set_Restriction
- (R_Id, N, Integer (UI_To_Int (Val)));
- Restriction_Warnings (R_Id) := True;
- end if;
-
- -- Real restriction case, set restriction and make sure warning
- -- flag is off since real restriction always overrides warning.
-
- else
- Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
- Restriction_Warnings (R_Id) := False;
- end if;
+ Set_Restriction (R_Id, N, Warn, Integer (UI_To_Int (Val)));
end if;
Next (Arg);
@@ -11196,7 +11253,7 @@ package body Sem_Prag is
-- Set required policies
-- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
- -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
+ -- (For Ravenscar, Jorvik, and GNAT_Extended_Ravenscar profiles)
-- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
-- (For GNAT_Ravenscar_EDF profile)
-- pragma Locking_Policy (Ceiling_Locking)
@@ -11234,13 +11291,6 @@ package body Sem_Prag is
Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
end Set_Error_Msg_To_Profile_Name;
- -- Local variables
-
- Nod : Node_Id;
- Pref : Node_Id;
- Pref_Id : Node_Id;
- Sel_Id : Node_Id;
-
Profile_Dispatching_Policy : Character;
-- Start of processing for Set_Ravenscar_Profile
@@ -11312,378 +11362,60 @@ package body Sem_Prag is
-- No_Dependence => Ada.Calendar
-- No_Dependence => Ada.Task_Attributes
-- are already set by previous call to Set_Profile_Restrictions.
+ -- Really???
-- Set the following restrictions which were added to Ada 2005:
-- No_Dependence => Ada.Execution_Time.Group_Budget
-- No_Dependence => Ada.Execution_Time.Timers
if Ada_Version >= Ada_2005 then
- Pref_Id := Make_Identifier (Loc, Name_Find ("ada"));
- Sel_Id := Make_Identifier (Loc, Name_Find ("execution_time"));
-
- Pref :=
- Make_Selected_Component
- (Sloc => Loc,
- Prefix => Pref_Id,
- Selector_Name => Sel_Id);
-
- Sel_Id := Make_Identifier (Loc, Name_Find ("group_budgets"));
-
- Nod :=
- Make_Selected_Component
- (Sloc => Loc,
- Prefix => Pref,
- Selector_Name => Sel_Id);
-
- Set_Restriction_No_Dependence
- (Unit => Nod,
- Warn => Treat_Restrictions_As_Warnings,
- Profile => Ravenscar);
-
- Sel_Id := Make_Identifier (Loc, Name_Find ("timers"));
-
- Nod :=
- Make_Selected_Component
- (Sloc => Loc,
- Prefix => Pref,
- Selector_Name => Sel_Id);
-
- Set_Restriction_No_Dependence
- (Unit => Nod,
- Warn => Treat_Restrictions_As_Warnings,
- Profile => Ravenscar);
+ declare
+ Execution_Time : constant Node_Id :=
+ Sel_Comp ("ada", "execution_time", Loc);
+ Group_Budgets : constant Node_Id :=
+ Sel_Comp (Execution_Time, "group_budgets");
+ Timers : constant Node_Id :=
+ Sel_Comp (Execution_Time, "timers");
+ begin
+ Set_Restriction_No_Dependence
+ (Unit => Group_Budgets,
+ Warn => Treat_Restrictions_As_Warnings,
+ Profile => Ravenscar);
+ Set_Restriction_No_Dependence
+ (Unit => Timers,
+ Warn => Treat_Restrictions_As_Warnings,
+ Profile => Ravenscar);
+ end;
end if;
-- Set the following restriction which was added to Ada 2012 (see
- -- AI-0171):
+ -- AI05-0171):
-- No_Dependence => System.Multiprocessors.Dispatching_Domains
if Ada_Version >= Ada_2012 then
- Pref_Id := Make_Identifier (Loc, Name_Find ("system"));
- Sel_Id := Make_Identifier (Loc, Name_Find ("multiprocessors"));
-
- Pref :=
- Make_Selected_Component
- (Sloc => Loc,
- Prefix => Pref_Id,
- Selector_Name => Sel_Id);
-
- Sel_Id := Make_Identifier (Loc, Name_Find ("dispatching_domains"));
-
- Nod :=
- Make_Selected_Component
- (Sloc => Loc,
- Prefix => Pref,
- Selector_Name => Sel_Id);
-
Set_Restriction_No_Dependence
- (Unit => Nod,
+ (Sel_Comp
+ (Sel_Comp ("system", "multiprocessors", Loc),
+ "dispatching_domains"),
Warn => Treat_Restrictions_As_Warnings,
Profile => Ravenscar);
- end if;
- end Set_Ravenscar_Profile;
- -----------------------------------
- -- Validate_Acc_Condition_Clause --
- -----------------------------------
-
- procedure Validate_Acc_Condition_Clause (Clause : Node_Id) is
- begin
- Analyze_And_Resolve (Clause);
+ -- Set the following restriction which was added to Ada 2020,
+ -- but as a binding interpretation:
+ -- No_Dependence => Ada.Synchronous_Barriers
+ -- for Ravenscar (and therefore for Ravenscar variants) but not
+ -- for Jorvik. The unit Ada.Synchronous_Barriers was introduced
+ -- in Ada2012 (AI05-0174).
- if not Is_Boolean_Type (Etype (Clause)) then
- Error_Pragma ("expected a boolean");
- end if;
- end Validate_Acc_Condition_Clause;
-
- ------------------------------
- -- Validate_Acc_Data_Clause --
- ------------------------------
-
- procedure Validate_Acc_Data_Clause (Clause : Node_Id) is
- Expr : Node_Id;
-
- begin
- Expr := Acc_First (Clause);
- while Present (Expr) loop
- if Nkind (Expr) /= N_Identifier then
- Error_Pragma ("expected an identifer");
+ if Profile /= Jorvik then
+ Set_Restriction_No_Dependence
+ (Sel_Comp ("ada", "synchronous_barriers", Loc),
+ Warn => Treat_Restrictions_As_Warnings,
+ Profile => Ravenscar);
end if;
-
- Analyze_And_Resolve (Expr);
-
- Expr := Acc_Next (Expr);
- end loop;
- end Validate_Acc_Data_Clause;
-
- ----------------------------------
- -- Validate_Acc_Int_Expr_Clause --
- ----------------------------------
-
- procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id) is
- begin
- Analyze_And_Resolve (Clause);
-
- if not Is_Integer_Type (Etype (Clause)) then
- Error_Pragma_Arg ("expected an integer", Clause);
- end if;
- end Validate_Acc_Int_Expr_Clause;
-
- ---------------------------------------
- -- Validate_Acc_Int_Expr_List_Clause --
- ---------------------------------------
-
- procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id) is
- Expr : Node_Id;
-
- begin
- Expr := Acc_First (Clause);
- while Present (Expr) loop
- Analyze_And_Resolve (Expr);
-
- if not Is_Integer_Type (Etype (Expr)) then
- Error_Pragma ("expected an integer");
- end if;
-
- Expr := Acc_Next (Expr);
- end loop;
- end Validate_Acc_Int_Expr_List_Clause;
-
- --------------------------------
- -- Validate_Acc_Loop_Collapse --
- --------------------------------
-
- procedure Validate_Acc_Loop_Collapse (Clause : Node_Id) is
- Count : Uint;
- Par_Loop : Node_Id;
- Stmt : Node_Id;
-
- begin
- -- Make sure the argument is a positive integer
-
- Analyze_And_Resolve (Clause);
-
- Count := Static_Integer (Clause);
- if Count = No_Uint or else Count < 1 then
- Error_Pragma_Arg ("expected a positive integer", Clause);
- end if;
-
- -- Then, make sure we have at least Count-1 tightly-nested loops
- -- (i.e. loops with no statements in between).
-
- Par_Loop := Parent (Parent (Parent (Clause)));
- Stmt := First (Statements (Par_Loop));
-
- -- Skip first pragmas in the parent loop
-
- while Present (Stmt) and then Nkind (Stmt) = N_Pragma loop
- Next (Stmt);
- end loop;
-
- if not Present (Next (Stmt)) then
- while Nkind (Stmt) = N_Loop_Statement and Count > 1 loop
- Stmt := First (Statements (Stmt));
- exit when Present (Next (Stmt));
-
- Count := Count - 1;
- end loop;
- end if;
-
- if Count > 1 then
- Error_Pragma_Arg
- ("Collapse argument too high or loops not tightly nested",
- Clause);
end if;
- end Validate_Acc_Loop_Collapse;
-
- ----------------------------
- -- Validate_Acc_Loop_Gang --
- ----------------------------
-
- procedure Validate_Acc_Loop_Gang (Clause : Node_Id) is
- begin
- Error_Pragma_Arg ("Loop_Gang not implemented", Clause);
- end Validate_Acc_Loop_Gang;
-
- ------------------------------
- -- Validate_Acc_Loop_Vector --
- ------------------------------
-
- procedure Validate_Acc_Loop_Vector (Clause : Node_Id) is
- begin
- Error_Pragma_Arg ("Loop_Vector not implemented", Clause);
- end Validate_Acc_Loop_Vector;
-
- -------------------------------
- -- Validate_Acc_Loop_Worker --
- -------------------------------
-
- procedure Validate_Acc_Loop_Worker (Clause : Node_Id) is
- begin
- Error_Pragma_Arg ("Loop_Worker not implemented", Clause);
- end Validate_Acc_Loop_Worker;
-
- ---------------------------------
- -- Validate_Acc_Name_Reduction --
- ---------------------------------
-
- procedure Validate_Acc_Name_Reduction (Clause : Node_Id) is
-
- -- ??? On top of the following operations, the OpenAcc spec adds the
- -- "bitwise and", "bitwise or" and modulo for C and ".eqv" and
- -- ".neqv" for Fortran. Can we, should we and how do we support them
- -- in Ada?
-
- type Reduction_Op is (Add_Op, Mul_Op, Max_Op, Min_Op, And_Op, Or_Op);
-
- function To_Reduction_Op (Op : String) return Reduction_Op;
- -- Convert operator Op described by a String into its corresponding
- -- enumeration value.
-
- ---------------------
- -- To_Reduction_Op --
- ---------------------
-
- function To_Reduction_Op (Op : String) return Reduction_Op is
- begin
- if Op = "+" then
- return Add_Op;
-
- elsif Op = "*" then
- return Mul_Op;
-
- elsif Op = "max" then
- return Max_Op;
-
- elsif Op = "min" then
- return Min_Op;
-
- elsif Op = "and" then
- return And_Op;
-
- elsif Op = "or" then
- return Or_Op;
-
- else
- Error_Pragma ("unsuported reduction operation");
- end if;
- end To_Reduction_Op;
-
- -- Local variables
-
- Seen : constant Elist_Id := New_Elmt_List;
-
- Expr : Node_Id;
- Reduc_Op : Node_Id;
- Reduc_Var : Node_Id;
-
- -- Start of processing for Validate_Acc_Name_Reduction
-
- begin
- -- Reduction operations appear in the following form:
- -- ("+" => (a, b), "*" => c)
-
- Expr := First (Component_Associations (Clause));
- while Present (Expr) loop
- Reduc_Op := First (Choices (Expr));
- String_To_Name_Buffer (Strval (Reduc_Op));
-
- case To_Reduction_Op (Name_Buffer (1 .. Name_Len)) is
- when Add_Op
- | Mul_Op
- | Max_Op
- | Min_Op
- =>
- Reduc_Var := Acc_First (Expression (Expr));
- while Present (Reduc_Var) loop
- Analyze_And_Resolve (Reduc_Var);
-
- if Contains (Seen, Entity (Reduc_Var)) then
- Error_Pragma ("variable used in multiple reductions");
-
- else
- if Nkind (Reduc_Var) /= N_Identifier
- or not Is_Numeric_Type (Etype (Reduc_Var))
- then
- Error_Pragma
- ("expected an identifier for a Numeric");
- end if;
-
- Append_Elmt (Entity (Reduc_Var), Seen);
- end if;
-
- Reduc_Var := Acc_Next (Reduc_Var);
- end loop;
-
- when And_Op
- | Or_Op
- =>
- Reduc_Var := Acc_First (Expression (Expr));
- while Present (Reduc_Var) loop
- Analyze_And_Resolve (Reduc_Var);
-
- if Contains (Seen, Entity (Reduc_Var)) then
- Error_Pragma ("variable used in multiple reductions");
-
- else
- if Nkind (Reduc_Var) /= N_Identifier
- or not Is_Boolean_Type (Etype (Reduc_Var))
- then
- Error_Pragma
- ("expected a variable of type boolean");
- end if;
-
- Append_Elmt (Entity (Reduc_Var), Seen);
- end if;
-
- Reduc_Var := Acc_Next (Reduc_Var);
- end loop;
- end case;
-
- Next (Expr);
- end loop;
- end Validate_Acc_Name_Reduction;
-
- -----------------------------------
- -- Validate_Acc_Size_Expressions --
- -----------------------------------
-
- procedure Validate_Acc_Size_Expressions (Clause : Node_Id) is
- function Validate_Size_Expr (Expr : Node_Id) return Boolean;
- -- A size expr is either an integer expression or "*"
-
- ------------------------
- -- Validate_Size_Expr --
- ------------------------
-
- function Validate_Size_Expr (Expr : Node_Id) return Boolean is
- begin
- if Nkind (Expr) = N_Operator_Symbol then
- return Get_String_Char (Strval (Expr), 1) = Get_Char_Code ('*');
- end if;
-
- Analyze_And_Resolve (Expr);
-
- return Is_Integer_Type (Etype (Expr));
- end Validate_Size_Expr;
-
- -- Local variables
-
- Expr : Node_Id;
-
- -- Start of processing for Validate_Acc_Size_Expressions
-
- begin
- Expr := Acc_First (Clause);
- while Present (Expr) loop
- if not Validate_Size_Expr (Expr) then
- Error_Pragma
- ("Size expressions should be either integers or '*'");
- end if;
- Expr := Acc_Next (Expr);
- end loop;
- end Validate_Acc_Size_Expressions;
+ end Set_Ravenscar_Profile;
-- Start of processing for Analyze_Pragma
@@ -11700,6 +11432,13 @@ package body Sem_Prag is
Check_Restriction_No_Use_Of_Pragma (N);
+ if Get_Aspect_Id (Chars (Pragma_Identifier (N))) /= No_Aspect then
+ -- 6.1/3 No_Specification_of_Aspect: Identifies an aspect for which
+ -- no aspect_specification, attribute_definition_clause, or pragma
+ -- is given.
+ Check_Restriction_No_Specification_Of_Aspect (N);
+ end if;
+
-- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
-- Default_Scalar_Storage_Order if the -gnatI switch was given.
@@ -11788,6 +11527,7 @@ package body Sem_Prag is
Arg2 := Empty;
Arg3 := Empty;
Arg4 := Empty;
+ Arg5 := Empty;
if Present (Pragma_Argument_Associations (N)) then
Arg_Count := List_Length (Pragma_Argument_Associations (N));
@@ -11801,6 +11541,10 @@ package body Sem_Prag is
if Present (Arg3) then
Arg4 := Next (Arg3);
+
+ if Present (Arg4) then
+ Arg5 := Next (Arg4);
+ end if;
end if;
end if;
end if;
@@ -11853,7 +11597,7 @@ package body Sem_Prag is
-- SIMPLE_OPTION
-- | NAME_VALUE_OPTION
- -- SIMPLE_OPTION ::= Ghost | Synchronous
+ -- SIMPLE_OPTION ::= Ghost | Relaxed_Initialization | Synchronous
-- NAME_VALUE_OPTION ::=
-- Part_Of => ABSTRACT_STATE
@@ -11923,15 +11667,16 @@ package body Sem_Prag is
is
-- Flags used to verify the consistency of options
- AR_Seen : Boolean := False;
- AW_Seen : Boolean := False;
- ER_Seen : Boolean := False;
- EW_Seen : Boolean := False;
- External_Seen : Boolean := False;
- Ghost_Seen : Boolean := False;
- Others_Seen : Boolean := False;
- Part_Of_Seen : Boolean := False;
- Synchronous_Seen : Boolean := False;
+ AR_Seen : Boolean := False;
+ AW_Seen : Boolean := False;
+ ER_Seen : Boolean := False;
+ EW_Seen : Boolean := False;
+ External_Seen : Boolean := False;
+ Ghost_Seen : Boolean := False;
+ Others_Seen : Boolean := False;
+ Part_Of_Seen : Boolean := False;
+ Relaxed_Initialization_Seen : Boolean := False;
+ Synchronous_Seen : Boolean := False;
-- Flags used to store the static value of all external states'
-- expressions.
@@ -12090,10 +11835,10 @@ package body Sem_Prag is
-- external properties.
elsif Nkind (Prop) = N_Identifier
- and then Nam_In (Chars (Prop), Name_Async_Readers,
- Name_Async_Writers,
- Name_Effective_Reads,
- Name_Effective_Writes)
+ and then Chars (Prop) in Name_Async_Readers
+ | Name_Async_Writers
+ | Name_Effective_Reads
+ | Name_Effective_Writes
then
null;
@@ -12412,6 +12157,12 @@ package body Sem_Prag is
Check_Duplicate_Option (Opt, Synchronous_Seen);
Check_Ghost_Synchronous;
+ -- Relaxed_Initialization
+
+ elsif Chars (Opt) = Name_Relaxed_Initialization then
+ Check_Duplicate_Option
+ (Opt, Relaxed_Initialization_Seen);
+
-- Option Part_Of without an encapsulating state is
-- illegal (SPARK RM 7.1.4(8)).
@@ -12564,8 +12315,8 @@ package body Sem_Prag is
Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
- if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
- N_Package_Declaration)
+ if Nkind (Pack_Decl) not in
+ N_Generic_Package_Declaration | N_Package_Declaration
then
Pragma_Misplaced;
return;
@@ -12628,306 +12379,6 @@ package body Sem_Prag is
Analyze_If_Present (Pragma_Initial_Condition);
end Abstract_State;
- --------------
- -- Acc_Data --
- --------------
-
- when Pragma_Acc_Data => Acc_Data : declare
- Clause_Names : constant Name_List :=
- (Name_Attach,
- Name_Copy,
- Name_Copy_In,
- Name_Copy_Out,
- Name_Create,
- Name_Delete,
- Name_Detach,
- Name_Device_Ptr,
- Name_No_Create,
- Name_Present);
-
- Clause : Node_Id;
- Clauses : Args_List (Clause_Names'Range);
-
- begin
- if not OpenAcc_Enabled then
- return;
- end if;
-
- GNAT_Pragma;
-
- if Nkind (Parent (N)) /= N_Loop_Statement then
- Error_Pragma
- ("Acc_Data pragma should be placed in loop or block "
- & "statements");
- end if;
-
- Gather_Associations (Clause_Names, Clauses);
-
- for Id in Clause_Names'First .. Clause_Names'Last loop
- Clause := Clauses (Id);
-
- if Present (Clause) then
- case Clause_Names (Id) is
- when Name_Copy
- | Name_Copy_In
- | Name_Copy_Out
- | Name_Create
- | Name_Device_Ptr
- | Name_Present
- =>
- Validate_Acc_Data_Clause (Clause);
-
- when Name_Attach
- | Name_Detach
- | Name_Delete
- | Name_No_Create
- =>
- Error_Pragma ("unsupported pragma clause");
-
- when others =>
- raise Program_Error;
- end case;
- end if;
- end loop;
-
- Set_Is_OpenAcc_Environment (Parent (N));
- end Acc_Data;
-
- --------------
- -- Acc_Loop --
- --------------
-
- when Pragma_Acc_Loop => Acc_Loop : declare
- Clause_Names : constant Name_List :=
- (Name_Auto,
- Name_Collapse,
- Name_Gang,
- Name_Independent,
- Name_Acc_Private,
- Name_Reduction,
- Name_Seq,
- Name_Tile,
- Name_Vector,
- Name_Worker);
-
- Clause : Node_Id;
- Clauses : Args_List (Clause_Names'Range);
- Par : Node_Id;
-
- begin
- if not OpenAcc_Enabled then
- return;
- end if;
-
- GNAT_Pragma;
-
- -- Make sure the pragma is in an openacc construct
-
- Check_Loop_Pragma_Placement;
-
- Par := Parent (N);
- while Present (Par)
- and then (Nkind (Par) /= N_Loop_Statement
- or else not Is_OpenAcc_Environment (Par))
- loop
- Par := Parent (Par);
- end loop;
-
- if not Is_OpenAcc_Environment (Par) then
- Error_Pragma
- ("Acc_Loop directive must be associated with an OpenAcc "
- & "construct region");
- end if;
-
- Gather_Associations (Clause_Names, Clauses);
-
- for Id in Clause_Names'First .. Clause_Names'Last loop
- Clause := Clauses (Id);
-
- if Present (Clause) then
- case Clause_Names (Id) is
- when Name_Auto
- | Name_Independent
- | Name_Seq
- =>
- null;
-
- when Name_Collapse =>
- Validate_Acc_Loop_Collapse (Clause);
-
- when Name_Gang =>
- Validate_Acc_Loop_Gang (Clause);
-
- when Name_Acc_Private =>
- Validate_Acc_Data_Clause (Clause);
-
- when Name_Reduction =>
- Validate_Acc_Name_Reduction (Clause);
-
- when Name_Tile =>
- Validate_Acc_Size_Expressions (Clause);
-
- when Name_Vector =>
- Validate_Acc_Loop_Vector (Clause);
-
- when Name_Worker =>
- Validate_Acc_Loop_Worker (Clause);
-
- when others =>
- raise Program_Error;
- end case;
- end if;
- end loop;
-
- Set_Is_OpenAcc_Loop (Parent (N));
- end Acc_Loop;
-
- ----------------------------------
- -- Acc_Parallel and Acc_Kernels --
- ----------------------------------
-
- when Pragma_Acc_Parallel
- | Pragma_Acc_Kernels
- =>
- Acc_Kernels_Or_Parallel : declare
- Clause_Names : constant Name_List :=
- (Name_Acc_If,
- Name_Async,
- Name_Copy,
- Name_Copy_In,
- Name_Copy_Out,
- Name_Create,
- Name_Default,
- Name_Device_Ptr,
- Name_Device_Type,
- Name_Num_Gangs,
- Name_Num_Workers,
- Name_Present,
- Name_Vector_Length,
- Name_Wait,
-
- -- Parallel only
-
- Name_Acc_Private,
- Name_First_Private,
- Name_Reduction,
-
- -- Kernels only
-
- Name_Attach,
- Name_No_Create);
-
- Clause : Node_Id;
- Clauses : Args_List (Clause_Names'Range);
-
- begin
- if not OpenAcc_Enabled then
- return;
- end if;
-
- GNAT_Pragma;
- Check_Loop_Pragma_Placement;
-
- if Nkind (Parent (N)) /= N_Loop_Statement then
- Error_Pragma
- ("pragma should be placed in loop or block statements");
- end if;
-
- Gather_Associations (Clause_Names, Clauses);
-
- for Id in Clause_Names'First .. Clause_Names'Last loop
- Clause := Clauses (Id);
-
- if Present (Clause) then
- if Chars (Parent (Clause)) = No_Name then
- Error_Pragma ("all arguments should be associations");
- else
- case Clause_Names (Id) is
-
- -- Note: According to the OpenAcc Standard v2.6,
- -- Async's argument should be optional. Because this
- -- complicates parsing the clause, the argument is
- -- made mandatory. The standard defines two negative
- -- values, acc_async_noval and acc_async_sync. When
- -- given acc_async_noval as value, the clause should
- -- behave as if no argument was given. According to
- -- the standard, acc_async_noval is defined in header
- -- files for C and Fortran, thus this value should
- -- probably be defined in the OpenAcc Ada library once
- -- it is implemented.
-
- when Name_Async
- | Name_Num_Gangs
- | Name_Num_Workers
- | Name_Vector_Length
- =>
- Validate_Acc_Int_Expr_Clause (Clause);
-
- when Name_Acc_If =>
- Validate_Acc_Condition_Clause (Clause);
-
- -- Unsupported by GCC
-
- when Name_Attach
- | Name_No_Create
- =>
- Error_Pragma ("unsupported clause");
-
- when Name_Acc_Private
- | Name_First_Private
- =>
- if Prag_Id /= Pragma_Acc_Parallel then
- Error_Pragma
- ("argument is only available for 'Parallel' "
- & "construct");
- else
- Validate_Acc_Data_Clause (Clause);
- end if;
-
- when Name_Copy
- | Name_Copy_In
- | Name_Copy_Out
- | Name_Create
- | Name_Device_Ptr
- | Name_Present
- =>
- Validate_Acc_Data_Clause (Clause);
-
- when Name_Reduction =>
- if Prag_Id /= Pragma_Acc_Parallel then
- Error_Pragma
- ("argument is only available for 'Parallel' "
- & "construct");
- else
- Validate_Acc_Name_Reduction (Clause);
- end if;
-
- when Name_Default =>
- if Chars (Clause) /= Name_None then
- Error_Pragma ("expected none");
- end if;
-
- when Name_Device_Type =>
- Error_Pragma ("unsupported pragma clause");
-
- -- Similar to Name_Async, Name_Wait's arguments should
- -- be optional. However, this can be simulated using
- -- acc_async_noval, hence, we do not bother making the
- -- argument optional for now.
-
- when Name_Wait =>
- Validate_Acc_Int_Expr_List_Clause (Clause);
-
- when others =>
- raise Program_Error;
- end case;
- end if;
- end if;
- end loop;
-
- Set_Is_OpenAcc_Environment (Parent (N));
- end Acc_Kernels_Or_Parallel;
-
------------
-- Ada_83 --
------------
@@ -13497,8 +12948,9 @@ package body Sem_Prag is
if Arg_Count > 1 then
Check_Optional_Identifier (Arg2, Name_Message);
- -- Provide semantic annnotations for optional argument, for
+ -- Provide semantic annotations for optional argument, for
-- ASIS use, before rewriting.
+ -- Is this still needed???
Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
Append_To (New_Args, New_Copy_Tree (Arg2));
@@ -13699,9 +13151,7 @@ package body Sem_Prag is
-- The Ghost policy must be either Check or Ignore
-- (SPARK RM 6.9(6)).
- if not Nam_In (Chars (Policy), Name_Check,
- Name_Ignore)
- then
+ if Chars (Policy) not in Name_Check | Name_Ignore then
Error_Pragma_Arg
("argument of pragma % Ghost must be Check or "
& "Ignore", Policy);
@@ -13832,41 +13282,66 @@ package body Sem_Prag is
| Pragma_No_Caching
=>
Async_Effective : declare
- Obj_Decl : Node_Id;
- Obj_Id : Entity_Id;
-
+ Obj_Or_Type_Decl : Node_Id;
+ Obj_Or_Type_Id : Entity_Id;
begin
GNAT_Pragma;
Check_No_Identifiers;
Check_At_Most_N_Arguments (1);
- Obj_Decl := Find_Related_Context (N, Do_Checks => True);
-
- -- Object declaration
-
- if Nkind (Obj_Decl) /= N_Object_Declaration then
- Pragma_Misplaced;
- return;
+ Obj_Or_Type_Decl := Find_Related_Context (N, Do_Checks => True);
+
+ -- Pragma must apply to a object declaration or to a type
+ -- declaration (only the former in the No_Caching case).
+ -- Original_Node is necessary to account for untagged derived
+ -- types that are rewritten as subtypes of their
+ -- respective root types.
+
+ if Nkind (Obj_Or_Type_Decl) /= N_Object_Declaration then
+ if Prag_Id = Pragma_No_Caching
+ or else Nkind (Original_Node (Obj_Or_Type_Decl)) not in
+ N_Full_Type_Declaration |
+ N_Private_Type_Declaration |
+ N_Formal_Type_Declaration |
+ N_Task_Type_Declaration |
+ N_Protected_Type_Declaration
+ then
+ Pragma_Misplaced;
+ return;
+ end if;
end if;
- Obj_Id := Defining_Entity (Obj_Decl);
+ Obj_Or_Type_Id := Defining_Entity (Obj_Or_Type_Decl);
-- Perform minimal verification to ensure that the argument is at
- -- least a variable. Subsequent finer grained checks will be done
- -- at the end of the declarative region the contains the pragma.
+ -- least a variable or a type. Subsequent finer grained checks
+ -- will be done at the end of the declarative region that
+ -- contains the pragma.
- if Ekind (Obj_Id) = E_Variable then
+ if Ekind (Obj_Or_Type_Id) = E_Variable
+ or else Is_Type (Obj_Or_Type_Id)
+ then
+
+ -- In the case of a type, pragma is a type-related
+ -- representation item and so requires checks common to
+ -- all type-related representation items.
+
+ if Is_Type (Obj_Or_Type_Id)
+ and then Rep_Item_Too_Late (Obj_Or_Type_Id, N)
+ then
+ return;
+ end if;
-- A pragma that applies to a Ghost entity becomes Ghost for
-- the purposes of legality checks and removal of ignored Ghost
-- code.
- Mark_Ghost_Pragma (N, Obj_Id);
+ Mark_Ghost_Pragma (N, Obj_Or_Type_Id);
-- Chain the pragma on the contract for further processing by
-- Analyze_External_Property_In_Decl_Part.
- Add_Contract_Item (N, Obj_Id);
+ Add_Contract_Item (N, Obj_Or_Type_Id);
-- Analyze the Boolean expression (if any)
@@ -13877,7 +13352,8 @@ package body Sem_Prag is
-- Otherwise the external property applies to a constant
else
- Error_Pragma ("pragma % must apply to a volatile object");
+ Error_Pragma
+ ("pragma % must apply to a volatile type or object");
end if;
end Async_Effective;
@@ -14083,9 +13559,7 @@ package body Sem_Prag is
if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E))
or else
(Nkind (D) = N_Object_Declaration
- and then (Ekind (E) = E_Constant
- or else
- Ekind (E) = E_Variable)
+ and then Ekind (E) in E_Constant | E_Variable
and then Nkind (Object_Definition (D)) =
N_Constrained_Array_Definition)
or else
@@ -14518,7 +13992,7 @@ package body Sem_Prag is
-- identifier is Name.
if Nkind (Arg1) /= N_Pragma_Argument_Association
- or else Nam_In (Chars (Arg1), No_Name, Name_Name)
+ or else Chars (Arg1) in No_Name | Name_Name
then
-- Old syntax
@@ -14531,7 +14005,7 @@ package body Sem_Prag is
-- Check forbidden check kind
- if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
+ if Chars (Kind) in Name_Name | Name_Policy then
Error_Msg_Name_2 := Chars (Kind);
Error_Pragma_Arg
("pragma% does not allow% as check name", Arg1);
@@ -14715,7 +14189,7 @@ package body Sem_Prag is
-- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
when Pragma_Complex_Representation => Complex_Representation : declare
- E_Id : Entity_Id;
+ E_Id : Node_Id;
E : Entity_Id;
Ent : Entity_Id;
@@ -15054,9 +14528,9 @@ package body Sem_Prag is
-- or subprogram body because it cannot benefit from forward
-- references.
- if Nkind_In (Subp_Decl, N_Entry_Body,
- N_Subprogram_Body,
- N_Subprogram_Body_Stub)
+ if Nkind (Subp_Decl) in N_Entry_Body
+ | N_Subprogram_Body
+ | N_Subprogram_Body_Stub
then
-- The legality checks of pragma Contract_Cases are affected by
-- the SPARK mode in effect and the volatility of the context.
@@ -15286,6 +14760,140 @@ package body Sem_Prag is
& "effect?j?", N);
end if;
+ --------------------
+ -- CUDA_Execute --
+ --------------------
+
+ -- pragma CUDA_Execute (PROCEDURE_CALL_STATEMENT,
+ -- EXPRESSION,
+ -- EXPRESSION,
+ -- [, EXPRESSION
+ -- [, EXPRESSION]]);
+
+ when Pragma_CUDA_Execute => CUDA_Execute : declare
+
+ function Is_Acceptable_Dim3 (N : Node_Id) return Boolean;
+ -- Returns True if N is an acceptable argument for CUDA_Execute,
+ -- false otherwise.
+
+ ------------------------
+ -- Is_Acceptable_Dim3 --
+ ------------------------
+
+ function Is_Acceptable_Dim3 (N : Node_Id) return Boolean is
+ Tmp : Node_Id;
+ begin
+ if Etype (N) = RTE (RE_Dim3) or else Is_Integer_Type (Etype (N))
+ then
+ return True;
+ end if;
+
+ if Nkind (N) = N_Aggregate
+ and then List_Length (Expressions (N)) = 3
+ then
+ Tmp := First (Expressions (N));
+ while Present (Tmp) loop
+ Analyze_And_Resolve (Tmp, Any_Integer);
+ Tmp := Next (Tmp);
+ end loop;
+ return True;
+ end if;
+
+ return False;
+ end Is_Acceptable_Dim3;
+
+ -- Local variables
+
+ Block_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg3);
+ Grid_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg2);
+ Kernel_Call : constant Node_Id := Get_Pragma_Arg (Arg1);
+ Shared_Memory : Node_Id;
+ Stream : Node_Id;
+
+ -- Start of processing for CUDA_Execute
+
+ begin
+
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (3);
+ Check_At_Most_N_Arguments (5);
+
+ Analyze_And_Resolve (Kernel_Call);
+ if Nkind (Kernel_Call) /= N_Function_Call
+ or else Etype (Kernel_Call) /= Standard_Void_Type
+ then
+ -- In `pragma CUDA_Execute (Kernel_Call (...), ...)`,
+ -- GNAT sees Kernel_Call as an N_Function_Call since
+ -- Kernel_Call "looks" like an expression. However, only
+ -- procedures can be kernels, so to make things easier for the
+ -- user the error message complains about Kernel_Call not being
+ -- a procedure call.
+
+ Error_Msg_N ("first argument of & must be a procedure call", N);
+ end if;
+
+ Analyze (Grid_Dimensions);
+ if not Is_Acceptable_Dim3 (Grid_Dimensions) then
+ Error_Msg_N
+ ("second argument of & must be an Integer, Dim3 or aggregate "
+ & "containing 3 Integers", N);
+ end if;
+
+ Analyze (Block_Dimensions);
+ if not Is_Acceptable_Dim3 (Block_Dimensions) then
+ Error_Msg_N
+ ("third argument of & must be an Integer, Dim3 or aggregate "
+ & "containing 3 Integers", N);
+ end if;
+
+ if Present (Arg4) then
+ Shared_Memory := Get_Pragma_Arg (Arg4);
+ Analyze_And_Resolve (Shared_Memory, Any_Integer);
+
+ if Present (Arg5) then
+ Stream := Get_Pragma_Arg (Arg5);
+ Analyze_And_Resolve (Stream, RTE (RE_Stream_T));
+ end if;
+ end if;
+ end CUDA_Execute;
+
+ -----------------
+ -- CUDA_Global --
+ -----------------
+
+ -- pragma CUDA_Global (IDENTIFIER);
+
+ when Pragma_CUDA_Global => CUDA_Global : declare
+ Arg_Node : Node_Id;
+ Kernel_Proc : Entity_Id;
+ Pack_Id : Entity_Id;
+ begin
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (1);
+ Check_At_Most_N_Arguments (1);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ Arg_Node := Get_Pragma_Arg (Arg1);
+ Analyze (Arg_Node);
+
+ Kernel_Proc := Entity (Arg_Node);
+ Pack_Id := Scope (Kernel_Proc);
+
+ if Ekind (Kernel_Proc) /= E_Procedure then
+ Error_Msg_NE ("& must be a procedure", N, Kernel_Proc);
+
+ elsif Ekind (Pack_Id) /= E_Package
+ or else not Is_Library_Level_Entity (Pack_Id)
+ then
+ Error_Msg_NE
+ ("& must reside in a library-level package", N, Kernel_Proc);
+
+ else
+ Set_Is_CUDA_Kernel (Kernel_Proc);
+ end if;
+ end CUDA_Global;
+
----------------
-- CPP_Vtable --
----------------
@@ -15314,13 +14922,13 @@ package body Sem_Prag is
Ada_2012_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
+ Arg := Get_Pragma_Arg (Arg1);
-- Subprogram case
if Nkind (P) = N_Subprogram_Body then
Check_In_Main_Program;
- Arg := Get_Pragma_Arg (Arg1);
Analyze_And_Resolve (Arg, Any_Integer);
Ent := Defining_Unit_Name (Specification (P));
@@ -15367,7 +14975,6 @@ package body Sem_Prag is
-- Task case
elsif Nkind (P) = N_Task_Definition then
- Arg := Get_Pragma_Arg (Arg1);
Ent := Defining_Identifier (Parent (P));
-- The expression must be analyzed in the special manner
@@ -15376,6 +14983,16 @@ package body Sem_Prag is
Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
+ -- See comment in Sem_Ch13 about the following restrictions
+
+ if Is_OK_Static_Expression (Arg) then
+ if Expr_Value (Arg) = Uint_0 then
+ Check_Restriction (No_Tasks_Unassigned_To_CPU, N);
+ end if;
+ else
+ Check_Restriction (No_Dynamic_CPU_Assignment, N);
+ end if;
+
-- Anything else is incorrect
else
@@ -15464,11 +15081,11 @@ package body Sem_Prag is
Call := Get_Pragma_Arg (Arg1);
end if;
- if Nkind_In (Call, N_Expanded_Name,
- N_Function_Call,
- N_Identifier,
- N_Indexed_Component,
- N_Selected_Component)
+ if Nkind (Call) in N_Expanded_Name
+ | N_Function_Call
+ | N_Identifier
+ | N_Indexed_Component
+ | N_Selected_Component
then
-- If this pragma Debug comes from source, its argument was
-- parsed as a name form (which is syntactically identical).
@@ -15603,8 +15220,8 @@ package body Sem_Prag is
-- The associated private type [extension] has been found, stop
-- the search.
- elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
- N_Private_Type_Declaration)
+ elsif Nkind (Stmt) in N_Private_Extension_Declaration
+ | N_Private_Type_Declaration
then
Typ := Defining_Entity (Stmt);
exit;
@@ -15853,9 +15470,9 @@ package body Sem_Prag is
-- or subprogram body because it cannot benefit from forward
-- references.
- if Nkind_In (Subp_Decl, N_Entry_Body,
- N_Subprogram_Body,
- N_Subprogram_Body_Stub)
+ if Nkind (Subp_Decl) in N_Entry_Body
+ | N_Subprogram_Body
+ | N_Subprogram_Body_Stub
then
-- The legality checks of pragmas Depends and Global are
-- affected by the SPARK mode in effect and the volatility
@@ -16209,8 +15826,8 @@ package body Sem_Prag is
Mark_Ghost_Pragma (N, Cunit_Ent);
- if Nkind_In (Unit (Cunit_Node), N_Package_Body,
- N_Subprogram_Body)
+ if Nkind (Unit (Cunit_Node)) in
+ N_Package_Body | N_Subprogram_Body
then
Error_Pragma ("pragma% must refer to a spec, not a body");
else
@@ -17184,8 +16801,8 @@ package body Sem_Prag is
-- Task unit declared without a definition cannot be subject to
-- pragma Ghost (SPARK RM 6.9(19)).
- elsif Nkind_In (Stmt, N_Single_Task_Declaration,
- N_Task_Type_Declaration)
+ elsif Nkind (Stmt) in
+ N_Single_Task_Declaration | N_Task_Type_Declaration
then
Error_Pragma ("pragma % cannot apply to a task type");
return;
@@ -17198,8 +16815,8 @@ package body Sem_Prag is
-- When pragma Ghost applies to an untagged derivation, the
-- derivation is transformed into a [sub]type declaration.
- if Nkind_In (Stmt, N_Full_Type_Declaration,
- N_Subtype_Declaration)
+ if Nkind (Stmt) in
+ N_Full_Type_Declaration | N_Subtype_Declaration
and then Comes_From_Source (Orig_Stmt)
and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
and then Nkind (Type_Definition (Orig_Stmt)) =
@@ -17233,14 +16850,14 @@ package body Sem_Prag is
-- The pragma applies to a legal construct, stop the traversal
- elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
- N_Full_Type_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Object_Declaration,
- N_Private_Extension_Declaration,
- N_Private_Type_Declaration,
- N_Subprogram_Declaration,
- N_Subtype_Declaration)
+ elsif Nkind (Stmt) in N_Abstract_Subprogram_Declaration
+ | N_Full_Type_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Object_Declaration
+ | N_Private_Extension_Declaration
+ | N_Private_Type_Declaration
+ | N_Subprogram_Declaration
+ | N_Subtype_Declaration
then
Id := Defining_Entity (Stmt);
exit;
@@ -17269,12 +16886,12 @@ package body Sem_Prag is
-- Protected and task types cannot be subject to pragma Ghost
-- (SPARK RM 6.9(19)).
- if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
+ if Nkind (Context) in N_Protected_Body | N_Protected_Definition
then
Error_Pragma ("pragma % cannot apply to a protected type");
return;
- elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
+ elsif Nkind (Context) in N_Task_Body | N_Task_Definition then
Error_Pragma ("pragma % cannot apply to a task type");
return;
end if;
@@ -17468,9 +17085,9 @@ package body Sem_Prag is
-- or subprogram body because it cannot benefit from forward
-- references.
- if Nkind_In (Subp_Decl, N_Entry_Body,
- N_Subprogram_Body,
- N_Subprogram_Body_Stub)
+ if Nkind (Subp_Decl) in N_Entry_Body
+ | N_Subprogram_Body
+ | N_Subprogram_Body_Stub
then
-- The legality checks of pragmas Depends and Global are
-- affected by the SPARK mode in effect and the volatility
@@ -17521,8 +17138,8 @@ package body Sem_Prag is
begin
GP := Parent (Parent (N));
- if Nkind_In (GP, N_Package_Declaration,
- N_Generic_Package_Declaration)
+ if Nkind (GP) in
+ N_Package_Declaration | N_Generic_Package_Declaration
then
GP := Parent (GP);
end if;
@@ -17535,15 +17152,12 @@ package body Sem_Prag is
if Present (CS) then
- -- If we have multiple instances, concatenate them, but
- -- not in ASIS, where we want the original tree.
+ -- If we have multiple instances, concatenate them.
- if not ASIS_Mode then
- Start_String (Strval (CS));
- Store_String_Char (' ');
- Store_String_Chars (Strval (Str));
- Set_Strval (CS, End_String);
- end if;
+ Start_String (Strval (CS));
+ Store_String_Char (' ');
+ Store_String_Chars (Strval (Str));
+ Set_Strval (CS, End_String);
else
Set_Ident_String (Current_Sem_Unit, Str);
@@ -17673,8 +17287,8 @@ package body Sem_Prag is
-- "synchronized".
or else
- (Ekind_In (Typ, E_Record_Type_With_Private,
- E_Record_Subtype_With_Private)
+ (Ekind (Typ) in E_Record_Type_With_Private
+ | E_Record_Subtype_With_Private
and then Synchronized_Present (Parent (Typ))))
then
null;
@@ -17689,7 +17303,7 @@ package body Sem_Prag is
-- By_Protected_Procedure to the primitive procedure of a task
-- interface.
- if Chars (Arg2) = Name_By_Protected_Procedure
+ if Chars (Get_Pragma_Arg (Arg2)) = Name_By_Protected_Procedure
and then Is_Interface (Typ)
and then Is_Task_Interface (Typ)
then
@@ -17714,6 +17328,18 @@ package body Sem_Prag is
return;
end if;
+ -- Ada 2012 (AI12-0279): Cannot apply the implementation_kind
+ -- By_Protected_Procedure to a procedure that has aspect Yield
+
+ if Chars (Get_Pragma_Arg (Arg2)) = Name_By_Protected_Procedure
+ and then Has_Yield_Aspect (Proc_Id)
+ then
+ Error_Pragma_Arg
+ ("implementation kind By_Protected_Procedure cannot be "
+ & "applied to entities with aspect 'Yield", Arg2);
+ return;
+ end if;
+
Record_Rep_Item (Proc_Id, N);
end Implemented;
@@ -18118,8 +17744,8 @@ package body Sem_Prag is
Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
- if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
- N_Package_Declaration)
+ if Nkind (Pack_Decl) not in
+ N_Generic_Package_Declaration | N_Package_Declaration
then
Pragma_Misplaced;
return;
@@ -18390,8 +18016,8 @@ package body Sem_Prag is
Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
- if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
- N_Package_Declaration)
+ if Nkind (Pack_Decl) not in
+ N_Generic_Package_Declaration | N_Package_Declaration
then
Pragma_Misplaced;
return;
@@ -18728,7 +18354,7 @@ package body Sem_Prag is
Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
end if;
- if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
+ if Nkind (P) not in N_Task_Definition | N_Protected_Definition then
Pragma_Misplaced;
return;
@@ -18927,9 +18553,9 @@ package body Sem_Prag is
-- A [class-wide] invariant may be associated a [limited] private
-- type or a private extension.
- elsif Ekind_In (Typ, E_Limited_Private_Type,
- E_Private_Type,
- E_Record_Type_With_Private)
+ elsif Ekind (Typ) in E_Limited_Private_Type
+ | E_Private_Type
+ | E_Record_Type_With_Private
then
null;
@@ -18976,15 +18602,6 @@ package body Sem_Prag is
Set_Has_Own_Invariants (Typ);
- -- Set the Invariants_Ignored flag if that policy is in effect
-
- Set_Invariants_Ignored (Typ,
- Present (Check_Policy_List)
- and then
- (Policy_In_Effect (Name_Invariant) = Name_Ignore
- and then
- Policy_In_Effect (Name_Type_Invariant) = Name_Ignore));
-
-- If the invariant is class-wide, then it can be inherited by
-- derived or interface implementing types. The type is said to
-- have "inheritable" invariants.
@@ -19589,8 +19206,7 @@ package body Sem_Prag is
if Chars (Variant) = No_Name then
Error_Pragma_Arg_Ident ("expect name `Increases`", Variant);
- elsif not Nam_In (Chars (Variant), Name_Decreases,
- Name_Increases)
+ elsif Chars (Variant) not in Name_Decreases | Name_Increases
then
declare
Name : String := Get_Name_String (Chars (Variant));
@@ -19824,7 +19440,8 @@ package body Sem_Prag is
-- Otherwise the pragma is associated with an illegal construct
else
- Error_Pragma ("pragma % must apply to a protected entry");
+ Error_Pragma
+ ("pragma % must apply to a protected entry declaration");
return;
end if;
@@ -19902,11 +19519,11 @@ package body Sem_Prag is
-- Must appear for a spec or generic spec
- if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
- N_Generic_Package_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Package_Declaration,
- N_Subprogram_Declaration)
+ if Nkind (Unit (Cunit (Current_Sem_Unit))) not in
+ N_Generic_Package_Declaration |
+ N_Generic_Subprogram_Declaration |
+ N_Package_Declaration |
+ N_Subprogram_Declaration
then
Error_Pragma
(Fix_Error
@@ -20037,7 +19654,7 @@ package body Sem_Prag is
-- The pragma must apply to an access-to-object type
- if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) then
+ if Ekind (Typ) in E_Access_Type | E_General_Access_Type then
null;
-- Give a detailed error message on all other access type kinds
@@ -20155,7 +19772,7 @@ package body Sem_Prag is
raise Pragma_Exit;
end if;
- -- Loop to find matching procedures
+ -- Loop to find matching procedures or functions (Ada 2020)
E := Entity (Id);
@@ -20163,8 +19780,13 @@ package body Sem_Prag is
while Present (E)
and then Scope (E) = Current_Scope
loop
- if Ekind_In (E, E_Generic_Procedure, E_Procedure) then
+ -- Ada 2020 (AI12-0269): A function can be No_Return
+ if Ekind (E) in E_Generic_Procedure | E_Procedure
+ or else (Ada_Version >= Ada_2020
+ and then
+ Ekind (E) in E_Generic_Function | E_Function)
+ then
-- Check that the pragma is not applied to a body.
-- First check the specless body case, to give a
-- different error message. These checks do not apply
@@ -20246,6 +19868,11 @@ package body Sem_Prag is
and then From_Aspect_Specification (N)
then
Set_No_Return (Entity (Id));
+
+ elsif Ada_Version >= Ada_2020 then
+ Error_Pragma_Arg
+ ("no subprogram& found for pragma%", Arg);
+
else
Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
end if;
@@ -20449,8 +20076,7 @@ package body Sem_Prag is
if Present (Ename) then
- -- If entity name matches, we are fine. Save entity in
- -- pragma argument, for ASIS use.
+ -- If entity name matches, we are fine.
if Chars (Ename) = Chars (Ent) then
Set_Entity (Ename, Ent);
@@ -20477,7 +20103,7 @@ package body Sem_Prag is
exit;
else
- Ent := Next_Literal (Ent);
+ Next_Literal (Ent);
end if;
end loop;
end if;
@@ -20551,9 +20177,8 @@ package body Sem_Prag is
and then
(Chars (Arg1) = Name_Entity
or else
- Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
- N_Identifier,
- N_Operator_Symbol))
+ Nkind (Get_Pragma_Arg (Arg1)) in
+ N_Character_Literal | N_Identifier | N_Operator_Symbol)
then
Ename := Get_Pragma_Arg (Arg1);
@@ -20989,9 +20614,8 @@ package body Sem_Prag is
-- they may not depend on variable input. This check is
-- left to the SPARK prover.
- elsif Ekind_In (Item_Id, E_Abstract_State,
- E_Constant,
- E_Variable)
+ elsif Ekind (Item_Id) in
+ E_Abstract_State | E_Constant | E_Variable
then
Has_Item := True;
Constits := Part_Of_Constituents (State_Id);
@@ -21308,9 +20932,9 @@ package body Sem_Prag is
Check_Arg_Is_Library_Level_Local_Name (Arg1);
if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
- or else not
- Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
- E_Constant)
+ or else
+ Ekind (Entity (Get_Pragma_Arg (Arg1))) not in
+ E_Variable | E_Constant
then
Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
end if;
@@ -21766,7 +21390,7 @@ package body Sem_Prag is
-- Task or Protected, must be of type Integer
- elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
+ elsif Nkind (P) in N_Protected_Definition | N_Task_Definition then
Arg := Get_Pragma_Arg (Arg1);
Ent := Defining_Identifier (Parent (P));
@@ -21948,6 +21572,9 @@ package body Sem_Prag is
if Chars (Argx) = Name_Ravenscar then
Set_Ravenscar_Profile (Ravenscar, N);
+ elsif Chars (Argx) = Name_Jorvik then
+ Set_Ravenscar_Profile (Jorvik, N);
+
elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
@@ -22130,7 +21757,7 @@ package body Sem_Prag is
-- Now declare the operators. We do this during analysis rather
-- than expansion, since we want the operators available if we
- -- are operating in -gnatc or ASIS mode.
+ -- are operating in -gnatc mode.
Declare_Shift_Operator (Name_Rotate_Left);
Declare_Shift_Operator (Name_Rotate_Right);
@@ -22175,9 +21802,8 @@ package body Sem_Prag is
procedure Check_Arg (Arg : Node_Id) is
begin
- if not Nkind_In (Original_Node (Arg),
- N_String_Literal,
- N_Identifier)
+ if Nkind (Original_Node (Arg)) not in
+ N_String_Literal | N_Identifier
then
Error_Pragma_Arg
("inappropriate argument for pragma %", Arg);
@@ -22193,7 +21819,7 @@ package body Sem_Prag is
Def_Id := Entity (Internal);
- if not Ekind_In (Def_Id, E_Constant, E_Variable) then
+ if Ekind (Def_Id) not in E_Constant | E_Variable then
Error_Pragma_Arg
("pragma% must designate an object", Internal);
end if;
@@ -22343,9 +21969,8 @@ package body Sem_Prag is
loop
Def_Id := Get_Base_Subprogram (E);
- if not Ekind_In (Def_Id, E_Function,
- E_Generic_Function,
- E_Operator)
+ if Ekind (Def_Id) not in
+ E_Function | E_Generic_Function | E_Operator
then
Error_Pragma_Arg
("pragma% requires a function name", Arg1);
@@ -22880,8 +22505,8 @@ package body Sem_Prag is
Mark_Ghost_Pragma (N, Cunit_Ent);
- if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
- N_Generic_Package_Declaration)
+ if Nkind (Unit (Cunit_Node)) not in
+ N_Package_Declaration | N_Generic_Package_Declaration
then
Error_Pragma
("pragma% can only apply to a package declaration");
@@ -23080,8 +22705,8 @@ package body Sem_Prag is
Mark_Ghost_Pragma (N, Cunit_Ent);
- if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
- N_Generic_Package_Declaration)
+ if Nkind (Unit (Cunit_Node)) not in
+ N_Package_Declaration | N_Generic_Package_Declaration
then
Error_Pragma
("pragma% can only apply to a package declaration");
@@ -23383,7 +23008,7 @@ package body Sem_Prag is
-- anonymous type whose name cannot be used to issue error
-- messages. Recover the original entity of the type.
- if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
+ if Ekind (Entity) in E_Protected_Type | E_Task_Type then
Err_Id :=
Defining_Entity
(Original_Node (Unit_Declaration_Node (Entity)));
@@ -23415,6 +23040,11 @@ package body Sem_Prag is
-- pragma in which case the current pragma is illegal as
-- it cannot "complete".
+ elsif Get_SPARK_Mode_From_Annotation (N) = Off
+ and then (Is_Generic_Unit (Entity) or else In_Instance)
+ then
+ null;
+
else
Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
Error_Msg_Sloc := Sloc (Err_Id);
@@ -23440,28 +23070,28 @@ package body Sem_Prag is
procedure Add_Entity_To_Name_Buffer is
begin
- if Ekind_In (E, E_Entry, E_Entry_Family) then
+ if Ekind (E) in E_Entry | E_Entry_Family then
Add_Str_To_Name_Buffer ("entry");
- elsif Ekind_In (E, E_Generic_Package,
- E_Package,
- E_Package_Body)
+ elsif Ekind (E) in E_Generic_Package
+ | E_Package
+ | E_Package_Body
then
Add_Str_To_Name_Buffer ("package");
- elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
+ elsif Ekind (E) in E_Protected_Body | E_Protected_Type then
Add_Str_To_Name_Buffer ("protected type");
- elsif Ekind_In (E, E_Function,
- E_Generic_Function,
- E_Generic_Procedure,
- E_Procedure,
- E_Subprogram_Body)
+ elsif Ekind (E) in E_Function
+ | E_Generic_Function
+ | E_Generic_Procedure
+ | E_Procedure
+ | E_Subprogram_Body
then
Add_Str_To_Name_Buffer ("subprogram");
else
- pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
+ pragma Assert (Ekind (E) in E_Task_Body | E_Task_Type);
Add_Str_To_Name_Buffer ("task type");
end if;
end Add_Entity_To_Name_Buffer;
@@ -23520,7 +23150,7 @@ package body Sem_Prag is
-- * The mode of the context
-- * The mode of the spec (if any)
- if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
+ if Nkind (Decl) in N_Entry_Body | N_Subprogram_Body then
-- A stand-alone subprogram body
@@ -23570,7 +23200,7 @@ package body Sem_Prag is
else
pragma Assert
- (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
+ (Nkind (Decl) in N_Protected_Body | N_Task_Body);
Check_Pragma_Conformance
(Context_Pragma => SPARK_Pragma (Body_Id),
@@ -23692,8 +23322,8 @@ package body Sem_Prag is
-- SPARK_Mode of the context because the task does not have any
-- entries that could inherit the mode.
- if not Nkind_In (Decl, N_Single_Task_Declaration,
- N_Task_Type_Declaration)
+ if Nkind (Decl) not in
+ N_Single_Task_Declaration | N_Task_Type_Declaration
then
Set_SPARK_Context;
end if;
@@ -23740,16 +23370,6 @@ package body Sem_Prag is
-- Start of processing for Do_SPARK_Mode
begin
- -- When a SPARK_Mode pragma appears inside an instantiation whose
- -- enclosing context has SPARK_Mode set to "off", the pragma has
- -- no semantic effect.
-
- if Ignore_SPARK_Mode_Pragmas_In_Instance then
- Rewrite (N, Make_Null_Statement (Loc));
- Analyze (N);
- return;
- end if;
-
GNAT_Pragma;
Check_No_Identifiers;
Check_At_Most_N_Arguments (1);
@@ -23766,6 +23386,18 @@ package body Sem_Prag is
Mode_Id := Get_SPARK_Mode_Type (Mode);
Context := Parent (N);
+ -- When a SPARK_Mode pragma appears inside an instantiation whose
+ -- enclosing context has SPARK_Mode set to "off", the pragma has
+ -- no semantic effect.
+
+ if Ignore_SPARK_Mode_Pragmas_In_Instance
+ and then Mode_Id /= Off
+ then
+ Rewrite (N, Make_Null_Statement (Loc));
+ Analyze (N);
+ return;
+ end if;
+
-- The pragma appears in a configuration file
if No (Context) then
@@ -23852,8 +23484,8 @@ package body Sem_Prag is
-- procedure Proc ...;
-- pragma SPARK_Mode ...;
- elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
- N_Subprogram_Declaration)
+ elsif Nkind (Stmt) in N_Generic_Subprogram_Declaration
+ | N_Subprogram_Declaration
or else (Nkind (Stmt) = N_Entry_Declaration
and then Is_Protected_Type
(Scope (Defining_Entity (Stmt))))
@@ -23898,11 +23530,11 @@ package body Sem_Prag is
-- protected body Prot is
-- pragma SPARK_Mode ...;
- if Nkind_In (Context, N_Entry_Body,
- N_Package_Body,
- N_Protected_Body,
- N_Subprogram_Body,
- N_Task_Body)
+ if Nkind (Context) in N_Entry_Body
+ | N_Package_Body
+ | N_Protected_Body
+ | N_Subprogram_Body
+ | N_Task_Body
then
Process_Body (Context);
@@ -23919,9 +23551,9 @@ package body Sem_Prag is
-- private
-- pragma SPARK_Mode ...;
- elsif Nkind_In (Context, N_Package_Specification,
- N_Protected_Definition,
- N_Task_Definition)
+ elsif Nkind (Context) in N_Package_Specification
+ | N_Protected_Definition
+ | N_Task_Definition
then
if List_Containing (N) = Visible_Declarations (Context) then
Process_Visible_Part (Parent (Context));
@@ -23947,8 +23579,8 @@ package body Sem_Prag is
-- procedure Proc ...;
-- pragma SPARK_Mode ...;
- elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
- N_Subprogram_Declaration)
+ elsif Nkind (Context) in N_Generic_Subprogram_Declaration
+ | N_Subprogram_Declaration
then
Process_Overloadable (Context);
@@ -24709,8 +24341,8 @@ package body Sem_Prag is
-- in a library-level package. First determine whether the current
-- compilation unit is a legal context.
- if Nkind_In (Pack_Decl, N_Package_Declaration,
- N_Generic_Package_Declaration)
+ if Nkind (Pack_Decl) in N_Package_Declaration
+ | N_Generic_Package_Declaration
then
null;
@@ -24746,11 +24378,11 @@ package body Sem_Prag is
-- The context is a [generic] subprogram declared at the top level
-- of the [generic] package unit.
- elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
- N_Subprogram_Declaration)
+ elsif Nkind (Subp_Decl) in N_Generic_Subprogram_Declaration
+ | N_Subprogram_Declaration
and then Present (Context)
- and then Nkind_In (Context, N_Generic_Package_Declaration,
- N_Package_Declaration)
+ and then Nkind (Context) in N_Generic_Package_Declaration
+ | N_Package_Declaration
then
null;
@@ -24775,10 +24407,10 @@ package body Sem_Prag is
Add_Contract_Item (N, Subp_Id);
- -- Preanalyze the original aspect argument "Name" for ASIS or for
- -- a generic subprogram to properly capture global references.
+ -- Preanalyze the original aspect argument "Name" for a generic
+ -- subprogram to properly capture global references.
- if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then
+ if Is_Generic_Subprogram (Subp_Id) then
Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
if Present (Asp_Arg) then
@@ -24804,9 +24436,9 @@ package body Sem_Prag is
-- or subprogram body because it cannot benefit from forward
-- references.
- if Nkind_In (Subp_Decl, N_Entry_Body,
- N_Subprogram_Body,
- N_Subprogram_Body_Stub)
+ if Nkind (Subp_Decl) in N_Entry_Body
+ | N_Subprogram_Body
+ | N_Subprogram_Body_Stub
then
-- The legality checks of pragma Test_Case are affected by the
-- SPARK mode in effect and the volatility of the context.
@@ -25469,7 +25101,7 @@ package body Sem_Prag is
Spec_Id := Unique_Defining_Entity (Subp_Decl);
- if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
+ if Ekind (Spec_Id) not in E_Function | E_Generic_Function then
Pragma_Misplaced;
return;
end if;
@@ -25557,7 +25189,7 @@ package body Sem_Prag is
-- DETAILS ::= static_string_EXPRESSION
-- DETAILS ::= On | Off, static_string_EXPRESSION
- -- TOOL_NAME ::= GNAT | GNATProve
+ -- TOOL_NAME ::= GNAT | GNATprove
-- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
@@ -25630,10 +25262,10 @@ package body Sem_Prag is
-- was given otherwise, by shifting the arguments.
if Nkind (Argx) = N_Identifier
- and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
+ and then Chars (Argx) in Name_Gnat | Name_Gnatprove
then
if Chars (Argx) = Name_Gnat then
- if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
+ if CodePeer_Mode or GNATprove_Mode then
Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
raise Pragma_Exit;
@@ -25683,7 +25315,7 @@ package body Sem_Prag is
-- On/Off one argument case was processed by parser
if Nkind (Argx) = N_Identifier
- and then Nam_In (Chars (Argx), Name_On, Name_Off)
+ and then Chars (Argx) in Name_On | Name_Off
then
null;
@@ -26055,7 +25687,7 @@ package body Sem_Prag is
and then
(Etype (Nod) = Disp_Typ
or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
- and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
+ and then Ekind (Entity (Nod)) in E_Constant | E_Variable
then
Error_Msg_NE
("object in class-wide condition must be formal of type &",
@@ -26433,9 +26065,8 @@ package body Sem_Prag is
if Is_Entity_Name (Ref_Item) then
Ref_Item_Id := Entity_Of (Ref_Item);
- if Ekind_In (Ref_Item_Id, E_Abstract_State,
- E_Constant,
- E_Variable)
+ if Ekind (Ref_Item_Id) in
+ E_Abstract_State | E_Constant | E_Variable
and then Present (Encapsulating_State (Ref_Item_Id))
and then Find_Encapsulating_State
(Dep_States, Ref_Item_Id) = Dep_Item_Id
@@ -27072,9 +26703,8 @@ package body Sem_Prag is
-- The input must be a constituent of a state
- if Ekind_In (Input_Id, E_Abstract_State,
- E_Constant,
- E_Variable)
+ if Ekind (Input_Id) in
+ E_Abstract_State | E_Constant | E_Variable
and then Present (Encapsulating_State (Input_Id))
then
State_Id := Encapsulating_State (Input_Id);
@@ -27256,13 +26886,6 @@ package body Sem_Prag is
Body_Outputs => Body_Outputs);
end if;
- -- Matching is disabled in ASIS because clauses are not normalized as
- -- this is a tree altering activity similar to expansion.
-
- if ASIS_Mode then
- goto Leave;
- end if;
-
-- Multiple dependency clauses appear as component associations of an
-- aggregate. Note that the clauses are copied because the algorithm
-- modifies them and this should not be visible in Depends.
@@ -27989,9 +27612,7 @@ package body Sem_Prag is
-- Start of processing for Check_Refined_Global_Item
begin
- if Ekind_In (Item_Id, E_Abstract_State,
- E_Constant,
- E_Variable)
+ if Ekind (Item_Id) in E_Abstract_State | E_Constant | E_Variable
then
Enc_State := Find_Encapsulating_State (States, Item_Id);
end if;
@@ -28085,9 +27706,9 @@ package body Sem_Prag is
-- Single global item declaration
- elsif Nkind_In (List, N_Expanded_Name,
- N_Identifier,
- N_Selected_Component)
+ elsif Nkind (List) in N_Expanded_Name
+ | N_Identifier
+ | N_Selected_Component
then
Check_Refined_Global_Item (List, Global_Mode);
@@ -28217,9 +27838,9 @@ package body Sem_Prag is
-- Single global item declaration
- elsif Nkind_In (List, N_Expanded_Name,
- N_Identifier,
- N_Selected_Component)
+ elsif Nkind (List) in N_Expanded_Name
+ | N_Identifier
+ | N_Selected_Component
then
Collect_Global_Item (List, Mode);
@@ -28906,9 +28527,8 @@ package body Sem_Prag is
-- The constituent is a valid state or object
- elsif Ekind_In (Constit_Id, E_Abstract_State,
- E_Constant,
- E_Variable)
+ elsif Ekind (Constit_Id) in
+ E_Abstract_State | E_Constant | E_Variable
then
Match_Constituent (Constit_Id);
@@ -29315,10 +28935,10 @@ package body Sem_Prag is
Arg : Node_Id;
begin
- -- Preanalyze the original aspect argument for ASIS or for a generic
- -- subprogram to properly capture global references.
+ -- Preanalyze the original aspect argument for a generic subprogram
+ -- to properly capture global references.
- if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then
+ if Is_Generic_Subprogram (Spec_Id) then
Arg :=
Test_Case_Arg
(Prag => N,
@@ -29597,11 +29217,11 @@ package body Sem_Prag is
if Ename = Pnm
or else Pnm = Name_Assertion
or else (Pnm = Name_Statement_Assertions
- and then Nam_In (Ename, Name_Assert,
- Name_Assert_And_Cut,
- Name_Assume,
- Name_Loop_Invariant,
- Name_Loop_Variant))
+ and then Ename in Name_Assert
+ | Name_Assert_And_Cut
+ | Name_Assume
+ | Name_Loop_Invariant
+ | Name_Loop_Variant)
then
Policy := Chars (Get_Pragma_Arg (Last (PPA)));
@@ -29736,11 +29356,11 @@ package body Sem_Prag is
or else (Pnm = Name_Assertion
and then Is_Valid_Assertion_Kind (Nam))
or else (Pnm = Name_Statement_Assertions
- and then Nam_In (Nam, Name_Assert,
- Name_Assert_And_Cut,
- Name_Assume,
- Name_Loop_Invariant,
- Name_Loop_Variant))
+ and then Nam in Name_Assert
+ | Name_Assert_And_Cut
+ | Name_Assume
+ | Name_Loop_Invariant
+ | Name_Loop_Variant)
then
case (Chars (Get_Pragma_Arg (Last (PPA)))) is
when Name_Check
@@ -29820,7 +29440,7 @@ package body Sem_Prag is
-- they depend on variable input. This check is left to the SPARK
-- prover.
- elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
+ elsif Ekind (Item_Id) in E_Abstract_State | E_Variable then
return True;
-- Recursively peek into nested packages and instantiations
@@ -30042,7 +29662,7 @@ package body Sem_Prag is
-- explicit contract.
Prags : constant Node_Id := Contract (Parent_Subp);
- In_Spec_Expr : Boolean;
+ In_Spec_Expr : Boolean := In_Spec_Expression;
Installed : Boolean;
Prag : Node_Id;
New_Prag : Node_Id;
@@ -30057,8 +29677,8 @@ package body Sem_Prag is
Prag := Pre_Post_Conditions (Prags);
while Present (Prag) loop
- if Nam_In (Pragma_Name_Unmapped (Prag),
- Name_Precondition, Name_Postcondition)
+ if Pragma_Name_Unmapped (Prag)
+ in Name_Precondition | Name_Postcondition
and then Class_Present (Prag)
then
-- The generated pragma must be analyzed in the context of
@@ -30211,11 +29831,11 @@ package body Sem_Prag is
procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
begin
- if Nam_In (Mode, Name_In_Out, Name_Input) then
+ if Mode in Name_In_Out | Name_Input then
Append_New_Elmt (Item, Subp_Inputs);
end if;
- if Nam_In (Mode, Name_In_Out, Name_Output) then
+ if Mode in Name_In_Out | Name_Output then
Append_New_Elmt (Item, Subp_Outputs);
end if;
end Collect_Global_Item;
@@ -30233,9 +29853,9 @@ package body Sem_Prag is
-- Single global item declaration
- elsif Nkind_In (List, N_Expanded_Name,
- N_Identifier,
- N_Selected_Component)
+ elsif Nkind (List) in N_Expanded_Name
+ | N_Identifier
+ | N_Selected_Component
then
Collect_Global_Item (List, Mode);
@@ -30287,13 +29907,13 @@ package body Sem_Prag is
-- Process all formal parameters of entries, [generic] subprograms, and
-- their bodies.
- if Ekind_In (Subp_Id, E_Entry,
- E_Entry_Family,
- E_Function,
- E_Generic_Function,
- E_Generic_Procedure,
- E_Procedure,
- E_Subprogram_Body)
+ if Ekind (Subp_Id) in E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Procedure
+ | E_Procedure
+ | E_Subprogram_Body
then
Subp_Decl := Unit_Declaration_Node (Subp_Id);
Spec_Id := Unique_Defining_Entity (Subp_Decl);
@@ -30302,11 +29922,11 @@ package body Sem_Prag is
Formal := First_Entity (Spec_Id);
while Present (Formal) loop
- if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then
+ if Ekind (Formal) in E_In_Out_Parameter | E_In_Parameter then
Append_New_Elmt (Formal, Subp_Inputs);
end if;
- if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
+ if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then
Append_New_Elmt (Formal, Subp_Outputs);
-- Out parameters can act as inputs when the related type is
@@ -30326,7 +29946,7 @@ package body Sem_Prag is
-- Otherwise the input denotes a task type, a task body, or the
-- anonymous object created for a single task type.
- elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body)
+ elsif Ekind (Subp_Id) in E_Task_Type | E_Task_Body
or else Is_Single_Task_Object (Subp_Id)
then
Subp_Decl := Declaration_Node (Subp_Id);
@@ -30338,7 +29958,7 @@ package body Sem_Prag is
-- outputs.
if Is_Entry_Body (Subp_Id)
- or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
+ or else Ekind (Subp_Id) in E_Subprogram_Body | E_Task_Body
then
Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
@@ -30396,7 +30016,7 @@ package body Sem_Prag is
Append_New_Elmt (Typ, Subp_Inputs);
- if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
+ if Ekind (Spec_Id) in E_Entry | E_Entry_Family | E_Procedure then
Append_New_Elmt (Typ, Subp_Outputs);
end if;
@@ -30445,8 +30065,8 @@ package body Sem_Prag is
function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
begin
- return Nam_In (Pragma_Name_Unmapped (N),
- Name_Interrupt_State, Name_Priority_Specific_Dispatching);
+ return Pragma_Name_Unmapped (N)
+ in Name_Interrupt_State | Name_Priority_Specific_Dispatching;
end Delay_Config_Pragma_Analyze;
-----------------------
@@ -30536,7 +30156,9 @@ package body Sem_Prag is
-- Skip internally generated code
- elsif not Comes_From_Source (Stmt) then
+ elsif not Comes_From_Source (Stmt)
+ and then not Comes_From_Source (Original_Node (Stmt))
+ then
-- The anonymous object created for a single concurrent type is a
-- suitable context.
@@ -30601,10 +30223,10 @@ package body Sem_Prag is
Stmt : Node_Id;
Look_For_Body : constant Boolean :=
- Nam_In (Prag_Nam, Name_Refined_Depends,
- Name_Refined_Global,
- Name_Refined_Post,
- Name_Refined_State);
+ Prag_Nam in Name_Refined_Depends
+ | Name_Refined_Global
+ | Name_Refined_Post
+ | Name_Refined_State;
-- Refinement pragmas must be associated with a subprogram body [stub]
-- Start of processing for Find_Related_Declaration_Or_Body
@@ -30681,6 +30303,20 @@ package body Sem_Prag is
elsif Present (Generic_Parent (Specification (Stmt))) then
return Stmt;
+
+ -- Ada 2020: contract on formal subprogram or on generated
+ -- Access_Subprogram_Wrapper, which appears after the related
+ -- Access_Subprogram declaration.
+
+ elsif Is_Generic_Actual_Subprogram (Defining_Entity (Stmt))
+ and then Ada_Version >= Ada_2020
+ then
+ return Stmt;
+
+ elsif Is_Access_Subprogram_Wrapper (Defining_Entity (Stmt))
+ and then Ada_Version >= Ada_2020
+ then
+ return Stmt;
end if;
end if;
@@ -30846,14 +30482,12 @@ package body Sem_Prag is
Args : constant List_Id := Pragma_Argument_Associations (Prag);
begin
- -- Use the expression of the original aspect when compiling for ASIS or
- -- when analyzing the template of a generic unit. In both cases the
- -- aspect's tree must be decorated to allow for ASIS queries or to save
- -- the global references in the generic context.
+ -- Use the expression of the original aspect when analyzing the template
+ -- of a generic unit. In both cases the aspect's tree must be decorated
+ -- to save the global references in the generic context.
if From_Aspect_Specification (Prag)
- and then (ASIS_Mode or else (Present (Context_Id)
- and then Is_Generic_Unit (Context_Id)))
+ and then (Present (Context_Id) and then Is_Generic_Unit (Context_Id))
then
return Corresponding_Aspect (Prag);
@@ -31141,10 +30775,6 @@ package body Sem_Prag is
Sig_Flags : constant array (Pragma_Id) of Int :=
(Pragma_Abort_Defer => -1,
Pragma_Abstract_State => -1,
- Pragma_Acc_Data => 0,
- Pragma_Acc_Kernels => 0,
- Pragma_Acc_Loop => 0,
- Pragma_Acc_Parallel => 0,
Pragma_Ada_83 => -1,
Pragma_Ada_95 => -1,
Pragma_Ada_05 => -1,
@@ -31180,6 +30810,8 @@ package body Sem_Prag is
Pragma_C_Pass_By_Copy => 0,
Pragma_Comment => -1,
Pragma_Common_Object => 0,
+ Pragma_CUDA_Execute => -1,
+ Pragma_CUDA_Global => -1,
Pragma_Compile_Time_Error => -1,
Pragma_Compile_Time_Warning => -1,
Pragma_Compiler_Unit => -1,
@@ -31195,11 +30827,11 @@ package body Sem_Prag is
Pragma_Deadline_Floor => -1,
Pragma_Debug => -1,
Pragma_Debug_Policy => 0,
- Pragma_Detect_Blocking => 0,
Pragma_Default_Initial_Condition => -1,
Pragma_Default_Scalar_Storage_Order => 0,
Pragma_Default_Storage_Pool => 0,
Pragma_Depends => -1,
+ Pragma_Detect_Blocking => 0,
Pragma_Disable_Atomic_Synchronization => 0,
Pragma_Discard_Names => 0,
Pragma_Dispatching_Domain => -1,
@@ -31221,9 +30853,9 @@ package body Sem_Prag is
Pragma_Extensions_Allowed => 0,
Pragma_Extensions_Visible => 0,
Pragma_External => -1,
- Pragma_Favor_Top_Level => 0,
Pragma_External_Name_Casing => 0,
Pragma_Fast_Math => 0,
+ Pragma_Favor_Top_Level => 0,
Pragma_Finalize_Storage_Only => 0,
Pragma_Ghost => 0,
Pragma_Global => -1,
@@ -31287,9 +30919,9 @@ package body Sem_Prag is
Pragma_Obsolescent => 0,
Pragma_Optimize => 0,
Pragma_Optimize_Alignment => 0,
+ Pragma_Ordered => 0,
Pragma_Overflow_Mode => 0,
Pragma_Overriding_Renamings => 0,
- Pragma_Ordered => 0,
Pragma_Pack => 0,
Pragma_Page => 0,
Pragma_Part_Of => 0,
@@ -31297,7 +30929,6 @@ package body Sem_Prag is
Pragma_Passive => 0,
Pragma_Persistent_BSS => 0,
Pragma_Polling => 0,
- Pragma_Prefix_Exception_Messages => 0,
Pragma_Post => -1,
Pragma_Postcondition => -1,
Pragma_Post_Class => -1,
@@ -31307,6 +30938,7 @@ package body Sem_Prag is
Pragma_Predicate_Failure => -1,
Pragma_Preelaborable_Initialization => -1,
Pragma_Preelaborate => 0,
+ Pragma_Prefix_Exception_Messages => 0,
Pragma_Pre_Class => -1,
Pragma_Priority => -1,
Pragma_Priority_Specific_Dispatching => 0,
@@ -31325,35 +30957,35 @@ package body Sem_Prag is
Pragma_Refined_Post => -1,
Pragma_Refined_State => -1,
Pragma_Relative_Deadline => 0,
- Pragma_Rename_Pragma => 0,
Pragma_Remote_Access_Type => -1,
Pragma_Remote_Call_Interface => -1,
Pragma_Remote_Types => -1,
+ Pragma_Rename_Pragma => 0,
Pragma_Restricted_Run_Time => 0,
Pragma_Restriction_Warnings => 0,
Pragma_Restrictions => 0,
Pragma_Reviewable => -1,
Pragma_Secondary_Stack_Size => -1,
- Pragma_Short_Circuit_And_Or => 0,
Pragma_Share_Generic => 0,
Pragma_Shared => 0,
Pragma_Shared_Passive => 0,
+ Pragma_Short_Circuit_And_Or => 0,
Pragma_Short_Descriptors => 0,
Pragma_Simple_Storage_Pool_Type => 0,
Pragma_Source_File_Name => 0,
Pragma_Source_File_Name_Project => 0,
Pragma_Source_Reference => 0,
Pragma_SPARK_Mode => 0,
+ Pragma_Static_Elaboration_Desired => 0,
Pragma_Storage_Size => -1,
Pragma_Storage_Unit => 0,
- Pragma_Static_Elaboration_Desired => 0,
Pragma_Stream_Convert => 0,
Pragma_Style_Checks => 0,
Pragma_Subtitle => 0,
Pragma_Suppress => 0,
- Pragma_Suppress_Exception_Locations => 0,
Pragma_Suppress_All => 0,
Pragma_Suppress_Debug_Info => 0,
+ Pragma_Suppress_Exception_Locations => 0,
Pragma_Suppress_Initialization => 0,
Pragma_System_Name => 0,
Pragma_Task_Dispatching_Policy => 0,
@@ -31687,6 +31319,9 @@ package body Sem_Prag is
Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
Arg2 : constant Node_Id := Next (Arg1);
+ Pname : constant Name_Id := Pragma_Name_Unmapped (N);
+ Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
+
begin
Analyze_And_Resolve (Arg1x, Standard_Boolean);
@@ -31700,8 +31335,6 @@ package body Sem_Prag is
declare
Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
- Pname : constant Name_Id := Pragma_Name_Unmapped (N);
- Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
Str : constant String_Id :=
Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)));
Str_Len : constant Nat := String_Length (Str);
@@ -31761,10 +31394,12 @@ package body Sem_Prag is
if Force then
if Cont = False then
- Error_Msg ("<<~!!", Eloc);
+ Error_Msg
+ ("<<~!!", Eloc, Is_Compile_Time_Pragma => True);
Cont := True;
else
- Error_Msg ("\<<~!!", Eloc);
+ Error_Msg
+ ("\<<~!!", Eloc, Is_Compile_Time_Pragma => True);
end if;
-- Error, rather than warning, or in a body, so we do not
@@ -31775,10 +31410,12 @@ package body Sem_Prag is
else
if Cont = False then
- Error_Msg ("<<~", Eloc);
+ Error_Msg
+ ("<<~", Eloc, Is_Compile_Time_Pragma => True);
Cont := True;
else
- Error_Msg ("\<<~", Eloc);
+ Error_Msg
+ ("\<<~", Eloc, Is_Compile_Time_Pragma => True);
end if;
end if;
@@ -31787,13 +31424,17 @@ package body Sem_Prag is
end;
end if;
- -- Arg1x is not known at compile time, so issue a warning. This can
- -- happen only if the pragma's processing was deferred until after the
- -- back end is run (see Process_Compile_Time_Warning_Or_Error).
- -- Note that the warning control switch applies to both pragmas.
+ -- Arg1x is not known at compile time, so possibly issue an error
+ -- or warning. This can happen only if the pragma's processing
+ -- was deferred until after the back end is run (see
+ -- Process_Compile_Time_Warning_Or_Error). Note that the warning
+ -- control switch applies to only the warning case.
+
+ elsif Prag_Id = Pragma_Compile_Time_Error then
+ Error_Msg_N ("condition is not known at compile time", Arg1x);
elsif Warn_On_Unknown_Compile_Time_Warning then
- Error_Msg_N ("?condition is not known at compile time", Arg1x);
+ Error_Msg_N ("??condition is not known at compile time", Arg1x);
end if;
end Validate_Compile_Time_Warning_Or_Error;
@@ -32098,7 +31739,6 @@ package body Sem_Prag is
elsif Nkind (N) = N_Identifier
and then From_Policy
and then Serious_Errors_Detected = 0
- and then not ASIS_Mode
then
if Chars (N) = Name_Precondition
or else Chars (N) = Name_Postcondition
@@ -32261,6 +31901,64 @@ package body Sem_Prag is
Generate_Reference (Entity (With_Item), N, Set_Ref => False);
end Set_Elab_Unit_Name;
+ -----------------------
+ -- Set_Overflow_Mode --
+ -----------------------
+
+ procedure Set_Overflow_Mode (N : Node_Id) is
+
+ function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type;
+ -- Function to process one pragma argument, Arg
+
+ -----------------------
+ -- Get_Overflow_Mode --
+ -----------------------
+
+ function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+ begin
+ if Chars (Argx) = Name_Strict then
+ return Strict;
+
+ elsif Chars (Argx) = Name_Minimized then
+ return Minimized;
+
+ elsif Chars (Argx) = Name_Eliminated then
+ return Eliminated;
+
+ else
+ raise Program_Error;
+ end if;
+ end Get_Overflow_Mode;
+
+ -- Local variables
+
+ Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
+ Arg2 : constant Node_Id := Next (Arg1);
+
+ -- Start of processing for Set_Overflow_Mode
+
+ begin
+ -- Process first argument
+
+ Scope_Suppress.Overflow_Mode_General :=
+ Get_Overflow_Mode (Arg1);
+
+ -- Case of only one argument
+
+ if No (Arg2) then
+ Scope_Suppress.Overflow_Mode_Assertions :=
+ Scope_Suppress.Overflow_Mode_General;
+
+ -- Case of two arguments present
+
+ else
+ Scope_Suppress.Overflow_Mode_Assertions :=
+ Get_Overflow_Mode (Arg2);
+ end if;
+ end Set_Overflow_Mode;
+
-------------------
-- Test_Case_Arg --
-------------------
@@ -32275,10 +31973,8 @@ package body Sem_Prag is
Args : Node_Id;
begin
- pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
- Name_Mode,
- Name_Name,
- Name_Requires));
+ pragma Assert
+ (Arg_Nam in Name_Ensures | Name_Mode | Name_Name | Name_Requires);
-- The caller requests the aspect argument
@@ -32357,9 +32053,9 @@ package body Sem_Prag is
return Empty;
end Test_Case_Arg;
- -----------------------------------------
+ --------------------------------------------
-- Defer_Compile_Time_Warning_Error_To_BE --
- -----------------------------------------
+ --------------------------------------------
procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id) is
Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
index 88c103a..460fc9c 100644
--- a/gcc/ada/sem_prag.ads
+++ b/gcc/ada/sem_prag.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -49,6 +49,7 @@ package Sem_Prag is
Pragma_Contract_Cases => True,
Pragma_Convention => True,
Pragma_CPU => True,
+ Pragma_CUDA_Global => True,
Pragma_Default_Initial_Condition => True,
Pragma_Default_Storage_Pool => True,
Pragma_Depends => True,
@@ -426,7 +427,7 @@ package Sem_Prag is
-- of the pragma. The argument is extracted in the following manner:
--
-- When the pragma is generated from an aspect, return the corresponding
- -- aspect for ASIS or when Context_Id denotes a generic unit.
+ -- aspect when Context_Id denotes a generic unit.
--
-- Otherwise return the first argument of Prag
--
@@ -530,6 +531,11 @@ package Sem_Prag is
-- the value of the Interface_Name. Otherwise it is encoded as needed by
-- particular operating systems. See the body for details of the encoding.
+ procedure Set_Overflow_Mode (N : Node_Id);
+ -- Sets Sem.Scope_Suppress according to the overflow modes specified in
+ -- the pragma Overflow_Mode passed in argument. This should only be called
+ -- after N has been successfully analyzed.
+
function Test_Case_Arg
(Prag : Node_Id;
Arg_Nam : Name_Id;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 21cbe0a..50a4287 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@@ -177,6 +178,7 @@ package body Sem_Res is
procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Declare_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id);
@@ -226,6 +228,12 @@ package body Sem_Res is
-- is the context type, which is used when the operation is a protected
-- function with no arguments, and the return value is indexed.
+ procedure Resolve_Implicit_Dereference (P : Node_Id);
+ -- Called when P is the prefix of an indexed component, or of a selected
+ -- component, or of a slice. If P is of an access type, we unconditionally
+ -- rewrite it as an explicit dereference. This ensures that the expander
+ -- and the code generator have a fully explicit tree to work with.
+
procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id);
-- A call to a user-defined intrinsic operator is rewritten as a call to
-- the corresponding predefined operator, with suitable conversions. Note
@@ -265,8 +273,7 @@ package body Sem_Res is
procedure Simplify_Type_Conversion (N : Node_Id);
-- Called after N has been resolved and evaluated, but before range checks
- -- have been applied. Currently simplifies a combination of floating-point
- -- to integer conversion and Rounding or Truncation attribute.
+ -- have been applied. This rewrites the conversion into a simpler form.
function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id;
-- A universal_fixed expression in an universal context is unambiguous if
@@ -448,8 +455,8 @@ package body Sem_Res is
and then not
(Nkind (Parent (P)) = N_Subtype_Indication
and then
- Nkind_In (Parent (Parent (P)), N_Component_Definition,
- N_Subtype_Declaration)
+ Nkind (Parent (Parent (P))) in N_Component_Definition
+ | N_Subtype_Declaration
and then Paren_Count (N) = 0)
then
Error_Msg_N
@@ -573,8 +580,8 @@ package body Sem_Res is
-- Legal case is in index or discriminant constraint
- elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint,
- N_Discriminant_Association)
+ elsif Nkind (PN) in N_Index_Or_Discriminant_Constraint
+ | N_Discriminant_Association
then
if Paren_Count (N) > 0 then
Error_Msg_N
@@ -595,9 +602,8 @@ package body Sem_Res is
else
D := PN;
P := Parent (PN);
- while not Nkind_In (P, N_Component_Declaration,
- N_Subtype_Indication,
- N_Entry_Declaration)
+ while Nkind (P) not in
+ N_Component_Declaration | N_Subtype_Indication | N_Entry_Declaration
loop
D := P;
P := Parent (P);
@@ -610,8 +616,8 @@ package body Sem_Res is
-- course a double fault.
if (Nkind (P) = N_Subtype_Indication
- and then Nkind_In (Parent (P), N_Component_Definition,
- N_Derived_Type_Definition)
+ and then Nkind (Parent (P)) in N_Component_Definition
+ | N_Derived_Type_Definition
and then D = Constraint (P))
-- The constraint itself may be given by a subtype indication,
@@ -803,12 +809,12 @@ package body Sem_Res is
function Is_Conditional_Statement (N : Node_Id) return Boolean is
begin
return
- Nkind_In (N, N_And_Then,
- N_Case_Expression,
- N_Case_Statement,
- N_If_Expression,
- N_If_Statement,
- N_Or_Else);
+ Nkind (N) in N_And_Then
+ | N_Case_Expression
+ | N_Case_Statement
+ | N_If_Expression
+ | N_If_Statement
+ | N_Or_Else;
end Is_Conditional_Statement;
-------------------------------
@@ -834,7 +840,7 @@ package body Sem_Res is
begin
return
Nkind (HSS) = N_Handled_Sequence_Of_Statements
- and then Nkind_In (Parent (HSS), N_Entry_Body, N_Subprogram_Body)
+ and then Nkind (Parent (HSS)) in N_Entry_Body | N_Subprogram_Body
and then Is_List_Member (N)
and then List_Containing (N) = Statements (HSS);
end Is_Immediately_Within_Body;
@@ -1142,9 +1148,8 @@ package body Sem_Res is
-- functions, this is never a parameterless call (RM 4.1.4(6)).
if Nkind (Parent (N)) = N_Attribute_Reference
- and then Nam_In (Attribute_Name (Parent (N)), Name_Address,
- Name_Code_Address,
- Name_Access)
+ and then Attribute_Name (Parent (N))
+ in Name_Address | Name_Code_Address | Name_Access
then
return False;
end if;
@@ -1194,9 +1199,9 @@ package body Sem_Res is
and then Ekind (Entity (N)) = E_Procedure
and then not Is_Overloaded (N)
and then
- Nkind_In (Parent (N), N_Parameter_Association,
- N_Function_Call,
- N_Procedure_Call_Statement)
+ Nkind (Parent (N)) in N_Parameter_Association
+ | N_Function_Call
+ | N_Procedure_Call_Statement
then
return;
end if;
@@ -1231,8 +1236,8 @@ package body Sem_Res is
(Nkind (N) = N_Selected_Component
and then (Ekind (Entity (Selector_Name (N))) = E_Function
or else
- (Ekind_In (Entity (Selector_Name (N)), E_Entry,
- E_Procedure)
+ (Ekind (Entity (Selector_Name (N))) in
+ E_Entry | E_Procedure
and then Is_Overloaded (Selector_Name (N)))))
-- If one of the above three conditions is met, rewrite as call. Apply
@@ -1540,9 +1545,9 @@ package body Sem_Res is
elsif In_Instance then
null;
- elsif Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide)
- and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node)))
- and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node)))
+ elsif Op_Name in Name_Op_Multiply | Name_Op_Divide
+ and then Is_Fixed_Point_Type (Etype (Act1))
+ and then Is_Fixed_Point_Type (Etype (Act2))
then
if Pack /= Standard_Standard then
Error := True;
@@ -1552,8 +1557,9 @@ package body Sem_Res is
-- available.
elsif Ada_Version >= Ada_2005
- and then Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne)
- and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type
+ and then Op_Name in Name_Op_Eq | Name_Op_Ne
+ and then (Is_Anonymous_Access_Type (Etype (Act1))
+ or else Is_Anonymous_Access_Type (Etype (Act2)))
then
null;
@@ -1662,7 +1668,7 @@ package body Sem_Res is
and then not In_Instance
then
if Is_Fixed_Point_Type (Typ)
- and then Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide)
+ and then Op_Name in Name_Op_Multiply | Name_Op_Divide
then
-- Already checked above
@@ -1699,7 +1705,7 @@ package body Sem_Res is
-- the equality node will not resolve any remaining ambiguity, and it
-- assumes that the first operand is not overloaded.
- if Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne)
+ if Op_Name in Name_Op_Eq | Name_Op_Ne
and then Ekind (Func) = E_Function
and then Is_Overloaded (Act1)
then
@@ -1752,78 +1758,6 @@ package body Sem_Res is
else
Resolve (N, Typ);
end if;
-
- -- If in ASIS_Mode, propagate operand types to original actuals of
- -- function call, which would otherwise not be fully resolved. If
- -- the call has already been constant-folded, nothing to do. We
- -- relocate the operand nodes rather than copy them, to preserve
- -- original_node pointers, given that the operands themselves may
- -- have been rewritten. If the call was itself a rewriting of an
- -- operator node, nothing to do.
-
- if ASIS_Mode
- and then Nkind (N) in N_Op
- and then Nkind (Original_Node (N)) = N_Function_Call
- then
- declare
- L : Node_Id;
- R : constant Node_Id := Right_Opnd (N);
-
- Old_First : constant Node_Id :=
- First (Parameter_Associations (Original_Node (N)));
- Old_Sec : Node_Id;
-
- begin
- if Is_Binary then
- L := Left_Opnd (N);
- Old_Sec := Next (Old_First);
-
- -- If the original call has named associations, replace the
- -- explicit actual parameter in the association with the proper
- -- resolved operand.
-
- if Nkind (Old_First) = N_Parameter_Association then
- if Chars (Selector_Name (Old_First)) =
- Chars (First_Entity (Op_Id))
- then
- Rewrite (Explicit_Actual_Parameter (Old_First),
- Relocate_Node (L));
- else
- Rewrite (Explicit_Actual_Parameter (Old_First),
- Relocate_Node (R));
- end if;
-
- else
- Rewrite (Old_First, Relocate_Node (L));
- end if;
-
- if Nkind (Old_Sec) = N_Parameter_Association then
- if Chars (Selector_Name (Old_Sec)) =
- Chars (First_Entity (Op_Id))
- then
- Rewrite (Explicit_Actual_Parameter (Old_Sec),
- Relocate_Node (L));
- else
- Rewrite (Explicit_Actual_Parameter (Old_Sec),
- Relocate_Node (R));
- end if;
-
- else
- Rewrite (Old_Sec, Relocate_Node (R));
- end if;
-
- else
- if Nkind (Old_First) = N_Parameter_Association then
- Rewrite (Explicit_Actual_Parameter (Old_First),
- Relocate_Node (R));
- else
- Rewrite (Old_First, Relocate_Node (R));
- end if;
- end if;
- end;
-
- Set_Parent (Original_Node (N), Parent (N));
- end if;
end Make_Call_Into_Operator;
-------------------
@@ -2209,6 +2143,12 @@ package body Sem_Res is
return;
end Resolution_Failed;
+ Literal_Aspect_Map :
+ constant array (N_Numeric_Or_String_Literal) of Aspect_Id :=
+ (N_Integer_Literal => Aspect_Integer_Literal,
+ N_Real_Literal => Aspect_Real_Literal,
+ N_String_Literal => Aspect_String_Literal);
+
-- Start of processing for Resolve
begin
@@ -2220,9 +2160,9 @@ package body Sem_Res is
-- access-to-subprogram type.
if Nkind (N) = N_Attribute_Reference
- and then Nam_In (Attribute_Name (N), Name_Access,
- Name_Unrestricted_Access,
- Name_Unchecked_Access)
+ and then Attribute_Name (N) in Name_Access
+ | Name_Unrestricted_Access
+ | Name_Unchecked_Access
and then Comes_From_Source (N)
and then Is_Entity_Name (Prefix (N))
and then Is_Subprogram (Entity (Prefix (N)))
@@ -2344,10 +2284,18 @@ package body Sem_Res is
Check_Parameterless_Call (N);
-- The resolution of an Expression_With_Actions is determined by
- -- its Expression.
+ -- its Expression, but if the node comes from source it is a
+ -- Declare_Expression and requires scope management.
if Nkind (N) = N_Expression_With_Actions then
- Resolve (Expression (N), Typ);
+ if Comes_From_Source (N)
+ and then N = Original_Node (N)
+ then
+ Resolve_Declare_Expression (N, Typ);
+
+ else
+ Resolve (Expression (N), Typ);
+ end if;
Found := True;
Expr_Type := Etype (Expression (N));
@@ -2632,10 +2580,10 @@ package body Sem_Res is
Set_Entity (N, Seen);
Generate_Reference (Seen, N);
- elsif Nkind_In (N, N_Case_Expression,
- N_Character_Literal,
- N_Delta_Aggregate,
- N_If_Expression)
+ elsif Nkind (N) in N_Case_Expression
+ | N_Character_Literal
+ | N_Delta_Aggregate
+ | N_If_Expression
then
Set_Etype (N, Expr_Type);
@@ -2701,15 +2649,15 @@ package body Sem_Res is
-- with a name that is an explicit dereference, there is
-- nothing to be done at this point.
- elsif Nkind_In (N, N_Attribute_Reference,
- N_And_Then,
- N_Explicit_Dereference,
- N_Identifier,
- N_Indexed_Component,
- N_Or_Else,
- N_Range,
- N_Selected_Component,
- N_Slice)
+ elsif Nkind (N) in N_Attribute_Reference
+ | N_And_Then
+ | N_Explicit_Dereference
+ | N_Identifier
+ | N_Indexed_Component
+ | N_Or_Else
+ | N_Range
+ | N_Selected_Component
+ | N_Slice
or else Nkind (Name (N)) = N_Explicit_Dereference
then
null;
@@ -2826,6 +2774,17 @@ package body Sem_Res is
elsif Nkind (N) = N_Aggregate
and then Etype (N) = Any_Composite
then
+ if Ada_Version >= Ada_2020
+ and then Has_Aspect (Typ, Aspect_Aggregate)
+ then
+ Resolve_Container_Aggregate (N, Typ);
+
+ if Expander_Active then
+ Expand (N);
+ end if;
+ return;
+ end if;
+
-- Disable expansion in any case. If there is a type mismatch
-- it may be fatal to try to expand the aggregate. The flag
-- would otherwise be set to false when the error is posted.
@@ -2912,6 +2871,80 @@ package body Sem_Res is
end;
end if;
+ -- Rewrite Literal as a call if the corresponding literal aspect
+ -- is set.
+
+ if Nkind (N) in N_Numeric_Or_String_Literal
+ and then Present
+ (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N))))
+ then
+ declare
+ function Literal_Text (N : Node_Id) return String_Id;
+ -- Returns the text of a literal node
+
+ -------------------
+ -- Literal_Text --
+ -------------------
+
+ function Literal_Text (N : Node_Id) return String_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Numeric_Or_String_Literal);
+
+ if Nkind (N) = N_String_Literal then
+ return Strval (N);
+ else
+ return String_From_Numeric_Literal (N);
+ end if;
+ end Literal_Text;
+
+ Lit_Aspect : constant Aspect_Id :=
+ Literal_Aspect_Map (Nkind (N));
+
+ Callee : constant Entity_Id :=
+ Entity (Expression (Find_Aspect (Typ, Lit_Aspect)));
+
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Name : constant Node_Id :=
+ Make_Identifier (Loc, Chars (Callee));
+
+ Param : constant Node_Id :=
+ Make_String_Literal (Loc, Literal_Text (N));
+
+ Params : constant List_Id := New_List (Param);
+
+ Call : Node_Id :=
+ Make_Function_Call
+ (Sloc => Loc,
+ Name => Name,
+ Parameter_Associations => Params);
+ begin
+ Set_Entity (Name, Callee);
+ Set_Is_Overloaded (Name, False);
+ if Lit_Aspect = Aspect_String_Literal then
+ Set_Etype (Param, Standard_Wide_Wide_String);
+ else
+ Set_Etype (Param, Standard_String);
+ end if;
+ Set_Etype (Call, Etype (Callee));
+
+ -- Conversion needed in case of an inherited aspect
+ -- of a derived type.
+ --
+ -- ??? Need to do something different here for downward
+ -- tagged conversion case (which is only possible in the
+ -- case of a null extension); the current call to
+ -- Convert_To results in an error message about an illegal
+ -- downward conversion.
+
+ Call := Convert_To (Typ, Call);
+
+ Rewrite (N, Call);
+ end;
+ Analyze_And_Resolve (N, Typ);
+ return;
+ end if;
+
-- Looks like we have a type error, but check for special case
-- of Address wanted, integer found, with the configuration pragma
-- Allow_Integer_Address active. If we have this case, introduce
@@ -2925,7 +2958,7 @@ package body Sem_Res is
return;
-- Under relaxed RM semantics silently replace occurrences of null
- -- by System.Address_Null.
+ -- by System.Null_Address.
elsif Null_To_Null_Address_Convert_OK (N, Typ) then
Replace_Null_By_Null_Address (N);
@@ -3000,7 +3033,7 @@ package body Sem_Res is
Resolution_Failed;
return;
- -- Only one intepretation
+ -- Only one interpretation
else
-- In Ada 2005, if we have something like "X : T := 2 + 2;", where
@@ -3395,7 +3428,7 @@ package body Sem_Res is
procedure Flag_Effectively_Volatile_Objects (Expr : Node_Id);
-- Emit an error concerning the illegal usage of an effectively volatile
- -- object in interfering context (SPARK RM 7.13(12)).
+ -- object in interfering context (SPARK RM 7.1.3(10)).
procedure Insert_Default;
-- If the actual is missing in a call, insert in the actuals list
@@ -3680,7 +3713,7 @@ package body Sem_Res is
then
Error_Msg_N
("volatile object cannot appear in this context (SPARK "
- & "RM 7.1.3(11))", N);
+ & "RM 7.1.3(10))", N);
return Skip;
end if;
end if;
@@ -4077,69 +4110,107 @@ package body Sem_Res is
and then not Is_Class_Wide_Type (Etype (Expression (A)))
and then not Is_Interface (Etype (A))
then
- if Ekind (F) = E_In_Out_Parameter
- and then Is_Array_Type (Etype (F))
- then
- -- In a view conversion, the conversion must be legal in
- -- both directions, and thus both component types must be
- -- aliased, or neither (4.6 (8)).
+ declare
+ Expr_Typ : constant Entity_Id := Etype (Expression (A));
- -- The extra rule in 4.6 (24.9.2) seems unduly restrictive:
- -- the privacy requirement should not apply to generic
- -- types, and should be checked in an instance. ARG query
- -- is in order ???
+ begin
+ -- Check RM 4.6 (24.2/2)
- if Has_Aliased_Components (Etype (Expression (A))) /=
- Has_Aliased_Components (Etype (F))
+ if Is_Array_Type (Etype (F))
+ and then Is_View_Conversion (A)
then
- Error_Msg_N
- ("both component types in a view conversion must be"
- & " aliased, or neither", A);
+ -- In a view conversion, the conversion must be legal in
+ -- both directions, and thus both component types must be
+ -- aliased, or neither (4.6 (8)).
- -- Comment here??? what set of cases???
+ -- Check RM 4.6 (24.8/2)
- elsif
- not Same_Ancestor (Etype (F), Etype (Expression (A)))
- then
- -- Check view conv between unrelated by ref array types
+ if Has_Aliased_Components (Expr_Typ) /=
+ Has_Aliased_Components (Etype (F))
+ then
+ -- This normally illegal conversion is legal in an
+ -- expanded instance body because of RM 12.3(11).
+ -- At runtime, conversion must create a new object.
+
+ if not In_Instance then
+ Error_Msg_N
+ ("both component types in a view conversion must"
+ & " be aliased, or neither", A);
+ end if;
- if Is_By_Reference_Type (Etype (F))
- or else Is_By_Reference_Type (Etype (Expression (A)))
+ -- Check RM 4.6 (24/3)
+
+ elsif not Same_Ancestor (Etype (F), Expr_Typ) then
+ -- Check view conv between unrelated by ref array
+ -- types.
+
+ if Is_By_Reference_Type (Etype (F))
+ or else Is_By_Reference_Type (Expr_Typ)
+ then
+ Error_Msg_N
+ ("view conversion between unrelated by reference "
+ & "array types not allowed (\'A'I-00246)", A);
+
+ -- In Ada 2005 mode, check view conversion component
+ -- type cannot be private, tagged, or volatile. Note
+ -- that we only apply this to source conversions. The
+ -- generated code can contain conversions which are
+ -- not subject to this test, and we cannot extract the
+ -- component type in such cases since it is not
+ -- present.
+
+ elsif Comes_From_Source (A)
+ and then Ada_Version >= Ada_2005
+ then
+ declare
+ Comp_Type : constant Entity_Id :=
+ Component_Type (Expr_Typ);
+ begin
+ if (Is_Private_Type (Comp_Type)
+ and then not Is_Generic_Type (Comp_Type))
+ or else Is_Tagged_Type (Comp_Type)
+ or else Is_Volatile (Comp_Type)
+ then
+ Error_Msg_N
+ ("component type of a view conversion " &
+ "cannot be private, tagged, or volatile" &
+ " (RM 4.6 (24))",
+ Expression (A));
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- AI12-0074 & AI12-0377
+ -- Check 6.4.1: If the mode is out, the actual parameter is
+ -- a view conversion, and the type of the formal parameter
+ -- is a scalar type, then either:
+ -- - the target and operand type both do not have the
+ -- Default_Value aspect specified; or
+ -- - the target and operand type both have the
+ -- Default_Value aspect specified, and there shall exist
+ -- a type (other than a root numeric type) that is an
+ -- ancestor of both the target type and the operand
+ -- type.
+
+ elsif Ekind (F) = E_Out_Parameter
+ and then Is_Scalar_Type (Etype (F))
+ then
+ if Has_Default_Aspect (Etype (F)) /=
+ Has_Default_Aspect (Expr_Typ)
then
Error_Msg_N
- ("view conversion between unrelated by reference "
- & "array types not allowed (\'A'I-00246)", A);
-
- -- In Ada 2005 mode, check view conversion component
- -- type cannot be private, tagged, or volatile. Note
- -- that we only apply this to source conversions. The
- -- generated code can contain conversions which are
- -- not subject to this test, and we cannot extract the
- -- component type in such cases since it is not present.
-
- elsif Comes_From_Source (A)
- and then Ada_Version >= Ada_2005
+ ("view conversion requires Default_Value on both " &
+ "types (RM 6.4.1)", A);
+ elsif Has_Default_Aspect (Expr_Typ)
+ and then not Same_Ancestor (Etype (F), Expr_Typ)
then
- declare
- Comp_Type : constant Entity_Id :=
- Component_Type
- (Etype (Expression (A)));
- begin
- if (Is_Private_Type (Comp_Type)
- and then not Is_Generic_Type (Comp_Type))
- or else Is_Tagged_Type (Comp_Type)
- or else Is_Volatile (Comp_Type)
- then
- Error_Msg_N
- ("component type of a view conversion cannot"
- & " be private, tagged, or volatile"
- & " (RM 4.6 (24))",
- Expression (A));
- end if;
- end;
+ Error_Msg_N
+ ("view conversion between unrelated types with "
+ & "Default_Value not allowed (RM 6.4.1)", A);
end if;
end if;
- end if;
+ end;
-- Resolve expression if conversion is all OK
@@ -4349,71 +4420,6 @@ package body Sem_Res is
("invalid use of untagged formal incomplete type", A);
end if;
- if Comes_From_Source (Original_Node (N))
- and then Nkind_In (Original_Node (N), N_Function_Call,
- N_Procedure_Call_Statement)
- then
- -- In formal mode, check that actual parameters matching
- -- formals of tagged types are objects (or ancestor type
- -- conversions of objects), not general expressions.
-
- if Is_Actual_Tagged_Parameter (A) then
- if Is_SPARK_05_Object_Reference (A) then
- null;
-
- elsif Nkind (A) = N_Type_Conversion then
- declare
- Operand : constant Node_Id := Expression (A);
- Operand_Typ : constant Entity_Id := Etype (Operand);
- Target_Typ : constant Entity_Id := A_Typ;
-
- begin
- if not Is_SPARK_05_Object_Reference (Operand) then
- Check_SPARK_05_Restriction
- ("object required", Operand);
-
- -- In formal mode, the only view conversions are those
- -- involving ancestor conversion of an extended type.
-
- elsif not
- (Is_Tagged_Type (Target_Typ)
- and then not Is_Class_Wide_Type (Target_Typ)
- and then Is_Tagged_Type (Operand_Typ)
- and then not Is_Class_Wide_Type (Operand_Typ)
- and then Is_Ancestor (Target_Typ, Operand_Typ))
- then
- if Ekind_In
- (F, E_Out_Parameter, E_In_Out_Parameter)
- then
- Check_SPARK_05_Restriction
- ("ancestor conversion is the only permitted "
- & "view conversion", A);
- else
- Check_SPARK_05_Restriction
- ("ancestor conversion required", A);
- end if;
-
- else
- null;
- end if;
- end;
-
- else
- Check_SPARK_05_Restriction ("object required", A);
- end if;
-
- -- In formal mode, the only view conversions are those
- -- involving ancestor conversion of an extended type.
-
- elsif Nkind (A) = N_Type_Conversion
- and then Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter)
- then
- Check_SPARK_05_Restriction
- ("ancestor conversion is the only permitted view "
- & "conversion", A);
- end if;
- end if;
-
-- has warnings suppressed, then we reset Never_Set_In_Source for
-- the calling entity. The reason for this is to catch cases like
-- GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram
@@ -4551,7 +4557,7 @@ package body Sem_Res is
-- Apply appropriate constraint/predicate checks for IN [OUT] case
- if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then
+ if Ekind (F) in E_In_Parameter | E_In_Out_Parameter then
-- Apply predicate tests except in certain special cases. Note
-- that it might be more consistent to apply these only when
@@ -4633,7 +4639,7 @@ package body Sem_Res is
-- Checks for OUT parameters and IN OUT parameters
- if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then
+ if Ekind (F) in E_Out_Parameter | E_In_Out_Parameter then
-- If there is a type conversion, make sure the return value
-- meets the constraints of the variable before the conversion.
@@ -4646,6 +4652,7 @@ package body Sem_Res is
-- This is for Starlet only though, so long obsolete.
if Mechanism (F) = By_Reference
+ and then Ekind (Nam) = E_Procedure
and then Is_Valued_Procedure (Nam)
then
null;
@@ -4871,7 +4878,7 @@ package body Sem_Res is
-- An effectively volatile object may act as an actual when the
-- corresponding formal is of a non-scalar effectively volatile
- -- type (SPARK RM 7.1.3(11)).
+ -- type (SPARK RM 7.1.3(10)).
if not Is_Scalar_Type (Etype (F))
and then Is_Effectively_Volatile (Etype (F))
@@ -4880,7 +4887,7 @@ package body Sem_Res is
-- An effectively volatile object may act as an actual in a
-- call to an instance of Unchecked_Conversion.
- -- (SPARK RM 7.1.3(11)).
+ -- (SPARK RM 7.1.3(10)).
elsif Is_Unchecked_Conversion_Instance (Nam) then
null;
@@ -4890,7 +4897,7 @@ package body Sem_Res is
elsif Is_Effectively_Volatile_Object (A) then
Error_Msg_N
("volatile object cannot act as actual in a call (SPARK "
- & "RM 7.1.3(11))", A);
+ & "RM 7.1.3(10))", A);
-- Otherwise the actual denotes an expression. Inspect the
-- expression and flag each effectively volatile object with
@@ -4951,7 +4958,7 @@ package body Sem_Res is
if Comes_From_Source (Nam)
and then Is_Ghost_Entity (Nam)
- and then Ekind_In (F, E_In_Out_Parameter, E_Out_Parameter)
+ and then Ekind (F) in E_In_Out_Parameter | E_Out_Parameter
and then Is_Entity_Name (A)
and then Present (Entity (A))
and then not Is_Ghost_Entity (Entity (A))
@@ -5092,7 +5099,7 @@ package body Sem_Res is
Expr := Next (First (Expressions (Disc_Exp)));
if Present (Expr) then
Check_Allocator_Discrim_Accessibility_Exprs (Expr, Alloc_Typ);
- Expr := Next (Expr);
+ Next (Expr);
if Present (Expr) then
Check_Allocator_Discrim_Accessibility_Exprs
(Expr, Alloc_Typ);
@@ -5158,8 +5165,9 @@ package body Sem_Res is
("class-wide allocator not allowed for this access type", N);
end if;
- Resolve (Expression (E), Etype (E));
- Check_Non_Static_Context (Expression (E));
+ -- Do a full resolution to apply constraint and predicate checks
+
+ Resolve_Qualified_Expression (E, Etype (E));
Check_Unset_Reference (Expression (E));
-- Allocators generated by the build-in-place expansion mechanism
@@ -5193,16 +5201,6 @@ package body Sem_Res is
end if;
end if;
- -- A qualified expression requires an exact match of the type. Class-
- -- wide matching is not allowed.
-
- if (Is_Class_Wide_Type (Etype (Expression (E)))
- or else Is_Class_Wide_Type (Etype (E)))
- and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E))
- then
- Wrong_Type (Expression (E), Etype (E));
- end if;
-
-- Calls to build-in-place functions are not currently supported in
-- allocators for access types associated with a simple storage pool.
-- Supporting such allocators may require passing additional implicit
@@ -5247,7 +5245,7 @@ package body Sem_Res is
Aggr := Original_Node (Expression (E));
if Has_Discriminants (Subtyp)
- and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate)
+ and then Nkind (Aggr) in N_Aggregate | N_Extension_Aggregate
then
Discrim := First_Discriminant (Base_Type (Subtyp));
@@ -5604,18 +5602,18 @@ package body Sem_Res is
-- N is the expression after "delta" in a fixed_point_definition;
-- see RM-3.5.9(6):
- return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition,
- N_Decimal_Fixed_Point_Definition,
+ return Nkind (Parent (N)) in N_Ordinary_Fixed_Point_Definition
+ | N_Decimal_Fixed_Point_Definition
-- N is one of the bounds in a real_range_specification;
-- see RM-3.5.7(5):
- N_Real_Range_Specification,
+ | N_Real_Range_Specification
-- N is the expression of a delta_constraint;
-- see RM-J.3(3):
- N_Delta_Constraint);
+ | N_Delta_Constraint;
end Expected_Type_Is_Any_Real;
-----------------------------
@@ -5697,7 +5695,7 @@ package body Sem_Res is
-- a conversion will be applied to each operand, so resolve it
-- with its own type.
- if Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) then
+ if Nkind (Parent (N)) in N_Op_Divide | N_Op_Multiply then
Resolve (N);
else
@@ -5785,7 +5783,7 @@ package body Sem_Res is
-- involving a fixed-point operand) the conditional expression must
-- resolve to a unique visible fixed_point type, normally Duration.
- elsif Nkind_In (N, N_Case_Expression, N_If_Expression)
+ elsif Nkind (N) in N_Case_Expression | N_If_Expression
and then Etype (N) = Universal_Real
and then Is_Fixed_Point_Type (B_Typ)
then
@@ -5850,7 +5848,7 @@ package body Sem_Res is
and then (Is_Integer_Or_Universal (L)
or else
Is_Integer_Or_Universal (R))))
- and then Nkind_In (N, N_Op_Multiply, N_Op_Divide)
+ and then Nkind (N) in N_Op_Multiply | N_Op_Divide
then
if TL = Universal_Integer or else TR = Universal_Integer then
Check_For_Visible_Operator (N, B_Typ);
@@ -5896,8 +5894,8 @@ package body Sem_Res is
then
if B_Typ = Universal_Fixed
and then not Expected_Type_Is_Any_Real (N)
- and then not Nkind_In (Parent (N), N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ and then Nkind (Parent (N)) not in
+ N_Type_Conversion | N_Unchecked_Type_Conversion
then
Error_Msg_N ("type cannot be determined from context!", N);
Error_Msg_N ("\explicit conversion to result type required", N);
@@ -5908,9 +5906,8 @@ package body Sem_Res is
else
if Ada_Version = Ada_83
and then Etype (N) = Universal_Fixed
- and then not
- Nkind_In (Parent (N), N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ and then Nkind (Parent (N)) not in
+ N_Type_Conversion | N_Unchecked_Type_Conversion
then
Error_Msg_N
("(Ada 83) fixed-point operation needs explicit "
@@ -5989,20 +5986,6 @@ package body Sem_Res is
Analyze_Dimension (N);
Eval_Arithmetic_Op (N);
- -- In SPARK, a multiplication or division with operands of fixed point
- -- types must be qualified or explicitly converted to identify the
- -- result type.
-
- if (Is_Fixed_Point_Type (Etype (L))
- or else Is_Fixed_Point_Type (Etype (R)))
- and then Nkind_In (N, N_Op_Multiply, N_Op_Divide)
- and then
- not Nkind_In (Parent (N), N_Qualified_Expression, N_Type_Conversion)
- then
- Check_SPARK_05_Restriction
- ("operation should be qualified or explicitly converted", N);
- end if;
-
-- Set overflow and division checking bit
if Nkind (N) in N_Op then
@@ -6012,7 +5995,7 @@ package body Sem_Res is
-- Give warning if explicit division by zero
- if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod)
+ if Nkind (N) in N_Op_Divide | N_Op_Rem | N_Op_Mod
and then not Division_Checks_Suppressed (Etype (N))
then
Rop := Right_Opnd (N);
@@ -6093,7 +6076,7 @@ package body Sem_Res is
-- if both operands can be negative.
if Restriction_Check_Required (No_Implicit_Conditionals)
- and then Nkind_In (N, N_Op_Rem, N_Op_Mod)
+ and then Nkind (N) in N_Op_Rem | N_Op_Mod
then
declare
Lo : Uint;
@@ -6243,9 +6226,8 @@ package body Sem_Res is
-- operations use the same circuitry because the name in the call
-- can be an arbitrary expression with special resolution rules.
- elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component)
- or else (Is_Entity_Name (Subp)
- and then Ekind_In (Entity (Subp), E_Entry, E_Entry_Family))
+ elsif Nkind (Subp) in N_Selected_Component | N_Indexed_Component
+ or else (Is_Entity_Name (Subp) and then Is_Entry (Entity (Subp)))
then
Resolve_Entry_Call (N, Typ);
@@ -6293,26 +6275,6 @@ package body Sem_Res is
end loop;
end if;
- if Is_Access_Subprogram_Type (Base_Type (Etype (Nam)))
- and then not Is_Access_Subprogram_Type (Base_Type (Typ))
- and then Nkind (Subp) /= N_Explicit_Dereference
- and then Present (Parameter_Associations (N))
- then
- -- The prefix is a parameterless function call that returns an access
- -- to subprogram. If parameters are present in the current call, add
- -- add an explicit dereference. We use the base type here because
- -- within an instance these may be subtypes.
-
- -- The dereference is added either in Analyze_Call or here. Should
- -- be consolidated ???
-
- Set_Is_Overloaded (Subp, False);
- Set_Etype (Subp, Etype (Nam));
- Insert_Explicit_Dereference (Subp);
- Nam := Designated_Type (Etype (Nam));
- Resolve (Subp, Nam);
- end if;
-
-- Check that a call to Current_Task does not occur in an entry body
if Is_RTE (Nam, RE_Current_Task) then
@@ -6381,30 +6343,6 @@ package body Sem_Res is
end if;
end if;
- -- If the SPARK_05 restriction is active, we are not allowed
- -- to have a call to a subprogram before we see its completion.
-
- if not Has_Completion (Nam)
- and then Restriction_Check_Required (SPARK_05)
-
- -- Don't flag strange internal calls
-
- and then Comes_From_Source (N)
- and then Comes_From_Source (Nam)
-
- -- Only flag calls in extended main source
-
- and then In_Extended_Main_Source_Unit (Nam)
- and then In_Extended_Main_Source_Unit (N)
-
- -- Exclude enumeration literals from this processing
-
- and then Ekind (Nam) /= E_Enumeration_Literal
- then
- Check_SPARK_05_Restriction
- ("call to subprogram cannot appear before its body", N);
- end if;
-
-- Check that this is not a call to a protected procedure or entry from
-- within a protected function.
@@ -6565,7 +6503,6 @@ package body Sem_Res is
Set_Etype (Prefix (N), Ret_Type);
Set_Etype (N, Typ);
- Resolve_Indexed_Component (N, Typ);
if Legacy_Elaboration_Checks then
Check_Elab_Call (Prefix (N));
@@ -6577,6 +6514,8 @@ package body Sem_Res is
-- the ABE Processing phase.
Build_Call_Marker (Prefix (N));
+
+ Resolve_Indexed_Component (N, Typ);
end if;
end if;
@@ -6639,21 +6578,12 @@ package body Sem_Res is
if Comes_From_Source (N) then
Scop := Current_Scope;
- -- Check violation of SPARK_05 restriction which does not permit
- -- a subprogram body to contain a call to the subprogram directly.
-
- if Restriction_Check_Required (SPARK_05)
- and then Same_Or_Aliased_Subprograms (Nam, Scop)
- then
- Check_SPARK_05_Restriction
- ("subprogram may not contain direct call to itself", N);
- end if;
-
-- Issue warning for possible infinite recursion in the absence
-- of the No_Recursion restriction.
if Same_Or_Aliased_Subprograms (Nam, Scop)
and then not Restriction_Active (No_Recursion)
+ and then not Is_Static_Function (Scop)
and then Check_Infinite_Recursion (N)
then
-- Here we detected and flagged an infinite recursion, so we do
@@ -6671,6 +6601,19 @@ package body Sem_Res is
Scope_Loop : while Scop /= Standard_Standard loop
if Same_Or_Aliased_Subprograms (Nam, Scop) then
+ -- Ada 202x (AI12-0075): Static functions are never allowed
+ -- to make a recursive call, as specified by 6.8(5.4/5).
+
+ if Is_Static_Function (Scop) then
+ Error_Msg_N
+ ("recursive call not allowed in static expression "
+ & "function", N);
+
+ Set_Error_Posted (Scop);
+
+ exit Scope_Loop;
+ end if;
+
-- Although in general case, recursion is not statically
-- checkable, the case of calling an immediately containing
-- subprogram is easy to catch.
@@ -6714,8 +6657,8 @@ package body Sem_Res is
begin
P := Prev (N);
while Present (P) loop
- if not Nkind_In (P, N_Assignment_Statement,
- N_Raise_Constraint_Error)
+ if Nkind (P) not in N_Assignment_Statement
+ | N_Raise_Constraint_Error
then
exit Scope_Loop;
end if;
@@ -6808,6 +6751,11 @@ package body Sem_Res is
-- is already present. It may not be available if e.g. the subprogram is
-- declared in a child instance.
+ -- g) If the subprogram is a static expression function and the call is
+ -- a static call (the actuals are all static expressions), then we never
+ -- want to create a transient scope (this could occur in the case of a
+ -- static string-returning call).
+
if Is_Inlined (Nam)
and then Has_Pragma_Inline (Nam)
and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration
@@ -6819,6 +6767,7 @@ package body Sem_Res is
or else Is_Build_In_Place_Function (Nam)
or else Is_Intrinsic_Subprogram (Nam)
or else Is_Inlinable_Expression_Function (Nam)
+ or else Is_Static_Function_Call (N)
then
null;
@@ -6826,7 +6775,7 @@ package body Sem_Res is
-- secondary stack (or any other one).
elsif Expander_Active
- and then Ekind_In (Nam, E_Function, E_Subprogram_Type)
+ and then Ekind (Nam) in E_Function | E_Subprogram_Type
and then Requires_Transient_Scope (Etype (Nam))
and then not Is_Ignored_Ghost_Entity (Nam)
then
@@ -6925,7 +6874,7 @@ package body Sem_Res is
F := First_Formal (Nam);
A := First_Actual (N);
while Present (F) and then Present (A) loop
- if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter)
+ if Ekind (F) in E_Out_Parameter | E_In_Out_Parameter
and then Warn_On_Modified_As_Out_Parameter (F)
and then Is_Entity_Name (A)
and then Present (Entity (A))
@@ -7006,17 +6955,6 @@ package body Sem_Res is
Check_For_Eliminated_Subprogram (Subp, Nam);
- -- In formal mode, the primitive operations of a tagged type or type
- -- extension do not include functions that return the tagged type.
-
- if Nkind (N) = N_Function_Call
- and then Is_Tagged_Type (Etype (N))
- and then Is_Entity_Name (Name (N))
- and then Is_Inherited_Operation_For_Type (Entity (Name (N)), Etype (N))
- then
- Check_SPARK_05_Restriction ("function not inherited", N);
- end if;
-
-- Implement rule in 12.5.1 (23.3/2): In an instance, if the actual is
-- class-wide and the call dispatches on result in a context that does
-- not provide a tag, the call raises Program_Error.
@@ -7094,12 +7032,26 @@ package body Sem_Res is
Warn_On_Overlapping_Actuals (Nam, N);
+ -- Ada 202x (AI12-0075): If the call is a static call to a static
+ -- expression function, then we want to "inline" the call, replacing
+ -- it with the folded static result. This is not done if the checking
+ -- for a potentially static expression is enabled or if an error has
+ -- been posted on the call (which may be due to the check for recursive
+ -- calls, in which case we don't want to fall into infinite recursion
+ -- when doing the inlining).
+
+ if not Checking_Potentially_Static_Expression
+ and then Is_Static_Function_Call (N)
+ and then not Error_Posted (Ultimate_Alias (Nam))
+ then
+ Inline_Static_Function_Call (N, Ultimate_Alias (Nam));
+
-- In GNATprove mode, expansion is disabled, but we want to inline some
-- subprograms to facilitate formal verification. Indirect calls through
-- a subprogram type or within a generic cannot be inlined. Inlining is
-- performed only for calls subject to SPARK_Mode on.
- if GNATprove_Mode
+ elsif GNATprove_Mode
and then SPARK_Mode = On
and then Is_Overloadable (Nam)
and then not Inside_A_Generic
@@ -7449,20 +7401,6 @@ package body Sem_Res is
Generate_Operator_Reference (N, T);
Check_Low_Bound_Tested (N);
- -- In SPARK, ordering operators <, <=, >, >= are not defined for Boolean
- -- types or array types except String.
-
- if Is_Boolean_Type (T) then
- Check_SPARK_05_Restriction
- ("comparison is not defined on Boolean type", N);
-
- elsif Is_Array_Type (T)
- and then Base_Type (T) /= Standard_String
- then
- Check_SPARK_05_Restriction
- ("comparison is not defined on array types other than String", N);
- end if;
-
-- Check comparison on unordered enumeration
if Bad_Unordered_Enumeration_Reference (N, Etype (L)) then
@@ -7491,6 +7429,49 @@ package body Sem_Res is
end if;
end Resolve_Comparison_Op;
+ --------------------------------
+ -- Resolve_Declare_Expression --
+ --------------------------------
+
+ procedure Resolve_Declare_Expression
+ (N : Node_Id;
+ Typ : Entity_Id)
+ is
+ Decl : Node_Id;
+ begin
+ -- Install the scope created for local declarations, if
+ -- any. The syntax allows a Declare_Expression with no
+ -- declarations, in analogy with block statements.
+
+ Decl := First (Actions (N));
+
+ while Present (Decl) loop
+ exit when Nkind (Decl) = N_Object_Declaration;
+ Next (Decl);
+ end loop;
+
+ if Present (Decl) then
+ Push_Scope (Scope (Defining_Identifier (Decl)));
+
+ declare
+ E : Entity_Id := First_Entity (Current_Scope);
+
+ begin
+ while Present (E) loop
+ Set_Current_Entity (E);
+ Set_Is_Immediately_Visible (E);
+ Next_Entity (E);
+ end loop;
+ end;
+
+ Resolve (Expression (N), Typ);
+ End_Scope;
+
+ else
+ Resolve (Expression (N), Typ);
+ end if;
+ end Resolve_Declare_Expression;
+
-----------------------------------------
-- Resolve_Discrete_Subtype_Indication --
-----------------------------------------
@@ -7595,6 +7576,10 @@ package body Sem_Res is
-- Determine whether node Context denotes an assignment statement or an
-- object declaration whose expression is node Expr.
+ function Is_Attribute_Expression (Expr : Node_Id) return Boolean;
+ -- Determine whether Expr is part of an N_Attribute_Reference
+ -- expression.
+
----------------------------------------
-- Is_Assignment_Or_Object_Expression --
----------------------------------------
@@ -7604,8 +7589,8 @@ package body Sem_Res is
Expr : Node_Id) return Boolean
is
begin
- if Nkind_In (Context, N_Assignment_Statement,
- N_Object_Declaration)
+ if Nkind (Context) in
+ N_Assignment_Statement | N_Object_Declaration
and then Expression (Context) = Expr
then
return True;
@@ -7613,15 +7598,15 @@ package body Sem_Res is
-- Check whether a construct that yields a name is the expression of
-- an assignment statement or an object declaration.
- elsif (Nkind_In (Context, N_Attribute_Reference,
- N_Explicit_Dereference,
- N_Indexed_Component,
- N_Selected_Component,
- N_Slice)
+ elsif (Nkind (Context) in N_Attribute_Reference
+ | N_Explicit_Dereference
+ | N_Indexed_Component
+ | N_Selected_Component
+ | N_Slice
and then Prefix (Context) = Expr)
or else
- (Nkind_In (Context, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ (Nkind (Context) in N_Type_Conversion
+ | N_Unchecked_Type_Conversion
and then Expression (Context) = Expr)
then
return
@@ -7637,6 +7622,24 @@ package body Sem_Res is
end if;
end Is_Assignment_Or_Object_Expression;
+ -----------------------------
+ -- Is_Attribute_Expression --
+ -----------------------------
+
+ function Is_Attribute_Expression (Expr : Node_Id) return Boolean is
+ N : Node_Id := Expr;
+ begin
+ while Present (N) loop
+ if Nkind (N) = N_Attribute_Reference then
+ return True;
+ end if;
+
+ N := Parent (N);
+ end loop;
+
+ return False;
+ end Is_Attribute_Expression;
+
-- Local variables
E : constant Entity_Id := Entity (N);
@@ -7707,8 +7710,8 @@ package body Sem_Res is
-- array types (i.e. bounds and length) are legal.
elsif Ekind (E) = E_Out_Parameter
- and then (Nkind (Parent (N)) /= N_Attribute_Reference
- or else Is_Scalar_Type (Etype (E)))
+ and then (Is_Scalar_Type (Etype (E))
+ or else not Is_Attribute_Expression (Parent (N)))
and then (Nkind (Parent (N)) in N_Op
or else Nkind (Parent (N)) = N_Explicit_Dereference
@@ -7768,7 +7771,7 @@ package body Sem_Res is
-- An effectively volatile object subject to enabled properties
-- Async_Writers or Effective_Reads must appear in non-interfering
- -- context (SPARK RM 7.1.3(12)).
+ -- context (SPARK RM 7.1.3(10)).
if Is_Object (E)
and then Is_Effectively_Volatile (E)
@@ -7778,7 +7781,7 @@ package body Sem_Res is
then
SPARK_Msg_N
("volatile object cannot appear in this context "
- & "(SPARK RM 7.1.3(12))", N);
+ & "(SPARK RM 7.1.3(10))", N);
end if;
-- Check for possible elaboration issues with respect to reads of
@@ -7854,7 +7857,7 @@ package body Sem_Res is
-- to the discriminant of the same name in the target task. If the
-- entry name is the target of a requeue statement and the entry is
-- in the current protected object, the bound to be used is the
- -- discriminal of the object (see Apply_Range_Checks for details of
+ -- discriminal of the object (see Apply_Range_Check for details of
-- the transformation).
-----------------------------
@@ -8014,10 +8017,23 @@ package body Sem_Res is
if Nkind (Entry_Name) = N_Selected_Component then
Resolve (Prefix (Entry_Name));
+ Resolve_Implicit_Dereference (Prefix (Entry_Name));
else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
Nam := Entity (Selector_Name (Prefix (Entry_Name)));
Resolve (Prefix (Prefix (Entry_Name)));
+ Resolve_Implicit_Dereference (Prefix (Prefix (Entry_Name)));
+
+ -- We do not resolve the prefix because an Entry_Family has no type,
+ -- although it has the semantics of an array since it can be indexed.
+ -- In order to perform the associated range check, we would need to
+ -- build an array type on the fly and set it on the prefix, but this
+ -- would be wasteful since only the index type matters. Therefore we
+ -- attach this index type directly, so that Actual_Index_Expression
+ -- can pick it up later in order to generate the range check.
+
+ Set_Etype (Prefix (Entry_Name), Actual_Index_Type (Nam));
+
Index := First (Expressions (Entry_Name));
Resolve (Index, Entry_Index_Type (Nam));
@@ -8033,7 +8049,7 @@ package body Sem_Res is
if Nkind (Index) = N_Parameter_Association then
Error_Msg_N ("expect expression for entry index", Index);
else
- Apply_Range_Check (Index, Actual_Index_Type (Nam));
+ Apply_Scalar_Range_Check (Index, Etype (Prefix (Entry_Name)));
end if;
end if;
end Resolve_Entry;
@@ -8159,7 +8175,7 @@ package body Sem_Res is
end;
end if;
- if Ekind_In (Nam, E_Entry, E_Entry_Family)
+ if Is_Entry (Nam)
and then Present (Contract_Wrapper (Nam))
and then Current_Scope /= Contract_Wrapper (Nam)
then
@@ -8230,7 +8246,7 @@ package body Sem_Res is
Generate_Reference (Nam, Entry_Name, 's');
- if Ekind_In (Nam, E_Entry, E_Entry_Family) then
+ if Is_Entry (Nam) then
Check_Potentially_Blocking_Operation (N);
end if;
@@ -8312,6 +8328,13 @@ package body Sem_Res is
then
Establish_Transient_Scope (N, Manage_Sec_Stack => True);
end if;
+
+ -- Now we know that this is not a call to a function that returns an
+ -- array type; moreover, we know the name of the called entry. Detect
+ -- overlapping actuals, just like for a subprogram call.
+
+ Warn_On_Overlapping_Actuals (Nam, N);
+
end Resolve_Entry_Call;
-------------------------
@@ -8447,13 +8470,11 @@ package body Sem_Res is
S : Entity_Id;
begin
- if Ekind_In (Etype (R), E_Allocator_Type,
- E_Access_Attribute_Type)
+ if Ekind (Etype (R)) in E_Allocator_Type | E_Access_Attribute_Type
then
Acc := Designated_Type (Etype (R));
- elsif Ekind_In (Etype (L), E_Allocator_Type,
- E_Access_Attribute_Type)
+ elsif Ekind (Etype (L)) in E_Allocator_Type | E_Access_Attribute_Type
then
Acc := Designated_Type (Etype (L));
else
@@ -8506,7 +8527,7 @@ package body Sem_Res is
return;
elsif T = Any_Access
- or else Ekind_In (T, E_Allocator_Type, E_Access_Attribute_Type)
+ or else Ekind (T) in E_Allocator_Type | E_Access_Attribute_Type
then
T := Find_Unique_Access_Type;
@@ -8523,10 +8544,8 @@ package body Sem_Res is
-- Why no similar processing for case expressions???
elsif Ada_Version >= Ada_2012
- and then Ekind_In (Etype (L), E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
- and then Ekind_In (Etype (R), E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
+ and then Is_Anonymous_Access_Type (Etype (L))
+ and then Is_Anonymous_Access_Type (Etype (R))
then
Check_If_Expression (L);
Check_If_Expression (R);
@@ -8535,27 +8554,6 @@ package body Sem_Res is
Resolve (L, T);
Resolve (R, T);
- -- In SPARK, equality operators = and /= for array types other than
- -- String are only defined when, for each index position, the
- -- operands have equal static bounds.
-
- if Is_Array_Type (T) then
-
- -- Protect call to Matching_Static_Array_Bounds to avoid costly
- -- operation if not needed.
-
- if Restriction_Check_Required (SPARK_05)
- and then Base_Type (T) /= Standard_String
- and then Base_Type (Etype (L)) = Base_Type (Etype (R))
- and then Etype (L) /= Any_Composite -- or else L in error
- and then Etype (R) /= Any_Composite -- or else R in error
- and then not Matching_Static_Array_Bounds (Etype (L), Etype (R))
- then
- Check_SPARK_05_Restriction
- ("array types should have matching static bounds", N);
- end if;
- end if;
-
-- If the unique type is a class-wide type then it will be expanded
-- into a dispatching call to the predefined primitive. Therefore we
-- check here for potential violation of such restriction.
@@ -8670,8 +8668,8 @@ package body Sem_Res is
if Expander_Active
and then
- (Ekind_In (T, E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
+ (Ekind (T) in E_Anonymous_Access_Type
+ | E_Anonymous_Access_Subprogram_Type
or else Is_Private_Type (T))
then
if Etype (L) /= T then
@@ -8827,18 +8825,102 @@ package body Sem_Res is
-------------------------------------
procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id) is
+
+ function OK_For_Static (Act : Node_Id) return Boolean;
+ -- True if Act is an action of a declare_expression that is allowed in a
+ -- static declare_expression.
+
+ function All_OK_For_Static return Boolean;
+ -- True if all actions of N are allowed in a static declare_expression.
+
+ function Get_Literal (Expr : Node_Id) return Node_Id;
+ -- Expr is an expression with compile-time-known value. This returns the
+ -- literal node that reprsents that value.
+
+ function OK_For_Static (Act : Node_Id) return Boolean is
+ begin
+ case Nkind (Act) is
+ when N_Object_Declaration =>
+ if Constant_Present (Act)
+ and then Is_Static_Expression (Expression (Act))
+ then
+ return True;
+ end if;
+
+ when N_Object_Renaming_Declaration =>
+ if Statically_Names_Object (Name (Act)) then
+ return True;
+ end if;
+
+ when others =>
+ -- No other declarations, nor even pragmas, are allowed in a
+ -- declare expression, so if we see something else, it must be
+ -- an internally generated expression_with_actions.
+ null;
+ end case;
+
+ return False;
+ end OK_For_Static;
+
+ function All_OK_For_Static return Boolean is
+ Act : Node_Id := First (Actions (N));
+ begin
+ while Present (Act) loop
+ if not OK_For_Static (Act) then
+ return False;
+ end if;
+
+ Next (Act);
+ end loop;
+
+ return True;
+ end All_OK_For_Static;
+
+ function Get_Literal (Expr : Node_Id) return Node_Id is
+ pragma Assert (Compile_Time_Known_Value (Expr));
+ Result : Node_Id;
+ begin
+ case Nkind (Expr) is
+ when N_Has_Entity =>
+ if Ekind (Entity (Expr)) = E_Enumeration_Literal then
+ Result := Expr;
+ else
+ Result := Constant_Value (Entity (Expr));
+ end if;
+ when N_Numeric_Or_String_Literal =>
+ Result := Expr;
+ when others =>
+ raise Program_Error;
+ end case;
+
+ pragma Assert
+ (Nkind (Result) in N_Numeric_Or_String_Literal
+ or else Ekind (Entity (Result)) = E_Enumeration_Literal);
+ return Result;
+ end Get_Literal;
+
+ Loc : constant Source_Ptr := Sloc (N);
+
begin
Set_Etype (N, Typ);
- -- If N has no actions, and its expression has been constant folded,
- -- then rewrite N as just its expression. Note, we can't do this in
- -- the general case of Is_Empty_List (Actions (N)) as this would cause
- -- Expression (N) to be expanded again.
+ if Is_Empty_List (Actions (N)) then
+ pragma Assert (All_OK_For_Static); null;
+ end if;
+
+ -- If the value of the expression is known at compile time, and all
+ -- of the actions (if any) are suitable, then replace the declare
+ -- expression with its expression. This allows the declare expression
+ -- as a whole to be static if appropriate. See AI12-0368.
- if Is_Empty_List (Actions (N))
- and then Compile_Time_Known_Value (Expression (N))
- then
- Rewrite (N, Expression (N));
+ if Compile_Time_Known_Value (Expression (N)) then
+ if Is_Empty_List (Actions (N)) then
+ Rewrite (N, Expression (N));
+ elsif All_OK_For_Static then
+ Rewrite
+ (N, New_Copy_Tree
+ (Get_Literal (Expression (N)), New_Sloc => Loc));
+ end if;
end if;
end Resolve_Expression_With_Actions;
@@ -8848,47 +8930,9 @@ package body Sem_Res is
procedure Resolve_Generalized_Indexing (N : Node_Id; Typ : Entity_Id) is
Indexing : constant Node_Id := Generalized_Indexing (N);
- Call : Node_Id;
- Indexes : List_Id;
- Pref : Node_Id;
-
begin
- -- In ASIS mode, propagate the information about the indexes back to
- -- to the original indexing node. The generalized indexing is either
- -- a function call, or a dereference of one. The actuals include the
- -- prefix of the original node, which is the container expression.
-
- if ASIS_Mode then
- Resolve (Indexing, Typ);
- Set_Etype (N, Etype (Indexing));
- Set_Is_Overloaded (N, False);
-
- Call := Indexing;
- while Nkind_In (Call, N_Explicit_Dereference, N_Selected_Component)
- loop
- Call := Prefix (Call);
- end loop;
-
- if Nkind (Call) = N_Function_Call then
- Indexes := New_Copy_List (Parameter_Associations (Call));
- Pref := Remove_Head (Indexes);
- Set_Expressions (N, Indexes);
-
- -- If expression is to be reanalyzed, reset Generalized_Indexing
- -- to recreate call node, as is the case when the expression is
- -- part of an expression function.
-
- if In_Spec_Expression then
- Set_Generalized_Indexing (N, Empty);
- end if;
-
- Set_Prefix (N, Pref);
- end if;
-
- else
- Rewrite (N, Indexing);
- Resolve (N, Typ);
- end if;
+ Rewrite (N, Indexing);
+ Resolve (N, Typ);
end Resolve_Generalized_Indexing;
---------------------------
@@ -9013,6 +9057,32 @@ package body Sem_Res is
Analyze_Dimension (N);
end Resolve_If_Expression;
+ ----------------------------------
+ -- Resolve_Implicit_Dereference --
+ ----------------------------------
+
+ procedure Resolve_Implicit_Dereference (P : Node_Id) is
+ Desig_Typ : Entity_Id;
+
+ begin
+ -- In an instance the proper view may not always be correct for
+ -- private types, see e.g. Sem_Type.Covers for similar handling.
+
+ if Is_Private_Type (Etype (P))
+ and then Present (Full_View (Etype (P)))
+ and then Is_Access_Type (Full_View (Etype (P)))
+ and then In_Instance
+ then
+ Set_Etype (P, Full_View (Etype (P)));
+ end if;
+
+ if Is_Access_Type (Etype (P)) then
+ Desig_Typ := Implicitly_Designated_Type (Etype (P));
+ Insert_Explicit_Dereference (P);
+ Analyze_And_Resolve (P, Desig_Typ);
+ end if;
+ end Resolve_Implicit_Dereference;
+
-------------------------------
-- Resolve_Indexed_Component --
-------------------------------
@@ -9085,15 +9155,15 @@ package body Sem_Res is
Resolve (Name, Array_Type);
Array_Type := Get_Actual_Subtype_If_Available (Name);
- -- If prefix is access type, dereference to get real array type.
- -- Note: we do not apply an access check because the expander always
- -- introduces an explicit dereference, and the check will happen there.
+ -- If the prefix's type is an access type, get to the real array type.
+ -- Note: we do not apply an access check because an explicit dereference
+ -- will be introduced later, and the check will happen there.
if Is_Access_Type (Array_Type) then
- Array_Type := Designated_Type (Array_Type);
+ Array_Type := Implicitly_Designated_Type (Array_Type);
end if;
- -- If name was overloaded, set component type correctly now
+ -- If name was overloaded, set component type correctly now.
-- If a misplaced call to an entry family (which has no index types)
-- return. Error will be diagnosed from calling context.
@@ -9115,21 +9185,18 @@ package body Sem_Res is
Resolve (Expr, Standard_Positive);
else
- while Present (Index) and Present (Expr) loop
+ while Present (Index) and then Present (Expr) loop
Resolve (Expr, Etype (Index));
Check_Unset_Reference (Expr);
- if Is_Scalar_Type (Etype (Expr)) then
- Apply_Scalar_Range_Check (Expr, Etype (Index));
- else
- Apply_Range_Check (Expr, Get_Actual_Subtype (Index));
- end if;
+ Apply_Scalar_Range_Check (Expr, Etype (Index));
Next_Index (Index);
Next (Expr);
end loop;
end if;
+ Resolve_Implicit_Dereference (Prefix (N));
Analyze_Dimension (N);
-- Do not generate the warning on suspicious index if we are analyzing
@@ -9145,10 +9212,10 @@ package body Sem_Res is
Eval_Indexed_Component (N);
end if;
- -- If the array type is atomic, and the component is not atomic, then
- -- this is worth a warning, since we have a situation where the access
- -- to the component may cause extra read/writes of the atomic array
- -- object, or partial word accesses, which could be unexpected.
+ -- If the array type is atomic and the component is not, then this is
+ -- worth a warning before Ada 2020, since we have a situation where the
+ -- access to the component may cause extra read/writes of the atomic
+ -- object, or partial word accesses, both of which may be unexpected.
if Nkind (N) = N_Indexed_Component
and then Is_Atomic_Ref_With_Address (N)
@@ -9157,6 +9224,7 @@ package body Sem_Res is
and then Has_Atomic_Components
(Entity (Prefix (N)))))
and then not Is_Atomic (Component_Type (Array_Type))
+ and then Ada_Version < Ada_2020
then
Error_Msg_N
("??access to non-atomic component of atomic array", Prefix (N));
@@ -9198,7 +9266,7 @@ package body Sem_Res is
Res : Node_Id;
begin
- if Nkind_In (Opnd, N_Integer_Literal, N_Real_Literal) then
+ if Nkind (Opnd) in N_Integer_Literal | N_Real_Literal then
Res :=
Make_Qualified_Expression (Loc,
Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
@@ -9391,7 +9459,7 @@ package body Sem_Res is
if Short_Circuit_And_Or
and then B_Typ = Standard_Boolean
- and then Nkind_In (N, N_Op_And, N_Op_Or)
+ and then Nkind (N) in N_Op_And | N_Op_Or
then
-- Mark the corresponding putative SCO operator as truly a logical
-- (and short-circuit) operator.
@@ -9432,34 +9500,6 @@ package body Sem_Res is
Set_Etype (N, B_Typ);
Generate_Operator_Reference (N, B_Typ);
Eval_Logical_Op (N);
-
- -- In SPARK, logical operations AND, OR and XOR for arrays are defined
- -- only when both operands have same static lower and higher bounds. Of
- -- course the types have to match, so only check if operands are
- -- compatible and the node itself has no errors.
-
- if Is_Array_Type (B_Typ)
- and then Nkind (N) in N_Binary_Op
- then
- declare
- Left_Typ : constant Node_Id := Etype (Left_Opnd (N));
- Right_Typ : constant Node_Id := Etype (Right_Opnd (N));
-
- begin
- -- Protect call to Matching_Static_Array_Bounds to avoid costly
- -- operation if not needed.
-
- if Restriction_Check_Required (SPARK_05)
- and then Base_Type (Left_Typ) = Base_Type (Right_Typ)
- and then Left_Typ /= Any_Composite -- or Left_Opnd in error
- and then Right_Typ /= Any_Composite -- or Right_Opnd in error
- and then not Matching_Static_Array_Bounds (Left_Typ, Right_Typ)
- then
- Check_SPARK_05_Restriction
- ("array types should have matching static bounds", N);
- end if;
- end;
- end if;
end Resolve_Logical_Op;
---------------------------
@@ -9478,8 +9518,8 @@ package body Sem_Res is
T : Entity_Id;
procedure Resolve_Set_Membership;
- -- Analysis has determined a unique type for the left operand. Use it to
- -- resolve the disjuncts.
+ -- Analysis has determined a unique type for the left operand. Use it as
+ -- the basis to resolve the disjuncts.
----------------------------
-- Resolve_Set_Membership --
@@ -9487,18 +9527,17 @@ package body Sem_Res is
procedure Resolve_Set_Membership is
Alt : Node_Id;
- Ltyp : Entity_Id;
begin
-- If the left operand is overloaded, find type compatible with not
-- overloaded alternative of the right operand.
+ Alt := First (Alternatives (N));
if Is_Overloaded (L) then
- Ltyp := Empty;
- Alt := First (Alternatives (N));
+ T := Empty;
while Present (Alt) loop
if not Is_Overloaded (Alt) then
- Ltyp := Intersect_Types (L, Alt);
+ T := Intersect_Types (L, Alt);
exit;
else
Next (Alt);
@@ -9508,15 +9547,15 @@ package body Sem_Res is
-- Unclear how to resolve expression if all alternatives are also
-- overloaded.
- if No (Ltyp) then
+ if No (T) then
Error_Msg_N ("ambiguous expression", N);
end if;
else
- Ltyp := Etype (L);
+ T := Intersect_Types (L, Alt);
end if;
- Resolve (L, Ltyp);
+ Resolve (L, T);
Alt := First (Alternatives (N));
while Present (Alt) loop
@@ -9527,7 +9566,7 @@ package body Sem_Res is
if not Is_Entity_Name (Alt)
or else not Is_Type (Entity (Alt))
then
- Resolve (Alt, Ltyp);
+ Resolve (Alt, T);
end if;
Next (Alt);
@@ -9535,7 +9574,7 @@ package body Sem_Res is
-- Check for duplicates for discrete case
- if Is_Discrete_Type (Ltyp) then
+ if Is_Discrete_Type (T) then
declare
type Ent is record
Alt : Node_Id;
@@ -9553,9 +9592,9 @@ package body Sem_Res is
Alt := First (Alternatives (N));
while Present (Alt) loop
if Is_OK_Static_Expression (Alt)
- and then (Nkind_In (Alt, N_Integer_Literal,
- N_Character_Literal)
- or else Nkind (Alt) in N_Has_Entity)
+ and then Nkind (Alt) in N_Integer_Literal
+ | N_Character_Literal
+ | N_Has_Entity
then
Nalts := Nalts + 1;
Alts (Nalts) := (Alt, Expr_Value (Alt));
@@ -9568,7 +9607,7 @@ package body Sem_Res is
end loop;
end if;
- Alt := Next (Alt);
+ Next (Alt);
end loop;
end;
end if;
@@ -9578,11 +9617,11 @@ package body Sem_Res is
-- equality for the type. This may be confusing to users, and the
-- following warning appears useful for the most common case.
- if Is_Scalar_Type (Ltyp)
- and then Present (Get_User_Defined_Eq (Ltyp))
+ if Is_Scalar_Type (Etype (L))
+ and then Present (Get_User_Defined_Eq (Etype (L)))
then
Error_Msg_NE
- ("membership test on& uses predefined equality?", N, Ltyp);
+ ("membership test on& uses predefined equality?", N, Etype (L));
Error_Msg_N
("\even if user-defined equality exists (RM 4.5.2 (28.1/3)?", N);
end if;
@@ -9817,11 +9856,6 @@ package body Sem_Res is
exit when NN = N;
NN := Parent (NN);
end loop;
-
- if Base_Type (Etype (N)) /= Standard_String then
- Check_SPARK_05_Restriction
- ("result of concatenation should have type String", N);
- end if;
end Resolve_Op_Concat;
---------------------------
@@ -9946,34 +9980,6 @@ package body Sem_Res is
Resolve (Arg, Btyp);
end if;
- -- Concatenation is restricted in SPARK: each operand must be either a
- -- string literal, the name of a string constant, a static character or
- -- string expression, or another concatenation. Arg cannot be a
- -- concatenation here as callers of Resolve_Op_Concat_Arg call it
- -- separately on each final operand, past concatenation operations.
-
- if Is_Character_Type (Etype (Arg)) then
- if not Is_OK_Static_Expression (Arg) then
- Check_SPARK_05_Restriction
- ("character operand for concatenation should be static", Arg);
- end if;
-
- elsif Is_String_Type (Etype (Arg)) then
- if not (Nkind_In (Arg, N_Identifier, N_Expanded_Name)
- and then Is_Constant_Object (Entity (Arg)))
- and then not Is_OK_Static_Expression (Arg)
- then
- Check_SPARK_05_Restriction
- ("string operand for concatenation should be static", Arg);
- end if;
-
- -- Do not issue error on an operand that is neither a character nor a
- -- string, as the error is issued in Resolve_Op_Concat.
-
- else
- null;
- end if;
-
Check_Unset_Reference (Arg);
end Resolve_Op_Concat_Arg;
@@ -10241,7 +10247,7 @@ package body Sem_Res is
begin
if B_Typ = Standard_Boolean
- and then Nkind_In (Opnd, N_Op_Eq, N_Op_Ne)
+ and then Nkind (Opnd) in N_Op_Eq | N_Op_Ne
and then Is_Overloaded (Opnd)
then
Resolve_Equality_Op (Opnd, B_Typ);
@@ -10299,19 +10305,6 @@ package body Sem_Res is
begin
Resolve (Expr, Target_Typ);
- -- Protect call to Matching_Static_Array_Bounds to avoid costly
- -- operation if not needed.
-
- if Restriction_Check_Required (SPARK_05)
- and then Is_Array_Type (Target_Typ)
- and then Is_Array_Type (Etype (Expr))
- and then Etype (Expr) /= Any_Composite -- or else Expr in error
- and then not Matching_Static_Array_Bounds (Target_Typ, Etype (Expr))
- then
- Check_SPARK_05_Restriction
- ("array types should have matching static bounds", N);
- end if;
-
-- A qualified expression requires an exact match of the type, class-
-- wide matching is not allowed. However, if the qualifying type is
-- specific and the expression has a class-wide type, it may still be
@@ -10330,10 +10323,12 @@ package body Sem_Res is
-- If the target type is unconstrained, then we reset the type of the
-- result from the type of the expression. For other cases, the actual
- -- subtype of the expression is the target type.
+ -- subtype of the expression is the target type. But we avoid doing it
+ -- for an allocator since this is not needed and might be problematic.
if Is_Composite_Type (Target_Typ)
and then not Is_Constrained (Target_Typ)
+ and then Nkind (Parent (N)) /= N_Allocator
then
Set_Etype (N, Etype (Expr));
end if;
@@ -10347,31 +10342,19 @@ package body Sem_Res is
-- check may convert an illegal static expression and result in warning
-- rather than giving an error (e.g Integer'(Integer'Last + 1)).
- if Nkind (N) = N_Qualified_Expression and then Is_Scalar_Type (Typ) then
- Apply_Scalar_Range_Check (Expr, Typ);
+ if Nkind (N) = N_Qualified_Expression
+ and then Is_Scalar_Type (Target_Typ)
+ then
+ Apply_Scalar_Range_Check (Expr, Target_Typ);
end if;
- -- Finally, check whether a predicate applies to the target type. This
- -- comes from AI12-0100. As for type conversions, check the enclosing
- -- context to prevent an infinite expansion.
+ -- AI12-0100: Once the qualified expression is resolved, check whether
+ -- operand statisfies a static predicate of the target subtype, if any.
+ -- In the static expression case, a predicate check failure is an error.
if Has_Predicates (Target_Typ) then
- if Nkind (Parent (N)) = N_Function_Call
- and then Present (Name (Parent (N)))
- and then (Is_Predicate_Function (Entity (Name (Parent (N))))
- or else
- Is_Predicate_Function_M (Entity (Name (Parent (N)))))
- then
- null;
-
- -- In the case of a qualified expression in an allocator, the check
- -- is applied when expanding the allocator, so avoid redundant check.
-
- elsif Nkind (N) = N_Qualified_Expression
- and then Nkind (Parent (N)) /= N_Allocator
- then
- Apply_Predicate_Check (N, Target_Typ);
- end if;
+ Check_Expression_Against_Static_Predicate
+ (Expr, Target_Typ, Static_Failure_Is_Error => True);
end if;
end Resolve_Qualified_Expression;
@@ -10436,13 +10419,8 @@ package body Sem_Res is
begin
Set_Etype (N, Typ);
- -- The lower bound should be in Typ. The higher bound can be in Typ's
- -- base type if the range is null. It may still be invalid if it is
- -- higher than the lower bound. This is checked later in the context in
- -- which the range appears.
-
Resolve (L, Typ);
- Resolve (H, Base_Type (Typ));
+ Resolve (H, Typ);
-- Reanalyze the lower bound after both bounds have been analyzed, so
-- that the range is known to be static or not by now. This may trigger
@@ -10712,7 +10690,7 @@ package body Sem_Res is
while Present (Comp1)
and then Chars (Comp1) /= Chars (S)
loop
- Comp1 := Next_Entity (Comp1);
+ Next_Entity (Comp1);
end loop;
end if;
@@ -10721,7 +10699,7 @@ package body Sem_Res is
end if;
end if;
- Comp := Next_Entity (Comp);
+ Next_Entity (Comp);
end loop;
end if;
@@ -10777,12 +10755,12 @@ package body Sem_Res is
Generate_Reference (Entity (S), S, 'r');
end if;
- -- If prefix is an access type, the node will be transformed into an
- -- explicit dereference during expansion. The type of the node is the
- -- designated type of that of the prefix.
+ -- If the prefix's type is an access type, get to the real record type.
+ -- Note: we do not apply an access check because an explicit dereference
+ -- will be introduced later, and the check will happen there.
if Is_Access_Type (Etype (P)) then
- T := Designated_Type (Etype (P));
+ T := Implicitly_Designated_Type (Etype (P));
Check_Fully_Declared_Prefix (T, P);
else
@@ -10838,15 +10816,16 @@ package body Sem_Res is
-- Note: No Eval processing is required, because the prefix is of a
-- record type, or protected type, and neither can possibly be static.
- -- If the record type is atomic, and the component is non-atomic, then
- -- this is worth a warning, since we have a situation where the access
- -- to the component may cause extra read/writes of the atomic array
+ -- If the record type is atomic and the component is not, then this is
+ -- worth a warning before Ada 2020, since we have a situation where the
+ -- access to the component may cause extra read/writes of the atomic
-- object, or partial word accesses, both of which may be unexpected.
if Nkind (N) = N_Selected_Component
and then Is_Atomic_Ref_With_Address (N)
and then not Is_Atomic (Entity (S))
and then not Is_Atomic (Etype (Entity (S)))
+ and then Ada_Version < Ada_2020
then
Error_Msg_N
("??access to non-atomic component of atomic record",
@@ -10856,6 +10835,7 @@ package body Sem_Res is
Prefix (N));
end if;
+ Resolve_Implicit_Dereference (Prefix (N));
Analyze_Dimension (N);
end Resolve_Selected_Component;
@@ -10913,7 +10893,7 @@ package body Sem_Res is
-- Set Comes_From_Source on L to preserve warnings for unset
-- reference.
- Set_Comes_From_Source (L, Comes_From_Source (Reloc_L));
+ Preserve_Comes_From_Source (L, Reloc_L);
end;
end if;
@@ -11086,9 +11066,12 @@ package body Sem_Res is
Resolve (Name, Array_Type);
+ -- If the prefix's type is an access type, get to the real array type.
+ -- Note: we do not apply an access check because an explicit dereference
+ -- will be introduced later, and the check will happen there.
+
if Is_Access_Type (Array_Type) then
- Apply_Access_Check (N);
- Array_Type := Designated_Type (Array_Type);
+ Array_Type := Implicitly_Designated_Type (Array_Type);
-- If the prefix is an access to an unconstrained array, we must use
-- the actual subtype of the object to perform the index checks. The
@@ -11232,6 +11215,7 @@ package body Sem_Res is
Warn_On_Suspicious_Index (Name, High_Bound (Drange));
end if;
+ Resolve_Implicit_Dereference (Prefix (N));
Analyze_Dimension (N);
Eval_Slice (N);
end Resolve_Slice;
@@ -11281,10 +11265,10 @@ package body Sem_Res is
elsif Nkind (Parent (N)) = N_Op_Concat
and then not Need_Check
- and then not Nkind_In (Original_Node (N), N_Character_Literal,
- N_Attribute_Reference,
- N_Qualified_Expression,
- N_Type_Conversion)
+ and then Nkind (Original_Node (N)) not in N_Character_Literal
+ | N_Attribute_Reference
+ | N_Qualified_Expression
+ | N_Type_Conversion
then
Subtype_Id := Typ;
@@ -11570,14 +11554,14 @@ package body Sem_Res is
-- precision.
if Is_Fixed_Point_Type (Typ)
- and then Nkind_In (Operand, N_Op_Divide, N_Op_Multiply)
+ and then Nkind (Operand) in N_Op_Divide | N_Op_Multiply
and then Etype (Left_Opnd (Operand)) = Any_Fixed
and then Etype (Right_Opnd (Operand)) = Any_Fixed
then
Set_Etype (Operand, Universal_Real);
elsif Is_Numeric_Type (Typ)
- and then Nkind_In (Operand, N_Op_Multiply, N_Op_Divide)
+ and then Nkind (Operand) in N_Op_Multiply | N_Op_Divide
and then (Etype (Right_Opnd (Operand)) = Universal_Real
or else
Etype (Left_Opnd (Operand)) = Universal_Real)
@@ -11633,35 +11617,6 @@ package body Sem_Res is
Resolve (Operand);
- -- In SPARK, a type conversion between array types should be restricted
- -- to types which have matching static bounds.
-
- -- Protect call to Matching_Static_Array_Bounds to avoid costly
- -- operation if not needed.
-
- if Restriction_Check_Required (SPARK_05)
- and then Is_Array_Type (Target_Typ)
- and then Is_Array_Type (Operand_Typ)
- and then Operand_Typ /= Any_Composite -- or else Operand in error
- and then not Matching_Static_Array_Bounds (Target_Typ, Operand_Typ)
- then
- Check_SPARK_05_Restriction
- ("array types should have matching static bounds", N);
- end if;
-
- -- In formal mode, the operand of an ancestor type conversion must be an
- -- object (not an expression).
-
- if Is_Tagged_Type (Target_Typ)
- and then not Is_Class_Wide_Type (Target_Typ)
- and then Is_Tagged_Type (Operand_Typ)
- and then not Is_Class_Wide_Type (Operand_Typ)
- and then Is_Ancestor (Target_Typ, Operand_Typ)
- and then not Is_SPARK_05_Object_Reference (Operand)
- then
- Check_SPARK_05_Restriction ("object required", Operand);
- end if;
-
Analyze_Dimension (N);
-- Note: we do the Eval_Type_Conversion call before applying the
@@ -11732,6 +11687,7 @@ package body Sem_Res is
-- odd subtype coming from the bounds).
if (Is_Entity_Name (Orig_N)
+ and then Present (Entity (Orig_N))
and then
(Etype (Entity (Orig_N)) = Orig_T
or else
@@ -11767,11 +11723,11 @@ package body Sem_Res is
-- newer language version.
elsif Nkind (Orig_N) = N_Qualified_Expression
- and then Nkind_In (Parent (N), N_Attribute_Reference,
- N_Indexed_Component,
- N_Selected_Component,
- N_Slice,
- N_Explicit_Dereference)
+ and then Nkind (Parent (N)) in N_Attribute_Reference
+ | N_Indexed_Component
+ | N_Selected_Component
+ | N_Slice
+ | N_Explicit_Dereference
then
null;
@@ -11786,17 +11742,15 @@ package body Sem_Res is
-- entity, give the name of the entity in the message. If not,
-- just mention the expression.
- -- Shoudn't we test Warn_On_Redundant_Constructs here ???
-
else
if Is_Entity_Name (Orig_N) then
Error_Msg_Node_2 := Orig_T;
Error_Msg_NE -- CODEFIX
- ("??redundant conversion, & is of type &!",
+ ("?r?redundant conversion, & is of type &!",
N, Entity (Orig_N));
else
Error_Msg_NE
- ("??redundant conversion, expression is of type&!",
+ ("?r?redundant conversion, expression is of type&!",
N, Orig_T);
end if;
end if;
@@ -11903,7 +11857,7 @@ package body Sem_Res is
-- Handle subtypes
- if Ekind_In (Opnd, E_Protected_Subtype, E_Task_Subtype) then
+ if Ekind (Opnd) in E_Protected_Subtype | E_Task_Subtype then
Opnd := Etype (Opnd);
end if;
@@ -11924,11 +11878,13 @@ package body Sem_Res is
end;
end if;
- -- Ada 2012: once the type conversion is resolved, check whether the
- -- operand statisfies the static predicate of the target type.
+ -- Ada 2012: Once the type conversion is resolved, check whether the
+ -- operand statisfies a static predicate of the target subtype, if any.
+ -- In the static expression case, a predicate check failure is an error.
if Has_Predicates (Target_Typ) then
- Check_Expression_Against_Static_Predicate (N, Target_Typ);
+ Check_Expression_Against_Static_Predicate
+ (N, Target_Typ, Static_Failure_Is_Error => True);
end if;
-- If at this stage we have a real to integer conversion, make sure that
@@ -11980,12 +11936,6 @@ package body Sem_Res is
Hi : Uint;
begin
- if Is_Modular_Integer_Type (Typ) and then Nkind (N) /= N_Op_Not then
- Error_Msg_Name_1 := Chars (Typ);
- Check_SPARK_05_Restriction
- ("unary operator not defined for modular type%", N);
- end if;
-
-- Deal with intrinsic unary operators
if Comes_From_Source (N)
@@ -12065,7 +12015,7 @@ package body Sem_Res is
-- mod. These are the cases where the grouping can affect results.
if Paren_Count (Rorig) = 0
- and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide)
+ and then Nkind (Rorig) in N_Op_Mod | N_Op_Multiply | N_Op_Divide
then
-- For mod, we always give the warning, since the value is
-- affected by the parenthesization (e.g. (-5) mod 315 /=
@@ -12147,7 +12097,7 @@ package body Sem_Res is
-- overflow is impossible (divisor > 1) or we have a case of
-- division by zero in any case.
- if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem)
+ if Nkind (Rorig) in N_Op_Divide | N_Op_Rem
and then Compile_Time_Known_Value (Right_Opnd (Rorig))
and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1
then
@@ -12196,6 +12146,18 @@ package body Sem_Res is
Resolve (Operand, Opnd_Type);
+ -- If the expression is a conversion to universal integer of an
+ -- an expression with an integer type, then we can eliminate the
+ -- intermediate conversion to universal integer.
+
+ if Nkind (Operand) = N_Type_Conversion
+ and then Entity (Subtype_Mark (Operand)) = Universal_Integer
+ and then Is_Integer_Type (Etype (Expression (Operand)))
+ then
+ Rewrite (Operand, Relocate_Node (Expression (Operand)));
+ Analyze_And_Resolve (Operand);
+ end if;
+
-- In an inlined context, the unchecked conversion may be applied
-- to a literal, in which case its type is the type of the context.
-- (In other contexts conversions cannot apply to literals).
@@ -12477,37 +12439,51 @@ package body Sem_Res is
-- If the lower bound is not static we create a range for the string
-- literal, using the index type and the known length of the literal.
- -- The index type is not necessarily Positive, so the upper bound is
- -- computed as T'Val (T'Pos (Low_Bound) + L - 1).
+ -- If the length is 1, then the upper bound is set to a mere copy of
+ -- the lower bound; or else, if the index type is a signed integer,
+ -- then the upper bound is computed as Low_Bound + L - 1; otherwise,
+ -- the upper bound is computed as T'Val (T'Pos (Low_Bound) + L - 1).
else
declare
- Index_List : constant List_Id := New_List;
- Index_Type : constant Entity_Id := Etype (First_Index (Typ));
- High_Bound : constant Node_Id :=
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Val,
- Prefix =>
- New_Occurrence_Of (Index_Type, Loc),
- Expressions => New_List (
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Pos,
- Prefix =>
- New_Occurrence_Of (Index_Type, Loc),
- Expressions =>
- New_List (New_Copy_Tree (Low_Bound))),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- String_Length (Strval (N)) - 1))));
-
+ Length : constant Nat := String_Length (Strval (N));
+ Index_List : constant List_Id := New_List;
+ Index_Type : constant Entity_Id := Etype (First_Index (Typ));
Array_Subtype : Entity_Id;
Drange : Node_Id;
+ High_Bound : Node_Id;
Index : Node_Id;
Index_Subtype : Entity_Id;
begin
+ if Length = 1 then
+ High_Bound := New_Copy_Tree (Low_Bound);
+
+ elsif Is_Signed_Integer_Type (Index_Type) then
+ High_Bound :=
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Copy_Tree (Low_Bound),
+ Right_Opnd => Make_Integer_Literal (Loc, Length - 1));
+
+ else
+ High_Bound :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Val,
+ Prefix =>
+ New_Occurrence_Of (Index_Type, Loc),
+ Expressions => New_List (
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Pos,
+ Prefix =>
+ New_Occurrence_Of (Index_Type, Loc),
+ Expressions =>
+ New_List (New_Copy_Tree (Low_Bound))),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Length - 1))));
+ end if;
+
if Is_Integer_Type (Index_Type) then
Set_String_Literal_Low_Bound
(Subtype_Id, Make_Integer_Literal (Loc, 1));
@@ -12522,10 +12498,10 @@ package body Sem_Res is
Attribute_Name => Name_First,
Prefix =>
New_Occurrence_Of (Base_Type (Index_Type), Loc)));
- Set_Etype (String_Literal_Low_Bound (Subtype_Id), Index_Type);
end if;
- Analyze_And_Resolve (String_Literal_Low_Bound (Subtype_Id));
+ Analyze_And_Resolve
+ (String_Literal_Low_Bound (Subtype_Id), Base_Type (Index_Type));
-- Build bona fide subtype for the string, and wrap it in an
-- unchecked conversion, because the back end expects the
@@ -12599,9 +12575,9 @@ package body Sem_Res is
or else (Is_Fixed_Point_Type (Target_Typ)
and then Conversion_OK (N)))
and then Nkind (Operand) = N_Attribute_Reference
- and then Nam_In (Attribute_Name (Operand), Name_Rounding,
- Name_Machine_Rounding,
- Name_Truncation)
+ and then Attribute_Name (Operand) in Name_Rounding
+ | Name_Machine_Rounding
+ | Name_Truncation
then
declare
Truncate : constant Boolean :=
@@ -12611,6 +12587,30 @@ package body Sem_Res is
Relocate_Node (First (Expressions (Operand))));
Set_Float_Truncate (N, Truncate);
end;
+
+ -- Special processing for the conversion of an integer literal to
+ -- a dynamic type: we first convert the literal to the root type
+ -- and then convert the result to the target type, the goal being
+ -- to avoid doing range checks in universal integer.
+
+ elsif Is_Integer_Type (Target_Typ)
+ and then not Is_Generic_Type (Root_Type (Target_Typ))
+ and then Nkind (Operand) = N_Integer_Literal
+ and then Opnd_Typ = Universal_Integer
+ then
+ Convert_To_And_Rewrite (Root_Type (Target_Typ), Operand);
+ Analyze_And_Resolve (Operand);
+
+ -- If the expression is a conversion to universal integer of an
+ -- an expression with an integer type, then we can eliminate the
+ -- intermediate conversion to universal integer.
+
+ elsif Nkind (Operand) = N_Type_Conversion
+ and then Entity (Subtype_Mark (Operand)) = Universal_Integer
+ and then Is_Integer_Type (Etype (Expression (Operand)))
+ then
+ Rewrite (Operand, Relocate_Node (Expression (Operand)));
+ Analyze_And_Resolve (Operand);
end if;
end;
end if;
@@ -12710,7 +12710,7 @@ package body Sem_Res is
-- When the context is a type conversion, issue the warning on the
-- expression of the conversion because it is the actual operation.
- if Nkind_In (N, N_Type_Conversion, N_Unchecked_Type_Conversion) then
+ if Nkind (N) in N_Type_Conversion | N_Unchecked_Type_Conversion then
ErrN := Expression (N);
else
ErrN := N;
@@ -12757,6 +12757,18 @@ package body Sem_Res is
-- are not rechecked because type visbility may lead to spurious errors,
-- but conversions in an actual for a formal object must be checked.
+ function Is_Discrim_Of_Bad_Access_Conversion_Argument
+ (Expr : Node_Id) return Boolean;
+ -- Implicit anonymous-to-named access type conversions are not allowed
+ -- if the "statically deeper than" relationship does not apply to the
+ -- type of the conversion operand. See RM 8.6(28.1) and AARM 8.6(28.d).
+ -- We deal with most such cases elsewhere so that we can emit more
+ -- specific error messages (e.g., if the operand is an access parameter
+ -- or a saooaaat (stand-alone object of an anonymous access type)), but
+ -- here is where we catch the case where the operand is an access
+ -- discriminant selected from a dereference of another such "bad"
+ -- conversion argument.
+
function Valid_Tagged_Conversion
(Target_Type : Entity_Id;
Opnd_Type : Entity_Id) return Boolean;
@@ -12859,6 +12871,73 @@ package body Sem_Res is
end if;
end In_Instance_Code;
+ --------------------------------------------------
+ -- Is_Discrim_Of_Bad_Access_Conversion_Argument --
+ --------------------------------------------------
+
+ function Is_Discrim_Of_Bad_Access_Conversion_Argument
+ (Expr : Node_Id) return Boolean
+ is
+ Exp_Type : Entity_Id := Base_Type (Etype (Expr));
+ pragma Assert (Is_Access_Type (Exp_Type));
+
+ Associated_Node : Node_Id;
+ Deref_Prefix : Node_Id;
+ begin
+ if not Is_Anonymous_Access_Type (Exp_Type) then
+ return False;
+ end if;
+
+ pragma Assert (Is_Itype (Exp_Type));
+ Associated_Node := Associated_Node_For_Itype (Exp_Type);
+
+ if Nkind (Associated_Node) /= N_Discriminant_Specification then
+ return False; -- not the type of an access discriminant
+ end if;
+
+ -- return False if Expr not of form <prefix>.all.Some_Component
+
+ if (Nkind (Expr) /= N_Selected_Component)
+ or else (Nkind (Prefix (Expr)) /= N_Explicit_Dereference)
+ then
+ -- conditional expressions, declare expressions ???
+ return False;
+ end if;
+
+ Deref_Prefix := Prefix (Prefix (Expr));
+ Exp_Type := Base_Type (Etype (Deref_Prefix));
+
+ -- The "statically deeper relationship" does not apply
+ -- to generic formal access types, so a prefix of such
+ -- a type is a "bad" prefix.
+
+ if Is_Generic_Formal (Exp_Type) then
+ return True;
+
+ -- The "statically deeper relationship" does apply to
+ -- any other named access type.
+
+ elsif not Is_Anonymous_Access_Type (Exp_Type) then
+ return False;
+ end if;
+
+ pragma Assert (Is_Itype (Exp_Type));
+ Associated_Node := Associated_Node_For_Itype (Exp_Type);
+
+ -- The "statically deeper relationship" applies to some
+ -- anonymous access types and not to others. Return
+ -- True for the cases where it does not apply. Also check
+ -- recursively for the
+ -- <prefix>.all.Access_Discrim.all.Access_Discrim case,
+ -- where the correct result depends on <prefix>.
+
+ return Nkind (Associated_Node) in
+ N_Procedure_Specification | -- access parameter
+ N_Function_Specification | -- access parameter
+ N_Object_Declaration -- saooaaat
+ or else Is_Discrim_Of_Bad_Access_Conversion_Argument (Deref_Prefix);
+ end Is_Discrim_Of_Bad_Access_Conversion_Argument;
+
----------------------------
-- Valid_Array_Conversion --
----------------------------
@@ -12929,9 +13008,9 @@ package body Sem_Res is
-- checks that must be applied to such conversions to prevent
-- out-of-scope references.
- elsif Ekind_In
- (Target_Comp_Base, E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
+ elsif Ekind (Target_Comp_Base) in
+ E_Anonymous_Access_Type
+ | E_Anonymous_Access_Subprogram_Type
and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base)
and then
Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type)
@@ -13240,8 +13319,8 @@ package body Sem_Res is
-- interface type.
elsif Is_Access_Type (Opnd_Type)
- and then Ekind_In (Target_Type, E_General_Access_Type,
- E_Anonymous_Access_Type)
+ and then Ekind (Target_Type) in
+ E_General_Access_Type | E_Anonymous_Access_Type
and then Is_Interface (Directly_Designated_Type (Target_Type))
then
-- Check the static accessibility rule of 4.6(17). Note that the
@@ -13321,7 +13400,7 @@ package body Sem_Res is
if Is_Entity_Name (Operand)
and then not Is_Local_Anonymous_Access (Opnd_Type)
and then
- Ekind_In (Entity (Operand), E_In_Parameter, E_Constant)
+ Ekind (Entity (Operand)) in E_In_Parameter | E_Constant
and then Present (Discriminal_Link (Entity (Operand)))
then
Conversion_Error_N
@@ -13336,14 +13415,15 @@ package body Sem_Res is
-- General and anonymous access types
- elsif Ekind_In (Target_Type, E_General_Access_Type,
- E_Anonymous_Access_Type)
+ elsif Ekind (Target_Type) in
+ E_General_Access_Type | E_Anonymous_Access_Type
and then
Conversion_Check
(Is_Access_Type (Opnd_Type)
- and then not
- Ekind_In (Opnd_Type, E_Access_Subprogram_Type,
- E_Access_Protected_Subprogram_Type),
+ and then
+ Ekind (Opnd_Type) not in
+ E_Access_Subprogram_Type |
+ E_Access_Protected_Subprogram_Type,
"must be an access-to-object type")
then
if Is_Access_Constant (Opnd_Type)
@@ -13395,26 +13475,24 @@ package body Sem_Res is
return False;
-- Implicit conversions aren't allowed for anonymous access
- -- parameters. The "not Is_Local_Anonymous_Access_Type" test
- -- is done to exclude anonymous access results.
+ -- parameters. We exclude anonymous access results as well
+ -- as universal_access "=".
elsif not Is_Local_Anonymous_Access (Opnd_Type)
- and then Nkind_In (Associated_Node_For_Itype (Opnd_Type),
- N_Function_Specification,
- N_Procedure_Specification)
+ and then Nkind (Associated_Node_For_Itype (Opnd_Type)) in
+ N_Function_Specification |
+ N_Procedure_Specification
+ and then Nkind (Parent (N)) not in N_Op_Eq | N_Op_Ne
then
Conversion_Error_N
- ("implicit conversion of anonymous access formal "
+ ("implicit conversion of anonymous access parameter "
& "not allowed", Operand);
return False;
- -- This is a case where there's an enclosing object whose
- -- to which the "statically deeper than" relationship does
- -- not apply (such as an access discriminant selected from
- -- a dereference of an access parameter).
+ -- Detect access discriminant values that are illegal
+ -- implicit anonymous-to-named access conversion operands.
- elsif Object_Access_Level (Operand)
- = Scope_Depth (Standard_Standard)
+ elsif Is_Discrim_Of_Bad_Access_Conversion_Argument (Operand)
then
Conversion_Error_N
("implicit conversion of anonymous access value "
@@ -13426,7 +13504,7 @@ package body Sem_Res is
-- implicit conversion is disallowed (by RM12-8.6(27.1/3)).
elsif Type_Access_Level (Opnd_Type) >
- Deepest_Type_Access_Level (Target_Type)
+ Deepest_Type_Access_Level (Target_Type)
then
Conversion_Error_N
("implicit conversion of anonymous access value "
@@ -13435,8 +13513,19 @@ package body Sem_Res is
end if;
end if;
+ -- Check if the operand is deeper than the target type, taking
+ -- care to avoid the case where we are converting a result of a
+ -- function returning an anonymous access type since the "master
+ -- of the call" would be target type of the conversion unless
+ -- the target type is anonymous access as well - see RM 3.10.2
+ -- (10.3/3).
+
elsif Type_Access_Level (Opnd_Type) >
Deepest_Type_Access_Level (Target_Type)
+ and then (Nkind (Associated_Node_For_Itype (Opnd_Type)) /=
+ N_Function_Specification
+ or else Ekind (Target_Type) in
+ Anonymous_Access_Kind)
then
-- In an instance, this is a run-time check, but one we know
-- will fail, so generate an appropriate warning. The raise
@@ -13507,7 +13596,7 @@ package body Sem_Res is
if Is_Entity_Name (Operand)
and then
- Ekind_In (Entity (Operand), E_In_Parameter, E_Constant)
+ Ekind (Entity (Operand)) in E_In_Parameter | E_Constant
and then Present (Discriminal_Link (Entity (Operand)))
then
Conversion_Error_N
diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads
index b667e45..44a8487 100644
--- a/gcc/ada/sem_res.ads
+++ b/gcc/ada/sem_res.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_scil.adb b/gcc/ada/sem_scil.adb
index a3ebca0..f8ad56b 100644
--- a/gcc/ada/sem_scil.adb
+++ b/gcc/ada/sem_scil.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -86,8 +86,8 @@ package body Sem_SCIL is
-- object or parameter declaration. Interface types are still
-- unsupported.
- elsif Nkind_In (Ctrl_Tag, N_Object_Declaration,
- N_Parameter_Specification)
+ elsif Nkind (Ctrl_Tag) in
+ N_Object_Declaration | N_Parameter_Specification
then
Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag));
@@ -132,10 +132,10 @@ package body Sem_SCIL is
-- Check contents of the boolean expression associated with the
-- membership test.
- pragma Assert (Nkind_In (N, N_Identifier,
- N_And_Then,
- N_Or_Else,
- N_Expression_With_Actions)
+ pragma Assert
+ (Nkind (N) in
+ N_Identifier | N_And_Then | N_Or_Else |
+ N_Expression_With_Actions
and then Etype (N) = Standard_Boolean);
-- Check the entity identifier of the associated tagged type (that
diff --git a/gcc/ada/sem_scil.ads b/gcc/ada/sem_scil.ads
index 88bc94d..3916e9e 100644
--- a/gcc/ada/sem_scil.ads
+++ b/gcc/ada/sem_scil.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_smem.adb b/gcc/ada/sem_smem.adb
index 112b27c..38fa1fa 100644
--- a/gcc/ada/sem_smem.adb
+++ b/gcc/ada/sem_smem.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -126,7 +126,7 @@ package body Sem_Smem is
if Is_Access_Type (Etype (C)) then
return True;
else
- C := Next_Discriminant (C);
+ Next_Discriminant (C);
end if;
end loop;
end if;
@@ -145,7 +145,7 @@ package body Sem_Smem is
then
return True;
else
- C := Next_Component (C);
+ Next_Component (C);
end if;
end loop;
diff --git a/gcc/ada/sem_smem.ads b/gcc/ada/sem_smem.ads
index aafa54e..ec497da 100644
--- a/gcc/ada/sem_smem.ads
+++ b/gcc/ada/sem_smem.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index e5d01dd..a5e62a7 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Alloc;
with Debug; use Debug;
@@ -375,7 +376,7 @@ package body Sem_Type is
or else Nkind (N) = N_Expanded_Name
or else (Nkind (N) in N_Op and then E = Entity (N))
or else (In_Instance or else In_Inlined_Body)
- or else Ekind (Vis_Type) = E_Anonymous_Access_Type
+ or else Is_Anonymous_Access_Type (Vis_Type)
then
null;
@@ -958,32 +959,7 @@ package body Sem_Type is
-- Note: test for presence of E is defense against previous error.
if No (E) then
-
- -- If expansion is disabled the Corresponding_Record_Type may
- -- not be available yet, so use the interface list in the
- -- declaration directly.
-
- if ASIS_Mode
- and then Nkind (Parent (BT2)) = N_Protected_Type_Declaration
- and then Present (Interface_List (Parent (BT2)))
- then
- declare
- Intf : Node_Id := First (Interface_List (Parent (BT2)));
- begin
- while Present (Intf) loop
- if Is_Ancestor (Etype (T1), Entity (Intf)) then
- return True;
- else
- Next (Intf);
- end if;
- end loop;
- end;
-
- return False;
-
- else
- Check_Error_Detected;
- end if;
+ Check_Error_Detected;
-- Here we have a corresponding record type
@@ -1046,23 +1022,25 @@ package body Sem_Type is
-- Ada 2012 (AI05-0149): Allow an anonymous access type in the context
-- of a named general access type. An implicit conversion will be
- -- applied. For the resolution, one designated type must cover the
- -- other.
+ -- applied. For the resolution, the designated types must match if
+ -- untagged; further, if the designated type is tagged, the designated
+ -- type of the anonymous access type shall be covered by the designated
+ -- type of the named access type.
elsif Ada_Version >= Ada_2012
and then Ekind (BT1) = E_General_Access_Type
and then Ekind (BT2) = E_Anonymous_Access_Type
- and then (Covers (Designated_Type (T1), Designated_Type (T2))
- or else
- Covers (Designated_Type (T2), Designated_Type (T1)))
+ and then Covers (Designated_Type (T1), Designated_Type (T2))
+ and then (Is_Class_Wide_Type (Designated_Type (T1)) >=
+ Is_Class_Wide_Type (Designated_Type (T2)))
then
return True;
-- An Access_To_Subprogram is compatible with itself, or with an
-- anonymous type created for an attribute reference Access.
- elsif Ekind_In (BT1, E_Access_Subprogram_Type,
- E_Access_Protected_Subprogram_Type)
+ elsif Ekind (BT1) in E_Access_Subprogram_Type
+ | E_Access_Protected_Subprogram_Type
and then Is_Access_Type (T2)
and then (not Comes_From_Source (T1)
or else not Comes_From_Source (T2))
@@ -1077,8 +1055,8 @@ package body Sem_Type is
-- with itself, or with an anonymous type created for an attribute
-- reference Access.
- elsif Ekind_In (BT1, E_Anonymous_Access_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type)
+ elsif Ekind (BT1) in E_Anonymous_Access_Subprogram_Type
+ | E_Anonymous_Access_Protected_Subprogram_Type
and then Is_Access_Type (T2)
and then (not Comes_From_Source (T1)
or else not Comes_From_Source (T2))
@@ -1128,7 +1106,7 @@ package body Sem_Type is
-- imposed by context.
elsif Ekind (T2) = E_Access_Attribute_Type
- and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type)
+ and then Ekind (BT1) in E_General_Access_Type | E_Access_Type
and then Covers (Designated_Type (T1), Designated_Type (T2))
then
-- If the target type is a RACW type while the source is an access
@@ -1264,8 +1242,8 @@ package body Sem_Type is
-- Formal_Obj => Actual_Obj);
elsif Ada_Version >= Ada_2005
- and then Ekind (T1) = E_Anonymous_Access_Type
- and then Ekind (T2) = E_Anonymous_Access_Type
+ and then Is_Anonymous_Access_Type (T1)
+ and then Is_Anonymous_Access_Type (T2)
and then Is_Generic_Type (Directly_Designated_Type (T1))
and then Get_Instance_Of (Directly_Designated_Type (T1)) =
Directly_Designated_Type (T2)
@@ -1383,7 +1361,7 @@ package body Sem_Type is
begin
return In_Same_List (Parent (Typ), Op_Decl)
or else
- (Ekind_In (Scop, E_Package, E_Generic_Package)
+ (Is_Package_Or_Generic_Package (Scop)
and then List_Containing (Op_Decl) =
Visible_Declarations (Parent (Scop))
and then List_Containing (Parent (Typ)) =
@@ -1621,10 +1599,10 @@ package body Sem_Type is
and then Is_Overloaded (Act1)
and then
(Nkind (Act1) in N_Unary_Op
- or else Nkind_In (Left_Opnd (Act1), N_Integer_Literal,
- N_Real_Literal))
- and then Nkind_In (Right_Opnd (Act1), N_Integer_Literal,
- N_Real_Literal)
+ or else Nkind (Left_Opnd (Act1)) in
+ N_Integer_Literal | N_Real_Literal)
+ and then Nkind (Right_Opnd (Act1)) in
+ N_Integer_Literal | N_Real_Literal
and then Has_Compatible_Type (Act1, Standard_Boolean)
and then Etype (F1) = Standard_Boolean
then
@@ -1649,8 +1627,8 @@ package body Sem_Type is
elsif Present (Act2)
and then Nkind (Act2) in N_Op
and then Is_Overloaded (Act2)
- and then Nkind_In (Right_Opnd (Act2), N_Integer_Literal,
- N_Real_Literal)
+ and then Nkind (Right_Opnd (Act2)) in
+ N_Integer_Literal | N_Real_Literal
and then Has_Compatible_Type (Act2, Standard_Boolean)
then
-- The preference rule on the first actual is not
@@ -1910,9 +1888,7 @@ package body Sem_Type is
elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration
and then Present (Access_Definition (Parent (N)))
then
- if Ekind_In (It1.Typ, E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
- then
+ if Is_Anonymous_Access_Type (It1.Typ) then
if Ekind (It2.Typ) = Ekind (It1.Typ) then
-- True ambiguity
@@ -1923,9 +1899,7 @@ package body Sem_Type is
return It1;
end if;
- elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
- then
+ elsif Is_Anonymous_Access_Type (It2.Typ) then
return It2;
-- No legal interpretation
@@ -2120,7 +2094,7 @@ package body Sem_Type is
and then not In_Instance
then
if Is_Fixed_Point_Type (Typ)
- and then Nam_In (Chars (Nam1), Name_Op_Multiply, Name_Op_Divide)
+ and then Chars (Nam1) in Name_Op_Multiply | Name_Op_Divide
and then
(Ada_Version = Ada_83
or else (Ada_Version >= Ada_2012
@@ -2140,10 +2114,10 @@ package body Sem_Type is
-- declared in the same declarative list as the type. The node
-- may be an operator or a function call.
- elsif Nam_In (Chars (Nam1), Name_Op_Eq, Name_Op_Ne)
+ elsif Chars (Nam1) in Name_Op_Eq | Name_Op_Ne
and then Ada_Version >= Ada_2005
and then Etype (User_Subp) = Standard_Boolean
- and then Ekind (Operand_Type) = E_Anonymous_Access_Type
+ and then Is_Anonymous_Access_Type (Operand_Type)
and then
In_Same_Declaration_List
(Designated_Type (Operand_Type),
@@ -2274,35 +2248,6 @@ package body Sem_Type is
elsif T = Universal_Fixed then
return Etype (R);
- -- Ada 2005 (AI-230): Support the following operators:
-
- -- function "=" (L, R : universal_access) return Boolean;
- -- function "/=" (L, R : universal_access) return Boolean;
-
- -- Pool specific access types (E_Access_Type) are not covered by these
- -- operators because of the legality rule of 4.5.2(9.2): "The operands
- -- of the equality operators for universal_access shall be convertible
- -- to one another (see 4.6)". For example, considering the type decla-
- -- ration "type P is access Integer" and an anonymous access to Integer,
- -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
- -- is no rule in 4.6 that allows "access Integer" to be converted to P.
- -- Note that this does not preclude one operand to be a pool-specific
- -- access type, as a previous version of this code enforced.
-
- elsif Ada_Version >= Ada_2005
- and then Ekind_In (Etype (L), E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
- and then Is_Access_Type (Etype (R))
- then
- return Etype (L);
-
- elsif Ada_Version >= Ada_2005
- and then Ekind_In (Etype (R), E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
- and then Is_Access_Type (Etype (L))
- then
- return Etype (R);
-
-- If one operand is a raise_expression, use type of other operand
elsif Nkind (L) = N_Raise_Expression then
@@ -2450,7 +2395,19 @@ package body Sem_Type is
or else
(not Is_Tagged_Type (Typ)
and then Ekind (Typ) /= E_Anonymous_Access_Type
- and then Covers (Etype (N), Typ));
+ and then Covers (Etype (N), Typ))
+
+ or else
+ (Nkind (N) = N_Integer_Literal
+ and then Present (Find_Aspect (Typ, Aspect_Integer_Literal)))
+
+ or else
+ (Nkind (N) = N_Real_Literal
+ and then Present (Find_Aspect (Typ, Aspect_Real_Literal)))
+
+ or else
+ (Nkind (N) = N_String_Literal
+ and then Present (Find_Aspect (Typ, Aspect_String_Literal)));
-- Overloaded case
@@ -3148,7 +3105,7 @@ package body Sem_Type is
elsif Num = 1 then
T1 := Etype (New_First_F);
- if Nam_In (Op_Name, Name_Op_Subtract, Name_Op_Add, Name_Op_Abs) then
+ if Op_Name in Name_Op_Subtract | Name_Op_Add | Name_Op_Abs then
return Base_Type (T1) = Base_Type (T)
and then Is_Numeric_Type (T);
@@ -3166,24 +3123,23 @@ package body Sem_Type is
T1 := Etype (New_First_F);
T2 := Etype (Next_Formal (New_First_F));
- if Nam_In (Op_Name, Name_Op_And, Name_Op_Or, Name_Op_Xor) then
+ if Op_Name in Name_Op_And | Name_Op_Or | Name_Op_Xor then
return Base_Type (T1) = Base_Type (T2)
and then Base_Type (T1) = Base_Type (T)
and then Valid_Boolean_Arg (Base_Type (T));
- elsif Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne) then
+ elsif Op_Name in Name_Op_Eq | Name_Op_Ne then
return Base_Type (T1) = Base_Type (T2)
and then not Is_Limited_Type (T1)
and then Is_Boolean_Type (T);
- elsif Nam_In (Op_Name, Name_Op_Lt, Name_Op_Le,
- Name_Op_Gt, Name_Op_Ge)
+ elsif Op_Name in Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge
then
return Base_Type (T1) = Base_Type (T2)
and then Valid_Comparison_Arg (T1)
and then Is_Boolean_Type (T);
- elsif Nam_In (Op_Name, Name_Op_Add, Name_Op_Subtract) then
+ elsif Op_Name in Name_Op_Add | Name_Op_Subtract then
return Base_Type (T1) = Base_Type (T2)
and then Base_Type (T1) = Base_Type (T)
and then Is_Numeric_Type (T);
@@ -3236,7 +3192,7 @@ package body Sem_Type is
and then Is_Floating_Point_Type (T2)
and then Base_Type (T2) = Base_Type (T));
- elsif Nam_In (Op_Name, Name_Op_Mod, Name_Op_Rem) then
+ elsif Op_Name in Name_Op_Mod | Name_Op_Rem then
return Base_Type (T1) = Base_Type (T2)
and then Base_Type (T1) = Base_Type (T)
and then Is_Integer_Type (T);
@@ -3448,39 +3404,79 @@ package body Sem_Type is
then
return T2;
- elsif Ekind_In (B1, E_Access_Subprogram_Type,
- E_Access_Protected_Subprogram_Type)
+ elsif Is_Access_Type (T1)
+ and then Is_Access_Type (T2)
+ and then Is_Class_Wide_Type (Designated_Type (T1))
+ and then not Is_Class_Wide_Type (Designated_Type (T2))
+ and then
+ Is_Ancestor (Root_Type (Designated_Type (T1)), Designated_Type (T2))
+ then
+ return T1;
+
+ elsif Is_Access_Type (T1)
+ and then Is_Access_Type (T2)
+ and then Is_Class_Wide_Type (Designated_Type (T2))
+ and then not Is_Class_Wide_Type (Designated_Type (T1))
+ and then
+ Is_Ancestor (Root_Type (Designated_Type (T2)), Designated_Type (T1))
+ then
+ return T2;
+
+ elsif Ekind (B1) in E_Access_Subprogram_Type
+ | E_Access_Protected_Subprogram_Type
and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
and then Is_Access_Type (T2)
then
return T2;
- elsif Ekind_In (B2, E_Access_Subprogram_Type,
- E_Access_Protected_Subprogram_Type)
+ elsif Ekind (B2) in E_Access_Subprogram_Type
+ | E_Access_Protected_Subprogram_Type
and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
and then Is_Access_Type (T1)
then
return T1;
- elsif Ekind_In (T1, E_Allocator_Type,
- E_Access_Attribute_Type,
- E_Anonymous_Access_Type)
+ elsif Ekind (T1) in E_Allocator_Type | E_Access_Attribute_Type
and then Is_Access_Type (T2)
then
return T2;
- elsif Ekind_In (T2, E_Allocator_Type,
- E_Access_Attribute_Type,
- E_Anonymous_Access_Type)
+ elsif Ekind (T2) in E_Allocator_Type | E_Access_Attribute_Type
and then Is_Access_Type (T1)
then
return T1;
- -- If none of the above cases applies, types are not compatible
+ -- Ada 2005 (AI-230): Support the following operators:
- else
- return Any_Type;
+ -- function "=" (L, R : universal_access) return Boolean;
+ -- function "/=" (L, R : universal_access) return Boolean;
+
+ -- Pool-specific access types (E_Access_Type) are not covered by these
+ -- operators because of the legality rule of 4.5.2(9.2): "The operands
+ -- of the equality operators for universal_access shall be convertible
+ -- to one another (see 4.6)". For example, considering the type decla-
+ -- ration "type P is access Integer" and an anonymous access to Integer,
+ -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
+ -- is no rule in 4.6 that allows "access Integer" to be converted to P.
+ -- Note that this does not preclude one operand to be a pool-specific
+ -- access type, as a previous version of this code enforced.
+
+ elsif Ada_Version >= Ada_2005 then
+ if Is_Anonymous_Access_Type (T1)
+ and then Is_Access_Type (T2)
+ then
+ return T1;
+
+ elsif Is_Anonymous_Access_Type (T2)
+ and then Is_Access_Type (T1)
+ then
+ return T2;
+ end if;
end if;
+
+ -- If none of the above cases applies, types are not compatible
+
+ return Any_Type;
end Specific_Type;
---------------------
diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads
index 08ab7c3..6c6d5eb 100644
--- a/gcc/ada/sem_type.ads
+++ b/gcc/ada/sem_type.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -196,7 +196,7 @@ package Sem_Type is
-- a compatible one.
function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean;
- -- A user-defined function hides a predefined operator if it is matches the
+ -- A user-defined function hides a predefined operator if it matches the
-- signature of the operator, and is declared in an open scope, or in the
-- scope of the result type.
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index e1703e9..679b3be 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -36,6 +36,7 @@ with Exp_Ch11; use Exp_Ch11;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Freeze; use Freeze;
+with Itypes; use Itypes;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet.Sp; use Namet.Sp;
@@ -115,8 +116,8 @@ package body Sem_Util is
(Item_Id : Entity_Id;
Property : Name_Id) return Boolean;
-- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
- -- Determine whether an abstract state or a variable denoted by entity
- -- Item_Id has enabled property Property.
+ -- Determine whether the state abstraction, variable, or type denoted by
+ -- entity Item_Id has enabled property Property.
function Has_Null_Extension (T : Entity_Id) return Boolean;
-- T is a derived tagged type. Check whether the type extension is null.
@@ -132,6 +133,10 @@ package body Sem_Util is
-- components in the selected variant to determine whether all of them
-- have a default.
+ function Is_Preelaborable_Function (Id : Entity_Id) return Boolean;
+ -- Ada 2020: Determine whether the specified function is suitable as the
+ -- name of a call in a preelaborable construct (RM 10.2.1(7/5)).
+
type Null_Status_Kind is
(Is_Null,
-- This value indicates that a subexpression is known to have a null
@@ -190,8 +195,7 @@ package body Sem_Util is
Nod := Declaration_Node (Base_Type (Typ));
- if Nkind_In (Nod, N_Full_Type_Declaration,
- N_Private_Type_Declaration)
+ if Nkind (Nod) in N_Full_Type_Declaration | N_Private_Type_Declaration
then
return Empty_List;
end if;
@@ -1019,11 +1023,13 @@ package body Sem_Util is
HSS : Node_Id;
begin
- pragma Assert (Nkind_In (N, N_Block_Statement,
- N_Entry_Body,
- N_Package_Body,
- N_Subprogram_Body,
- N_Task_Body));
+ pragma Assert
+ (Nkind (N) in
+ N_Block_Statement |
+ N_Entry_Body |
+ N_Package_Body |
+ N_Subprogram_Body |
+ N_Task_Body);
HSS := Handled_Statement_Sequence (N);
@@ -1218,6 +1224,10 @@ package body Sem_Util is
-- Similar to previous one, for discriminated components constrained
-- by the discriminant of the enclosing object.
+ function Copy_And_Maybe_Dereference (N : Node_Id) return Node_Id;
+ -- Copy the subtree rooted at N and insert an explicit dereference if it
+ -- is of an access type.
+
-----------------------------------
-- Build_Actual_Array_Constraint --
-----------------------------------
@@ -1239,7 +1249,7 @@ package body Sem_Util is
if Denotes_Discriminant (Old_Lo) then
Lo :=
Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (P),
+ Prefix => Copy_And_Maybe_Dereference (P),
Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
else
@@ -1257,7 +1267,7 @@ package body Sem_Util is
if Denotes_Discriminant (Old_Hi) then
Hi :=
Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (P),
+ Prefix => Copy_And_Maybe_Dereference (P),
Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
else
@@ -1286,7 +1296,7 @@ package body Sem_Util is
while Present (D) loop
if Denotes_Discriminant (Node (D)) then
D_Val := Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (P),
+ Prefix => Copy_And_Maybe_Dereference (P),
Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
else
@@ -1322,13 +1332,13 @@ package body Sem_Util is
D_Val := New_Copy_Tree (D);
Set_Expression (D_Val,
Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (P),
+ Prefix => Copy_And_Maybe_Dereference (P),
Selector_Name =>
New_Occurrence_Of (Entity (Expression (D)), Loc)));
elsif Denotes_Discriminant (D) then
D_Val := Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (P),
+ Prefix => Copy_And_Maybe_Dereference (P),
Selector_Name => New_Occurrence_Of (Entity (D), Loc));
else
@@ -1342,6 +1352,22 @@ package body Sem_Util is
return Constraints;
end Build_Access_Record_Constraint;
+ --------------------------------
+ -- Copy_And_Maybe_Dereference --
+ --------------------------------
+
+ function Copy_And_Maybe_Dereference (N : Node_Id) return Node_Id is
+ New_N : constant Node_Id := New_Copy_Tree (N);
+
+ begin
+ if Is_Access_Type (Etype (N)) then
+ return Make_Explicit_Dereference (Sloc (Parent (N)), New_N);
+
+ else
+ return New_N;
+ end if;
+ end Copy_And_Maybe_Dereference;
+
-- Start of processing for Build_Actual_Subtype_Of_Component
begin
@@ -1396,7 +1422,7 @@ package body Sem_Util is
if Ekind (Desig_Typ) = E_Array_Subtype then
Id := First_Index (Desig_Typ);
- -- Check whether an index bound is constrained by a discriminant.
+ -- Check whether an index bound is constrained by a discriminant
while Present (Id) loop
Index_Typ := Underlying_Type (Etype (Id));
@@ -1485,17 +1511,38 @@ package body Sem_Util is
Loc : constant Source_Ptr := Sloc (Bod);
Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id);
Clone_Body : Node_Id;
+ Assoc_List : constant Elist_Id := New_Elmt_List;
begin
-- The declaration of the class-wide clone was created when the
-- corresponding class-wide condition was analyzed.
+ -- The body of the original condition may contain references to
+ -- the formals of Spec_Id. In the body of the class-wide clone,
+ -- these must be replaced with the corresponding formals of
+ -- the clone.
+
+ declare
+ Spec_Formal_Id : Entity_Id := First_Formal (Spec_Id);
+ Clone_Formal_Id : Entity_Id := First_Formal (Clone_Id);
+ begin
+ while Present (Spec_Formal_Id) loop
+ Append_Elmt (Spec_Formal_Id, Assoc_List);
+ Append_Elmt (Clone_Formal_Id, Assoc_List);
+
+ Next_Formal (Spec_Formal_Id);
+ Next_Formal (Clone_Formal_Id);
+ end loop;
+ end;
+
Clone_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Subprogram_Spec (Parent (Clone_Id)),
Declarations => Declarations (Bod),
- Handled_Statement_Sequence => Handled_Statement_Sequence (Bod));
+ Handled_Statement_Sequence =>
+ New_Copy_Tree (Handled_Statement_Sequence (Bod),
+ Map => Assoc_List));
-- The new operation is internal and overriding indicators do not apply
-- (the original primitive may have carried one).
@@ -1618,6 +1665,13 @@ package body Sem_Util is
-- wrapper call to inherited operation.
Set_Class_Wide_Clone (Spec_Id, Clone_Id);
+
+ -- Inherit debug info flag from Spec_Id to Clone_Id to allow debugging
+ -- of the class-wide clone subprogram.
+
+ if Needs_Debug_Info (Spec_Id) then
+ Set_Debug_Info_Needed (Clone_Id);
+ end if;
end Build_Class_Wide_Clone_Decl;
-----------------------------
@@ -1656,6 +1710,78 @@ package body Sem_Util is
return Decl;
end Build_Component_Subtype;
+ -----------------------------
+ -- Build_Constrained_Itype --
+ -----------------------------
+
+ procedure Build_Constrained_Itype
+ (N : Node_Id;
+ Typ : Entity_Id;
+ New_Assoc_List : List_Id)
+ is
+ Constrs : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (N);
+ Def_Id : Entity_Id;
+ Indic : Node_Id;
+ New_Assoc : Node_Id;
+ Subtyp_Decl : Node_Id;
+
+ begin
+ New_Assoc := First (New_Assoc_List);
+ while Present (New_Assoc) loop
+
+ -- There is exactly one choice in the component association (and
+ -- it is either a discriminant, a component or the others clause).
+ pragma Assert (List_Length (Choices (New_Assoc)) = 1);
+
+ -- Duplicate expression for the discriminant and put it on the
+ -- list of constraints for the itype declaration.
+
+ if Is_Entity_Name (First (Choices (New_Assoc)))
+ and then
+ Ekind (Entity (First (Choices (New_Assoc)))) = E_Discriminant
+ then
+ Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc)));
+ end if;
+
+ Next (New_Assoc);
+ end loop;
+
+ if Has_Unknown_Discriminants (Typ)
+ and then Present (Underlying_Record_View (Typ))
+ then
+ Indic :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Underlying_Record_View (Typ), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Constrs));
+ else
+ Indic :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Base_Type (Typ), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Constrs));
+ end if;
+
+ Def_Id := Create_Itype (Ekind (Typ), N);
+
+ Subtyp_Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Subtype_Indication => Indic);
+ Set_Parent (Subtyp_Decl, Parent (N));
+
+ -- Itypes must be analyzed with checks off (see itypes.ads)
+
+ Analyze (Subtyp_Decl, Suppress => All_Checks);
+
+ Set_Etype (N, Def_Id);
+ end Build_Constrained_Itype;
+
---------------------------
-- Build_Default_Subtype --
---------------------------
@@ -1899,12 +2025,6 @@ package body Sem_Util is
if Present (Elaboration_Entity (Spec_Id)) then
return;
- -- Ignore in ASIS mode, elaboration entity is not in source and plays
- -- no role in analysis.
-
- elsif ASIS_Mode then
- return;
-
-- Do not generate an elaboration entity in GNATprove move because the
-- elaboration counter is a form of expansion.
@@ -2099,6 +2219,81 @@ package body Sem_Util is
return New_Spec;
end Build_Overriding_Spec;
+ -------------------
+ -- Build_Subtype --
+ -------------------
+
+ function Build_Subtype
+ (Related_Node : Node_Id;
+ Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Constraints : List_Id)
+ return Entity_Id
+ is
+ Indic : Node_Id;
+ Subtyp_Decl : Node_Id;
+ Def_Id : Entity_Id;
+ Btyp : Entity_Id := Base_Type (Typ);
+
+ begin
+ -- The Related_Node better be here or else we won't be able to
+ -- attach new itypes to a node in the tree.
+
+ pragma Assert (Present (Related_Node));
+
+ -- If the view of the component's type is incomplete or private
+ -- with unknown discriminants, then the constraint must be applied
+ -- to the full type.
+
+ if Has_Unknown_Discriminants (Btyp)
+ and then Present (Underlying_Type (Btyp))
+ then
+ Btyp := Underlying_Type (Btyp);
+ end if;
+
+ Indic :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc, Constraints));
+
+ Def_Id := Create_Itype (Ekind (Typ), Related_Node);
+
+ Subtyp_Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Subtype_Indication => Indic);
+
+ Set_Parent (Subtyp_Decl, Parent (Related_Node));
+
+ -- Itypes must be analyzed with checks off (see package Itypes)
+
+ Analyze (Subtyp_Decl, Suppress => All_Checks);
+
+ if Is_Itype (Def_Id) and then Has_Predicates (Typ) then
+ Inherit_Predicate_Flags (Def_Id, Typ);
+
+ -- Indicate where the predicate function may be found
+
+ if Is_Itype (Typ) then
+ if Present (Predicate_Function (Def_Id)) then
+ null;
+
+ elsif Present (Predicate_Function (Typ)) then
+ Set_Predicate_Function (Def_Id, Predicate_Function (Typ));
+
+ else
+ Set_Predicated_Parent (Def_Id, Predicated_Parent (Typ));
+ end if;
+
+ elsif No (Predicate_Function (Def_Id)) then
+ Set_Predicated_Parent (Def_Id, Typ);
+ end if;
+ end if;
+
+ return Def_Id;
+ end Build_Subtype;
+
-----------------------------------
-- Cannot_Raise_Constraint_Error --
-----------------------------------
@@ -2376,10 +2571,8 @@ package body Sem_Util is
-- Don't collect identifiers of packages, called functions, etc
- elsif Ekind_In (Entity (N), E_Package,
- E_Function,
- E_Procedure,
- E_Entry)
+ elsif Ekind (Entity (N)) in
+ E_Package | E_Function | E_Procedure | E_Entry
then
return Skip;
@@ -2399,9 +2592,8 @@ package body Sem_Util is
-- to identify a corner case???
elsif Nkind (Parent (N)) = N_Component_Association
- and then Nkind_In (Parent (Parent (N)),
- N_Aggregate,
- N_Extension_Aggregate)
+ and then Nkind (Parent (Parent (N))) in
+ N_Aggregate | N_Extension_Aggregate
then
declare
Choice : constant Node_Id := First (Choices (Parent (N)));
@@ -2435,15 +2627,15 @@ package body Sem_Util is
return Abandon;
end if;
- if Ekind_In (Id, E_Function, E_Generic_Function)
+ if Ekind (Id) in E_Function | E_Generic_Function
and then Has_Out_Or_In_Out_Parameter (Id)
then
Formal := First_Formal (Id);
Actual := First_Actual (Call);
while Present (Actual) and then Present (Formal) loop
if Actual = N then
- if Ekind_In (Formal, E_Out_Parameter,
- E_In_Out_Parameter)
+ if Ekind (Formal) in E_Out_Parameter
+ | E_In_Out_Parameter
then
Is_Writable_Actual := True;
end if;
@@ -2594,15 +2786,15 @@ package body Sem_Util is
if Ada_Version < Ada_2012
or else not Check_Actuals (N)
- or else (not (Nkind (N) in N_Op)
- and then not (Nkind (N) in N_Membership_Test)
- and then not Nkind_In (N, N_Range,
- N_Aggregate,
- N_Extension_Aggregate,
- N_Full_Type_Declaration,
- N_Function_Call,
- N_Procedure_Call_Statement,
- N_Entry_Call_Statement))
+ or else Nkind (N) not in N_Op
+ | N_Membership_Test
+ | N_Range
+ | N_Aggregate
+ | N_Extension_Aggregate
+ | N_Full_Type_Declaration
+ | N_Function_Call
+ | N_Procedure_Call_Statement
+ | N_Entry_Call_Statement
or else (Nkind (N) = N_Full_Type_Declaration
and then not Is_Record_Type (Defining_Identifier (N)))
@@ -2642,7 +2834,7 @@ package body Sem_Util is
Collect_Identifiers (Right_Opnd (N));
end if;
- if Nkind_In (N, N_In, N_Not_In)
+ if Nkind (N) in N_In | N_Not_In
and then Present (Alternatives (N))
then
Expr := First (Alternatives (N));
@@ -2720,8 +2912,7 @@ package body Sem_Util is
Formal := First_Formal (Id);
Actual := First_Actual (N);
while Present (Actual) and then Present (Formal) loop
- if Ekind_In (Formal, E_Out_Parameter,
- E_In_Out_Parameter)
+ if Ekind (Formal) in E_Out_Parameter | E_In_Out_Parameter
then
Collect_Identifiers (Actual);
end if;
@@ -2759,7 +2950,7 @@ package body Sem_Util is
declare
Count_Components : Uint := Uint_0;
Num_Components : Uint;
- Others_Assoc : Node_Id;
+ Others_Assoc : Node_Id := Empty;
Others_Choice : Node_Id := Empty;
Others_Box_Present : Boolean := False;
@@ -2788,8 +2979,8 @@ package body Sem_Util is
-- Count several components
- elsif Nkind_In (Choice, N_Range,
- N_Subtype_Indication)
+ elsif Nkind (Choice) in
+ N_Range | N_Subtype_Indication
or else (Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice)))
then
@@ -2844,6 +3035,8 @@ package body Sem_Util is
-- minimum decoration required to collect the
-- identifiers.
+ pragma Assert (Present (Others_Assoc));
+
if not Expander_Active then
Comp_Expr := Expression (Others_Assoc);
else
@@ -2889,8 +3082,8 @@ package body Sem_Util is
while Present (Assoc) loop
Choice := First (Choices (Assoc));
while Present (Choice) loop
- if Nkind_In (Choice, N_Range,
- N_Subtype_Indication)
+ if Nkind (Choice) in
+ N_Range | N_Subtype_Indication
or else (Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice)))
then
@@ -3250,8 +3443,8 @@ package body Sem_Util is
elsif Nkind (P) = N_Parameter_Specification
and then Scope (Current_Scope) = Scope (Nam)
- and then Nkind_In (Parent (P), N_Entry_Declaration,
- N_Subprogram_Declaration)
+ and then Nkind (Parent (P)) in
+ N_Entry_Declaration | N_Subprogram_Declaration
then
Error_Msg_N
("internal call cannot appear in default for formal of "
@@ -3320,7 +3513,8 @@ package body Sem_Util is
-- Loop through sequence of basic declarative items
Outer : while Present (Decl) loop
- if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body)
+ if Nkind (Decl) not in
+ N_Subprogram_Body | N_Package_Body | N_Task_Body
and then Nkind (Decl) not in N_Body_Stub
then
Next (Decl);
@@ -3339,10 +3533,6 @@ package body Sem_Util is
Error_Msg_N
("(Ada 83) decl cannot appear after body#", Decl);
end if;
- else
- Error_Msg_Sloc := Body_Sloc;
- Check_SPARK_05_Restriction
- ("decl cannot appear after body#", Decl);
end if;
end if;
@@ -3362,7 +3552,7 @@ package body Sem_Util is
Scop : Entity_Id;
begin
- pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
+ pragma Assert (Ekind (Id) in E_Abstract_State | E_Variable);
-- Nothing to do for internally-generated abstract states and variables
-- because they do not represent the hidden state of the source unit.
@@ -3387,23 +3577,21 @@ package body Sem_Util is
return;
-- Objects and states that appear immediately within a subprogram or
- -- inside a construct nested within a subprogram do not introduce a
- -- hidden state. They behave as local variable declarations.
+ -- entry inside a construct nested within a subprogram do not
+ -- introduce a hidden state. They behave as local variable
+ -- declarations. The same is true for elaboration code inside a block
+ -- or a task.
- elsif Is_Subprogram (Context) then
+ elsif Is_Subprogram_Or_Entry (Context)
+ or else Ekind (Context) in E_Block | E_Task_Type
+ then
return;
-
- -- When examining a package body, use the entity of the spec as it
- -- carries the abstract state declarations.
-
- elsif Ekind (Context) = E_Package_Body then
- Context := Spec_Entity (Context);
end if;
-- Stop the traversal when a package subject to a null abstract state
-- has been found.
- if Ekind_In (Context, E_Generic_Package, E_Package)
+ if Is_Package_Or_Generic_Package (Context)
and then Has_Null_Abstract_State (Context)
then
exit;
@@ -3613,7 +3801,7 @@ package body Sem_Util is
-- Initial_Condition and Initializes as this is part of the
-- elaboration checks for the constituent (SPARK RM 9(3)).
- if Nam_In (Prag_Nam, Name_Initial_Condition, Name_Initializes) then
+ if Prag_Nam in Name_Initial_Condition | Name_Initializes then
return;
-- When the reference appears within pragma Depends or Global,
@@ -3621,7 +3809,7 @@ package body Sem_Util is
-- that the pragma may not encapsulated by the type definition,
-- but this is still a valid context.
- elsif Nam_In (Prag_Nam, Name_Depends, Name_Global)
+ elsif Prag_Nam in Name_Depends | Name_Global
and then Is_Single_Task_Pragma (Par, Conc_Obj)
then
return;
@@ -3630,8 +3818,8 @@ package body Sem_Util is
-- The reference appears somewhere in the definition of a single
-- concurrent type (SPARK RM 9(3)).
- elsif Nkind_In (Par, N_Single_Protected_Declaration,
- N_Single_Task_Declaration)
+ elsif Nkind (Par) in
+ N_Single_Protected_Declaration | N_Single_Task_Declaration
and then Defining_Entity (Par) = Conc_Obj
then
return;
@@ -3639,10 +3827,10 @@ package body Sem_Util is
-- The reference appears within the declaration or body of a single
-- concurrent type (SPARK RM 9(3)).
- elsif Nkind_In (Par, N_Protected_Body,
- N_Protected_Type_Declaration,
- N_Task_Body,
- N_Task_Type_Declaration)
+ elsif Nkind (Par) in N_Protected_Body
+ | N_Protected_Type_Declaration
+ | N_Task_Body
+ | N_Task_Type_Declaration
and then Is_Single_Declaration_Or_Body (Par, Conc_Obj)
then
return;
@@ -3661,10 +3849,10 @@ package body Sem_Util is
-- real check was already performed in the original context of the
-- reference.
- elsif Nkind_In (Par, N_Package_Body,
- N_Package_Declaration,
- N_Subprogram_Body,
- N_Subprogram_Declaration)
+ elsif Nkind (Par) in N_Package_Body
+ | N_Package_Declaration
+ | N_Subprogram_Body
+ | N_Subprogram_Declaration
and then Is_Internal_Declaration_Or_Body (Par)
then
return;
@@ -3874,10 +4062,10 @@ package body Sem_Util is
-- Empty list (no global items) or single global item
-- declaration (only input items).
- if Nkind_In (List, N_Null,
- N_Expanded_Name,
- N_Identifier,
- N_Selected_Component)
+ if Nkind (List) in N_Null
+ | N_Expanded_Name
+ | N_Identifier
+ | N_Selected_Component
then
return False;
@@ -3928,7 +4116,7 @@ package body Sem_Util is
Param := First_Formal (Subp);
while Present (Param) loop
- if Ekind_In (Param, E_Out_Parameter, E_In_Out_Parameter) then
+ if Ekind (Param) in E_Out_Parameter | E_In_Out_Parameter then
return False;
end if;
@@ -3993,7 +4181,7 @@ package body Sem_Util is
procedure Check_Conjuncts (Expr : Node_Id) is
begin
- if Nkind_In (Expr, N_Op_And, N_And_Then) then
+ if Nkind (Expr) in N_Op_And | N_And_Then then
Check_Conjuncts (Left_Opnd (Expr));
Check_Conjuncts (Right_Opnd (Expr));
else
@@ -4075,11 +4263,11 @@ package body Sem_Util is
Ent : Entity_Id;
begin
- if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then
+ if Nkind (N) in N_Explicit_Dereference | N_Function_Call then
Post_State_Seen := True;
return Abandon;
- elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then
+ elsif Nkind (N) in N_Expanded_Name | N_Identifier then
Ent := Entity (N);
-- Treat an undecorated reference as OK
@@ -4089,10 +4277,10 @@ package body Sem_Util is
-- A reference to an assignable entity is considered a
-- change in the post-state of a subprogram.
- or else Ekind_In (Ent, E_Generic_In_Out_Parameter,
- E_In_Out_Parameter,
- E_Out_Parameter,
- E_Variable)
+ or else Ekind (Ent) in E_Generic_In_Out_Parameter
+ | E_In_Out_Parameter
+ | E_Out_Parameter
+ | E_Variable
-- The reference may be modified through a dereference
@@ -4150,8 +4338,7 @@ package body Sem_Util is
-- Examine the expression of a postcondition
- else pragma Assert (Nam_In (Nam, Name_Postcondition,
- Name_Refined_Post));
+ else pragma Assert (Nam in Name_Postcondition | Name_Refined_Post);
Check_Expression (Expr);
end if;
end Check_Result_And_Post_State_In_Pragma;
@@ -4225,8 +4412,8 @@ package body Sem_Util is
Prag := Pre_Post_Conditions (Items);
while Present (Prag) loop
- if Nam_In (Pragma_Name_Unmapped (Prag),
- Name_Postcondition, Name_Refined_Post)
+ if Pragma_Name_Unmapped (Prag)
+ in Name_Postcondition | Name_Refined_Post
and then not Error_Posted (Prag)
then
Post_Prag := Prag;
@@ -4253,7 +4440,7 @@ package body Sem_Util is
-- Do not emit any errors if the subprogram is not a function
- if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
+ if Ekind (Spec_Id) not in E_Function | E_Generic_Function then
null;
-- Regardless of whether the function has postconditions or contract
@@ -4386,8 +4573,8 @@ package body Sem_Util is
if Present (Decls) then
Decl := First (Decls);
while Present (Decl) loop
- if Nkind_In (Decl, N_Generic_Package_Declaration,
- N_Package_Declaration)
+ if Nkind (Decl) in N_Generic_Package_Declaration
+ | N_Package_Declaration
then
Check_Package (Decl);
end if;
@@ -4430,10 +4617,10 @@ package body Sem_Util is
-- An entry, protected, subprogram, or task body may declare a nested
-- package.
- elsif Nkind_In (Context, N_Entry_Body,
- N_Protected_Body,
- N_Subprogram_Body,
- N_Task_Body)
+ elsif Nkind (Context) in N_Entry_Body
+ | N_Protected_Body
+ | N_Subprogram_Body
+ | N_Task_Body
then
-- Do not verify proper state refinement when the body is subject to
-- pragma SPARK_Mode Off because this disables the requirement for
@@ -4458,8 +4645,8 @@ package body Sem_Util is
-- A library level [generic] package may declare a nested package
- elsif Nkind_In (Context, N_Generic_Package_Declaration,
- N_Package_Declaration)
+ elsif Nkind (Context) in
+ N_Generic_Package_Declaration | N_Package_Declaration
and then Is_Main_Unit
then
Check_Package (Context);
@@ -4512,7 +4699,7 @@ package body Sem_Util is
-- For indexed and selected components, recursively check the prefix
- if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
+ if Nkind (Obj) in N_Indexed_Component | N_Selected_Component then
return Enclosing_Protected_Type (Prefix (Obj));
-- The object does not denote a protected component
@@ -4616,9 +4803,8 @@ package body Sem_Util is
Constit_Id := Entity_Of (Constit);
if Present (Constit_Id)
- and then Ekind_In (Constit_Id, E_Abstract_State,
- E_Constant,
- E_Variable)
+ and then Ekind (Constit_Id) in
+ E_Abstract_State | E_Constant | E_Variable
then
Remove (States, Constit_Id);
end if;
@@ -4746,6 +4932,96 @@ package body Sem_Util is
end if;
end Check_Unused_Body_States;
+ ------------------------------------
+ -- Check_Volatility_Compatibility --
+ ------------------------------------
+
+ procedure Check_Volatility_Compatibility
+ (Id1, Id2 : Entity_Id;
+ Description_1, Description_2 : String;
+ Srcpos_Bearer : Node_Id) is
+
+ begin
+ if SPARK_Mode /= On then
+ return;
+ end if;
+
+ declare
+ AR1 : constant Boolean := Async_Readers_Enabled (Id1);
+ AW1 : constant Boolean := Async_Writers_Enabled (Id1);
+ ER1 : constant Boolean := Effective_Reads_Enabled (Id1);
+ EW1 : constant Boolean := Effective_Writes_Enabled (Id1);
+ AR2 : constant Boolean := Async_Readers_Enabled (Id2);
+ AW2 : constant Boolean := Async_Writers_Enabled (Id2);
+ ER2 : constant Boolean := Effective_Reads_Enabled (Id2);
+ EW2 : constant Boolean := Effective_Writes_Enabled (Id2);
+
+ AR_Check_Failed : constant Boolean := AR1 and not AR2;
+ AW_Check_Failed : constant Boolean := AW1 and not AW2;
+ ER_Check_Failed : constant Boolean := ER1 and not ER2;
+ EW_Check_Failed : constant Boolean := EW1 and not EW2;
+
+ package Failure_Description is
+ procedure Note_If_Failure
+ (Failed : Boolean; Aspect_Name : String);
+ -- If Failed is False, do nothing.
+ -- If Failed is True, add Aspect_Name to the failure description.
+
+ function Failure_Text return String;
+ -- returns accumulated list of failing aspects
+ end Failure_Description;
+
+ package body Failure_Description is
+ Description_Buffer : Bounded_String;
+
+ ---------------------
+ -- Note_If_Failure --
+ ---------------------
+
+ procedure Note_If_Failure
+ (Failed : Boolean; Aspect_Name : String) is
+ begin
+ if Failed then
+ if Description_Buffer.Length /= 0 then
+ Append (Description_Buffer, ", ");
+ end if;
+ Append (Description_Buffer, Aspect_Name);
+ end if;
+ end Note_If_Failure;
+
+ ------------------
+ -- Failure_Text --
+ ------------------
+
+ function Failure_Text return String is
+ begin
+ return +Description_Buffer;
+ end Failure_Text;
+ end Failure_Description;
+
+ use Failure_Description;
+ begin
+ if AR_Check_Failed
+ or AW_Check_Failed
+ or ER_Check_Failed
+ or EW_Check_Failed
+ then
+ Note_If_Failure (AR_Check_Failed, "Async_Readers");
+ Note_If_Failure (AW_Check_Failed, "Async_Writers");
+ Note_If_Failure (ER_Check_Failed, "Effective_Reads");
+ Note_If_Failure (EW_Check_Failed, "Effective_Writes");
+
+ Error_Msg_N
+ (Description_1
+ & " and "
+ & Description_2
+ & " are not compatible with respect to volatility due to "
+ & Failure_Text,
+ Srcpos_Bearer);
+ end if;
+ end;
+ end Check_Volatility_Compatibility;
+
-----------------
-- Choice_List --
-----------------
@@ -4800,7 +5076,7 @@ package body Sem_Util is
elsif Ekind (Item_Id) = E_Abstract_State then
Append_New_Elmt (Item_Id, States);
- elsif Ekind_In (Item_Id, E_Constant, E_Variable)
+ elsif Ekind (Item_Id) in E_Constant | E_Variable
and then Is_Visible_Object (Item_Id)
then
Append_New_Elmt (Item_Id, States);
@@ -5587,7 +5863,14 @@ package body Sem_Util is
-- will happen when something is evaluated if it never will be
-- evaluated.
- if not Is_Statically_Unevaluated (N) then
+ -- Suppress error reporting when checking that the expression of a
+ -- static expression function is a potentially static expression,
+ -- because we don't want additional errors being reported during the
+ -- preanalysis of the expression (see Analyze_Expression_Function).
+
+ if not Is_Statically_Unevaluated (N)
+ and then not Checking_Potentially_Static_Expression
+ then
if Present (Ent) then
Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
else
@@ -5860,14 +6143,14 @@ package body Sem_Util is
-- Current_Entity_In_Scope --
-----------------------------
- function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
+ function Current_Entity_In_Scope (N : Name_Id) return Entity_Id is
E : Entity_Id;
CS : constant Entity_Id := Current_Scope;
Transient_Case : constant Boolean := Scope_Is_Transient;
begin
- E := Get_Name_Entity_Id (Chars (N));
+ E := Get_Name_Entity_Id (N);
while Present (E)
and then Scope (E) /= CS
and then (not Transient_Case or else Scope (E) /= Scope (CS))
@@ -5878,6 +6161,15 @@ package body Sem_Util is
return E;
end Current_Entity_In_Scope;
+ -----------------------------
+ -- Current_Entity_In_Scope --
+ -----------------------------
+
+ function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
+ begin
+ return Current_Entity_In_Scope (Chars (N));
+ end Current_Entity_In_Scope;
+
-------------------
-- Current_Scope --
-------------------
@@ -6126,8 +6418,28 @@ package body Sem_Util is
function Is_Renaming (N : Node_Id) return Boolean is
begin
- return
- Is_Entity_Name (N) and then Present (Renamed_Entity (Entity (N)));
+ if not Is_Entity_Name (N) then
+ return False;
+ end if;
+
+ case Ekind (Entity (N)) is
+ when E_Variable | E_Constant =>
+ return Present (Renamed_Object (Entity (N)));
+
+ when E_Exception
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Package
+ | E_Generic_Procedure
+ | E_Operator
+ | E_Package
+ | E_Procedure
+ =>
+ return Present (Renamed_Entity (Entity (N)));
+
+ when others =>
+ return False;
+ end case;
end Is_Renaming;
-----------------------
@@ -6354,7 +6666,7 @@ package body Sem_Util is
function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
begin
if Is_Entity_Name (A1) then
- if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
+ if Nkind (A2) in N_Selected_Component | N_Indexed_Component
and then not Is_Access_Type (Etype (A1))
then
return Denotes_Same_Object (A1, Prefix (A2))
@@ -6366,9 +6678,9 @@ package body Sem_Util is
elsif Is_Entity_Name (A2) then
return Denotes_Same_Prefix (A1 => A2, A2 => A1);
- elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
+ elsif Nkind (A1) in N_Selected_Component | N_Indexed_Component | N_Slice
and then
- Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
+ Nkind (A2) in N_Selected_Component | N_Indexed_Component | N_Slice
then
declare
Root1, Root2 : Node_Id;
@@ -6377,8 +6689,8 @@ package body Sem_Util is
begin
Root1 := Prefix (A1);
while not Is_Entity_Name (Root1) loop
- if not Nkind_In
- (Root1, N_Selected_Component, N_Indexed_Component)
+ if Nkind (Root1) not in
+ N_Selected_Component | N_Indexed_Component
then
return False;
else
@@ -6390,8 +6702,8 @@ package body Sem_Util is
Root2 := Prefix (A2);
while not Is_Entity_Name (Root2) loop
- if not Nkind_In (Root2, N_Selected_Component,
- N_Indexed_Component)
+ if Nkind (Root2) not in
+ N_Selected_Component | N_Indexed_Component
then
return False;
else
@@ -6501,19 +6813,19 @@ package body Sem_Util is
-- Start of processing for Designate_Same_Unit
begin
- if Nkind_In (K1, N_Identifier, N_Defining_Identifier)
+ if K1 in N_Identifier | N_Defining_Identifier
and then
- Nkind_In (K2, N_Identifier, N_Defining_Identifier)
+ K2 in N_Identifier | N_Defining_Identifier
then
return Chars (Name1) = Chars (Name2);
- elsif Nkind_In (K1, N_Expanded_Name,
- N_Selected_Component,
- N_Defining_Program_Unit_Name)
- and then
- Nkind_In (K2, N_Expanded_Name,
- N_Selected_Component,
- N_Defining_Program_Unit_Name)
+ elsif K1 in N_Expanded_Name
+ | N_Selected_Component
+ | N_Defining_Program_Unit_Name
+ and then
+ K2 in N_Expanded_Name
+ | N_Selected_Component
+ | N_Defining_Program_Unit_Name
then
return
(Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
@@ -6609,7 +6921,7 @@ package body Sem_Util is
end if;
if (Is_Formal (E)
- or else Ekind_In (E, E_Variable, E_Constant))
+ or else Ekind (E) in E_Variable | E_Constant)
and then Present (Get_Accessibility (E))
then
return New_Occurrence_Of (Get_Accessibility (E), Loc);
@@ -6619,7 +6931,7 @@ package body Sem_Util is
-- Handle a constant-folded conditional expression by avoiding use of
-- the original node.
- if Nkind_In (Expr, N_Case_Expression, N_If_Expression) then
+ if Nkind (Expr) in N_Case_Expression | N_If_Expression then
Expr := N;
end if;
@@ -6938,13 +7250,13 @@ package body Sem_Util is
begin
Par := Parent (N);
while Present (Par) loop
- if Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then
+ if Nkind (Par) in N_Package_Body | N_Subprogram_Body then
Spec_Id := Corresponding_Spec (Par);
if Present (Spec_Id)
- and then Nkind_In (Unit_Declaration_Node (Spec_Id),
- N_Generic_Package_Declaration,
- N_Generic_Subprogram_Declaration)
+ and then Nkind (Unit_Declaration_Node (Spec_Id)) in
+ N_Generic_Package_Declaration |
+ N_Generic_Subprogram_Declaration
then
return Par;
end if;
@@ -6968,19 +7280,19 @@ package body Sem_Util is
begin
Par := Parent (N);
while Present (Par) loop
- if Nkind_In (Par, N_Generic_Package_Declaration,
- N_Generic_Subprogram_Declaration)
+ if Nkind (Par) in N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
then
return Par;
- elsif Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then
+ elsif Nkind (Par) in N_Package_Body | N_Subprogram_Body then
Spec_Id := Corresponding_Spec (Par);
if Present (Spec_Id) then
Spec_Decl := Unit_Declaration_Node (Spec_Id);
- if Nkind_In (Spec_Decl, N_Generic_Package_Declaration,
- N_Generic_Subprogram_Declaration)
+ if Nkind (Spec_Decl) in N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
then
return Spec_Decl;
end if;
@@ -7050,9 +7362,8 @@ package body Sem_Util is
elsif Dynamic_Scope = Empty then
return Empty;
- elsif Ekind_In (Dynamic_Scope, E_Generic_Package,
- E_Package,
- E_Package_Body)
+ elsif Ekind (Dynamic_Scope) in
+ E_Generic_Package | E_Package | E_Package_Body
then
return Dynamic_Scope;
@@ -7101,10 +7412,10 @@ package body Sem_Util is
elsif Ekind (Dyn_Scop) = E_Subprogram_Body then
return Corresponding_Spec (Parent (Parent (Dyn_Scop)));
- elsif Ekind_In (Dyn_Scop, E_Block, E_Loop, E_Return_Statement) then
+ elsif Ekind (Dyn_Scop) in E_Block | E_Loop | E_Return_Statement then
return Enclosing_Subprogram (Dyn_Scop);
- elsif Ekind_In (Dyn_Scop, E_Entry, E_Entry_Family) then
+ elsif Ekind (Dyn_Scop) in E_Entry | E_Entry_Family then
-- For a task entry or entry family, return the enclosing subprogram
-- of the task itself.
@@ -7126,17 +7437,16 @@ package body Sem_Util is
-- The scope may appear as a private type or as a private extension
-- whose completion is a task or protected type.
- elsif Ekind_In (Dyn_Scop, E_Limited_Private_Type,
- E_Record_Type_With_Private)
+ elsif Ekind (Dyn_Scop) in
+ E_Limited_Private_Type | E_Record_Type_With_Private
and then Present (Full_View (Dyn_Scop))
- and then Ekind_In (Full_View (Dyn_Scop), E_Task_Type, E_Protected_Type)
+ and then Ekind (Full_View (Dyn_Scop)) in E_Task_Type | E_Protected_Type
then
return Get_Task_Body_Procedure (Full_View (Dyn_Scop));
-- No body is generated if the protected operation is eliminated
- elsif Convention (Dyn_Scop) = Convention_Protected
- and then not Is_Eliminated (Dyn_Scop)
+ elsif not Is_Eliminated (Dyn_Scop)
and then Present (Protected_Body_Subprogram (Dyn_Scop))
then
return Protected_Body_Subprogram (Dyn_Scop);
@@ -7188,11 +7498,11 @@ package body Sem_Util is
-- Start of processing for End_Keyword_Location
begin
- if Nkind_In (N, N_Block_Statement,
- N_Entry_Body,
- N_Package_Body,
- N_Subprogram_Body,
- N_Task_Body)
+ if Nkind (N) in N_Block_Statement
+ | N_Entry_Body
+ | N_Package_Body
+ | N_Subprogram_Body
+ | N_Task_Body
then
Owner := Handled_Statement_Sequence (N);
@@ -7202,13 +7512,12 @@ package body Sem_Util is
elsif Nkind (N) = N_Protected_Body then
Owner := N;
- elsif Nkind_In (N, N_Protected_Type_Declaration,
- N_Single_Protected_Declaration)
+ elsif Nkind (N) in N_Protected_Type_Declaration
+ | N_Single_Protected_Declaration
then
Owner := Protected_Definition (N);
- elsif Nkind_In (N, N_Single_Task_Declaration,
- N_Task_Type_Declaration)
+ elsif Nkind (N) in N_Single_Task_Declaration | N_Task_Type_Declaration
then
Owner := Task_Definition (N);
@@ -7464,7 +7773,7 @@ package body Sem_Util is
-- Avoid cascaded messages with duplicate components in
-- derived types.
- if Ekind_In (E, E_Component, E_Discriminant) then
+ if Ekind (E) in E_Component | E_Discriminant then
return;
end if;
end if;
@@ -7499,7 +7808,7 @@ package body Sem_Util is
-- of inheriting components in a derived record definition. Preserve
-- their Ekind and Etype.
- if Ekind_In (Def_Id, E_Discriminant, E_Component) then
+ if Ekind (Def_Id) in E_Discriminant | E_Component then
null;
-- If a type is already set, leave it alone (happens when a type
@@ -7522,7 +7831,7 @@ package body Sem_Util is
-- Unless the Itype is for a record type with a corresponding remote
-- type (what is that about, it was not commented ???)
- if Ekind_In (Def_Id, E_Discriminant, E_Component)
+ if Ekind (Def_Id) in E_Discriminant | E_Component
or else
((not Is_Record_Type (Def_Id)
or else No (Corresponding_Remote_Type (Def_Id)))
@@ -7536,52 +7845,6 @@ package body Sem_Util is
Append_Entity (Def_Id, S);
Set_Public_Status (Def_Id);
- -- Declaring a homonym is not allowed in SPARK ...
-
- if Present (C) and then Restriction_Check_Required (SPARK_05) then
- declare
- Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
- Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
- Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C);
-
- begin
- -- ... unless the new declaration is in a subprogram, and the
- -- visible declaration is a variable declaration or a parameter
- -- specification outside that subprogram.
-
- if Present (Enclosing_Subp)
- and then Nkind_In (Parent (C), N_Object_Declaration,
- N_Parameter_Specification)
- and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
- then
- null;
-
- -- ... or the new declaration is in a package, and the visible
- -- declaration occurs outside that package.
-
- elsif Present (Enclosing_Pack)
- and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
- then
- null;
-
- -- ... or the new declaration is a component declaration in a
- -- record type definition.
-
- elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
- null;
-
- -- Don't issue error for non-source entities
-
- elsif Comes_From_Source (Def_Id)
- and then Comes_From_Source (C)
- then
- Error_Msg_Sloc := Sloc (C);
- Check_SPARK_05_Restriction
- ("redeclaration of identifier &#", Def_Id);
- end if;
- end;
- end if;
-
-- Warn if new entity hides an old one
if Warn_On_Hiding and then Present (C)
@@ -7920,8 +8183,7 @@ package body Sem_Util is
elsif Comes_From_Source (Decl)
or else
- (Nkind_In (Decl, N_Subprogram_Body,
- N_Subprogram_Declaration)
+ (Nkind (Decl) in N_Subprogram_Body | N_Subprogram_Declaration
and then Is_Expression_Function (Defining_Entity (Decl)))
then
exit;
@@ -7993,7 +8255,7 @@ package body Sem_Util is
Call_Nam : Node_Id;
begin
- if Nkind_In (Context, N_Indexed_Component, N_Selected_Component)
+ if Nkind (Context) in N_Indexed_Component | N_Selected_Component
and then N = Prefix (Context)
then
Find_Actual (Context, Formal, Call);
@@ -8004,9 +8266,9 @@ package body Sem_Util is
then
Call := Parent (Context);
- elsif Nkind_In (Context, N_Entry_Call_Statement,
- N_Function_Call,
- N_Procedure_Call_Statement)
+ elsif Nkind (Context) in N_Entry_Call_Statement
+ | N_Function_Call
+ | N_Procedure_Call_Statement
then
Call := Context;
@@ -8020,9 +8282,9 @@ package body Sem_Util is
-- we exclude overloaded calls, since we don't know enough to be sure
-- of giving the right answer in this case.
- if Nkind_In (Call, N_Entry_Call_Statement,
- N_Function_Call,
- N_Procedure_Call_Statement)
+ if Nkind (Call) in N_Entry_Call_Statement
+ | N_Function_Call
+ | N_Procedure_Call_Statement
then
Call_Nam := Name (Call);
@@ -8066,8 +8328,8 @@ package body Sem_Util is
return;
else
- Actual := Next_Actual (Actual);
- Formal := Next_Formal (Formal);
+ Next_Actual (Actual);
+ Next_Formal (Formal);
end if;
end loop;
end if;
@@ -8422,7 +8684,7 @@ package body Sem_Util is
Expr := Prefix (Expr);
exit;
- -- Check for Const where Const is a constant entity
+ -- Check for Const where Const is a constant entity
elsif Is_Entity_Name (Expr)
and then Ekind (Entity (Expr)) = E_Constant
@@ -8448,8 +8710,7 @@ package body Sem_Util is
-- Check for components
- elsif
- Nkind_In (Expr, N_Selected_Component, N_Indexed_Component)
+ elsif Nkind (Expr) in N_Selected_Component | N_Indexed_Component
then
Expr := Prefix (Expr);
Off := True;
@@ -8800,7 +9061,7 @@ package body Sem_Util is
-- Single global item declaration (only input items)
- elsif Nkind_In (List, N_Expanded_Name, N_Identifier) then
+ elsif Nkind (List) in N_Expanded_Name | N_Identifier then
if Global_Mode = Name_Input then
return List;
else
@@ -8854,10 +9115,10 @@ package body Sem_Util is
-- Start of processing for First_Global
begin
- pragma Assert (Nam_In (Global_Mode, Name_In_Out,
- Name_Input,
- Name_Output,
- Name_Proof_In));
+ pragma Assert (Global_Mode in Name_In_Out
+ | Name_Input
+ | Name_Output
+ | Name_Proof_In);
-- Retrieve the suitable pragma Global or Refined_Global. In the second
-- case, it can only be located on the body entity.
@@ -8906,7 +9167,7 @@ package body Sem_Util is
function Fix_Msg (Id : Entity_Id; Msg : String) return String is
Is_Task : constant Boolean :=
- Ekind_In (Id, E_Task_Body, E_Task_Type)
+ Ekind (Id) in E_Task_Body | E_Task_Type
or else Is_Single_Task_Object (Id);
Msg_Last : constant Natural := Msg'Last;
Msg_Index : Natural;
@@ -8926,7 +9187,7 @@ package body Sem_Util is
if Msg_Index <= Msg_Last - 10
and then Msg (Msg_Index .. Msg_Index + 9) = "subprogram"
then
- if Ekind_In (Id, E_Entry, E_Entry_Family) then
+ if Is_Entry (Id) then
Res (Res_Index .. Res_Index + 4) := "entry";
Res_Index := Res_Index + 5;
@@ -9946,6 +10207,16 @@ package body Sem_Util is
(Typ : Entity_Id;
Nam : Name_Id) return Entity_Id
is
+ pragma Assert
+ (Is_Type (Typ)
+ and then
+ Nam in Name_Element
+ | Name_First
+ | Name_Has_Element
+ | Name_Last
+ | Name_Next
+ | Name_Previous);
+
Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable);
Assoc : Node_Id;
@@ -9960,7 +10231,7 @@ package body Sem_Util is
return Entity (Expression (Assoc));
end if;
- Assoc := Next (Assoc);
+ Next (Assoc);
end loop;
return Empty;
@@ -10181,6 +10452,7 @@ package body Sem_Util is
begin
R := N;
while Is_Entity_Name (R)
+ and then Is_Object (Entity (R))
and then Present (Renamed_Object (Entity (R)))
loop
R := Renamed_Object (Entity (R));
@@ -10246,14 +10518,14 @@ package body Sem_Util is
-- Strip the subprogram call
loop
- if Nkind_In (Subp, N_Explicit_Dereference,
- N_Indexed_Component,
- N_Selected_Component)
+ if Nkind (Subp) in N_Explicit_Dereference
+ | N_Indexed_Component
+ | N_Selected_Component
then
Subp := Prefix (Subp);
- elsif Nkind_In (Subp, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ elsif Nkind (Subp) in N_Type_Conversion
+ | N_Unchecked_Type_Conversion
then
Subp := Expression (Subp);
@@ -10337,7 +10609,7 @@ package body Sem_Util is
(Typ : Entity_Id;
Priv_Typ : out Entity_Id;
Full_Typ : out Entity_Id;
- Full_Base : out Entity_Id;
+ UFull_Typ : out Entity_Id;
CRec_Typ : out Entity_Id)
is
IP_View : Entity_Id;
@@ -10347,7 +10619,7 @@ package body Sem_Util is
Priv_Typ := Empty;
Full_Typ := Empty;
- Full_Base := Empty;
+ UFull_Typ := Empty;
CRec_Typ := Empty;
-- The input type is the corresponding record type of a protected or a
@@ -10356,10 +10628,9 @@ package body Sem_Util is
if Ekind (Typ) = E_Record_Type
and then Is_Concurrent_Record_Type (Typ)
then
- CRec_Typ := Typ;
- Full_Typ := Corresponding_Concurrent_Type (CRec_Typ);
- Full_Base := Base_Type (Full_Typ);
- Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
+ CRec_Typ := Typ;
+ Full_Typ := Corresponding_Concurrent_Type (CRec_Typ);
+ Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
-- Otherwise the input type denotes an arbitrary type
@@ -10384,10 +10655,19 @@ package body Sem_Util is
Full_Typ := Typ;
end if;
- if Present (Full_Typ) then
- Full_Base := Base_Type (Full_Typ);
+ if Present (Full_Typ) and then Is_Private_Type (Full_Typ) then
+ UFull_Typ := Underlying_Full_View (Full_Typ);
+
+ if Present (UFull_Typ)
+ and then Ekind (UFull_Typ) in E_Protected_Type | E_Task_Type
+ then
+ CRec_Typ := Corresponding_Record_Type (UFull_Typ);
+ end if;
- if Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) then
+ else
+ if Present (Full_Typ)
+ and then Ekind (Full_Typ) in E_Protected_Type | E_Task_Type
+ then
CRec_Typ := Corresponding_Record_Type (Full_Typ);
end if;
end if;
@@ -10781,15 +11061,15 @@ package body Sem_Util is
function Has_Declarations (N : Node_Id) return Boolean is
begin
- return Nkind_In (Nkind (N), N_Accept_Statement,
- N_Block_Statement,
- N_Compilation_Unit_Aux,
- N_Entry_Body,
- N_Package_Body,
- N_Protected_Body,
- N_Subprogram_Body,
- N_Task_Body,
- N_Package_Specification);
+ return Nkind (N) in N_Accept_Statement
+ | N_Block_Statement
+ | N_Compilation_Unit_Aux
+ | N_Entry_Body
+ | N_Package_Body
+ | N_Protected_Body
+ | N_Subprogram_Body
+ | N_Task_Body
+ | N_Package_Specification;
end Has_Declarations;
---------------------------------
@@ -10891,7 +11171,7 @@ package body Sem_Util is
-- Inspect the return type of functions
- if Ekind_In (Subp_Id, E_Function, E_Generic_Function)
+ if Ekind (Subp_Id) in E_Function | E_Generic_Function
and then Is_Effectively_Volatile (Etype (Subp_Id))
then
return True;
@@ -10908,28 +11188,26 @@ package body Sem_Util is
(Item_Id : Entity_Id;
Property : Name_Id) return Boolean
is
- function Protected_Object_Has_Enabled_Property return Boolean;
- -- Determine whether a protected object denoted by Item_Id has the
- -- property enabled.
+ function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean;
+ -- Determine whether a protected type or variable denoted by Item_Id
+ -- has the property enabled.
function State_Has_Enabled_Property return Boolean;
-- Determine whether a state denoted by Item_Id has the property enabled
- function Variable_Has_Enabled_Property return Boolean;
- -- Determine whether a variable denoted by Item_Id has the property
- -- enabled.
-
- -------------------------------------------
- -- Protected_Object_Has_Enabled_Property --
- -------------------------------------------
+ function Type_Or_Variable_Has_Enabled_Property
+ (Item_Id : Entity_Id) return Boolean;
+ -- Determine whether type or variable denoted by Item_Id has the
+ -- property enabled.
- function Protected_Object_Has_Enabled_Property return Boolean is
- Constits : constant Elist_Id := Part_Of_Constituents (Item_Id);
- Constit_Elmt : Elmt_Id;
- Constit_Id : Entity_Id;
+ -----------------------------------------------------
+ -- Protected_Type_Or_Variable_Has_Enabled_Property --
+ -----------------------------------------------------
+ function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean
+ is
begin
- -- Protected objects always have the properties Async_Readers and
+ -- Protected entities always have the properties Async_Readers and
-- Async_Writers (SPARK RM 7.1.2(16)).
if Property = Name_Async_Readers
@@ -10941,21 +11219,30 @@ package body Sem_Util is
-- properties Effective_Reads and Effective_Writes
-- (SPARK RM 7.1.2(16)).
- elsif Present (Constits) then
- Constit_Elmt := First_Elmt (Constits);
- while Present (Constit_Elmt) loop
- Constit_Id := Node (Constit_Elmt);
+ elsif Is_Single_Protected_Object (Item_Id) then
+ declare
+ Constit_Elmt : Elmt_Id;
+ Constit_Id : Entity_Id;
+ Constits : constant Elist_Id
+ := Part_Of_Constituents (Item_Id);
+ begin
+ if Present (Constits) then
+ Constit_Elmt := First_Elmt (Constits);
+ while Present (Constit_Elmt) loop
+ Constit_Id := Node (Constit_Elmt);
- if Has_Enabled_Property (Constit_Id, Property) then
- return True;
- end if;
+ if Has_Enabled_Property (Constit_Id, Property) then
+ return True;
+ end if;
- Next_Elmt (Constit_Elmt);
- end loop;
+ Next_Elmt (Constit_Elmt);
+ end loop;
+ end if;
+ end;
end if;
return False;
- end Protected_Object_Has_Enabled_Property;
+ end Protected_Type_Or_Variable_Has_Enabled_Property;
--------------------------------
-- State_Has_Enabled_Property --
@@ -11111,17 +11398,19 @@ package body Sem_Util is
-- Synchronous (SPARK RM 7.1.4(9)).
elsif Has_Synchronous then
- return Nam_In (Property, Name_Async_Readers, Name_Async_Writers);
+ return Property in Name_Async_Readers | Name_Async_Writers;
end if;
return False;
end State_Has_Enabled_Property;
- -----------------------------------
- -- Variable_Has_Enabled_Property --
- -----------------------------------
+ -------------------------------------------
+ -- Type_Or_Variable_Has_Enabled_Property --
+ -------------------------------------------
- function Variable_Has_Enabled_Property return Boolean is
+ function Type_Or_Variable_Has_Enabled_Property
+ (Item_Id : Entity_Id) return Boolean
+ is
function Is_Enabled (Prag : Node_Id) return Boolean;
-- Determine whether property pragma Prag (if present) denotes an
-- enabled property.
@@ -11169,7 +11458,11 @@ package body Sem_Util is
EW : constant Node_Id :=
Get_Pragma (Item_Id, Pragma_Effective_Writes);
- -- Start of processing for Variable_Has_Enabled_Property
+ Is_Derived_Type_With_Volatile_Parent_Type : constant Boolean :=
+ Is_Derived_Type (Item_Id)
+ and then Is_Effectively_Volatile (Etype (Base_Type (Item_Id)));
+
+ -- Start of processing for Type_Or_Variable_Has_Enabled_Property
begin
-- A non-effectively volatile object can never possess external
@@ -11184,23 +11477,57 @@ package body Sem_Util is
-- property is enabled when the flag evaluates to True or the flag is
-- missing altogether.
- elsif Property = Name_Async_Readers and then Is_Enabled (AR) then
- return True;
+ elsif Property = Name_Async_Readers and then Present (AR) then
+ return Is_Enabled (AR);
- elsif Property = Name_Async_Writers and then Is_Enabled (AW) then
- return True;
+ elsif Property = Name_Async_Writers and then Present (AW) then
+ return Is_Enabled (AW);
- elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then
- return True;
+ elsif Property = Name_Effective_Reads and then Present (ER) then
+ return Is_Enabled (ER);
- elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then
- return True;
+ elsif Property = Name_Effective_Writes and then Present (EW) then
+ return Is_Enabled (EW);
+
+ -- If other properties are set explicitly, then this one is set
+ -- implicitly to False, except in the case of a derived type
+ -- whose parent type is volatile (in that case, we will inherit
+ -- from the parent type, below).
+
+ elsif (Present (AR)
+ or else Present (AW)
+ or else Present (ER)
+ or else Present (EW))
+ and then not Is_Derived_Type_With_Volatile_Parent_Type
+ then
+ return False;
+
+ -- For a private type, may need to look at the full view
+
+ elsif Is_Private_Type (Item_Id) and then Present (Full_View (Item_Id))
+ then
+ return Type_Or_Variable_Has_Enabled_Property (Full_View (Item_Id));
+
+ -- For a derived type whose parent type is volatile, the
+ -- property may be inherited (but ignore a non-volatile parent).
+
+ elsif Is_Derived_Type_With_Volatile_Parent_Type then
+ return Type_Or_Variable_Has_Enabled_Property
+ (First_Subtype (Etype (Base_Type (Item_Id))));
+
+ -- If not specified explicitly for an object and the type
+ -- is effectively volatile, then take result from the type.
+
+ elsif not Is_Type (Item_Id)
+ and then Is_Effectively_Volatile (Etype (Item_Id))
+ then
+ return Has_Enabled_Property (Etype (Item_Id), Property);
-- The implicit case lacks all property pragmas
elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
if Is_Protected_Type (Etype (Item_Id)) then
- return Protected_Object_Has_Enabled_Property;
+ return Protected_Type_Or_Variable_Has_Enabled_Property;
else
return True;
end if;
@@ -11208,7 +11535,7 @@ package body Sem_Util is
else
return False;
end if;
- end Variable_Has_Enabled_Property;
+ end Type_Or_Variable_Has_Enabled_Property;
-- Start of processing for Has_Enabled_Property
@@ -11220,15 +11547,19 @@ package body Sem_Util is
return State_Has_Enabled_Property;
elsif Ekind (Item_Id) = E_Variable then
- return Variable_Has_Enabled_Property;
+ return Type_Or_Variable_Has_Enabled_Property (Item_Id);
- -- By default, protected objects only have the properties Async_Readers
- -- and Async_Writers. If they have Part_Of components, they also inherit
- -- their properties Effective_Reads and Effective_Writes
- -- (SPARK RM 7.1.2(16)).
+ -- Other objects can only inherit properties through their type. We
+ -- cannot call directly Type_Or_Variable_Has_Enabled_Property on
+ -- these as they don't have contracts attached, which is expected by
+ -- this function.
- elsif Ekind (Item_Id) = E_Protected_Object then
- return Protected_Object_Has_Enabled_Property;
+ elsif Is_Object (Item_Id) then
+ return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id));
+
+ elsif Is_Type (Item_Id) then
+ return Type_Or_Variable_Has_Enabled_Property
+ (Item_Id => First_Subtype (Item_Id));
-- Otherwise a property is enabled when the related item is effectively
-- volatile.
@@ -11286,17 +11617,16 @@ package body Sem_Util is
-- Inspect all entities defined in the scope of the type, looking for
-- uninitialized components.
- Comp := First_Entity (Typ);
+ Comp := First_Component (Typ);
while Present (Comp) loop
- if Ekind (Comp) = E_Component
- and then Comes_From_Source (Comp)
+ if Comes_From_Source (Comp)
and then No (Expression (Parent (Comp)))
and then not Has_Full_Default_Initialization (Etype (Comp))
then
return False;
end if;
- Next_Entity (Comp);
+ Next_Component (Comp);
end loop;
-- Ensure that the parent type of a type extension is fully default
@@ -11490,12 +11820,10 @@ package body Sem_Util is
elsif Nkind (N) in N_Has_Entity then
return Present (Entity (N))
- and then Ekind_In (Entity (N), E_Variable,
- E_Constant,
- E_Enumeration_Literal,
- E_In_Parameter,
- E_Out_Parameter,
- E_In_Out_Parameter)
+ and then
+ Ekind (Entity (N)) in
+ E_Variable | E_Constant | E_Enumeration_Literal |
+ E_In_Parameter | E_Out_Parameter | E_In_Out_Parameter
and then not Is_Volatile (Entity (N));
else
@@ -11534,7 +11862,7 @@ package body Sem_Util is
Node := First (L);
loop
- if Nkind (Node) /= N_Null_Statement then
+ if Nkind (Node) not in N_Null_Statement | N_Call_Marker then
return True;
end if;
@@ -11547,6 +11875,104 @@ package body Sem_Util is
end Has_Non_Null_Statements;
----------------------------------
+ -- Is_Access_Subprogram_Wrapper --
+ ----------------------------------
+
+ function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean is
+ Formal : constant Entity_Id := Last_Formal (E);
+ begin
+ return Present (Formal)
+ and then Ekind (Etype (Formal)) in Access_Subprogram_Kind
+ and then Access_Subprogram_Wrapper
+ (Directly_Designated_Type (Etype (Formal))) = E;
+ end Is_Access_Subprogram_Wrapper;
+
+ ---------------------------------
+ -- Side_Effect_Free_Statements --
+ ---------------------------------
+
+ function Side_Effect_Free_Statements (L : List_Id) return Boolean is
+ Node : Node_Id;
+
+ begin
+ if Is_Non_Empty_List (L) then
+ Node := First (L);
+
+ loop
+ case Nkind (Node) is
+ when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error =>
+ null;
+ when N_Object_Declaration =>
+ if Present (Expression (Node))
+ and then not Side_Effect_Free (Expression (Node))
+ then
+ return False;
+ end if;
+
+ when others =>
+ return False;
+ end case;
+
+ Next (Node);
+ exit when Node = Empty;
+ end loop;
+ end if;
+
+ return True;
+ end Side_Effect_Free_Statements;
+
+ ---------------------------
+ -- Side_Effect_Free_Loop --
+ ---------------------------
+
+ function Side_Effect_Free_Loop (N : Node_Id) return Boolean is
+ Scheme : Node_Id;
+ Spec : Node_Id;
+ Subt : Node_Id;
+
+ begin
+ -- If this is not a loop (e.g. because the loop has been rewritten),
+ -- then return false.
+
+ if Nkind (N) /= N_Loop_Statement then
+ return False;
+ end if;
+
+ -- First check the statements
+
+ if Side_Effect_Free_Statements (Statements (N)) then
+
+ -- Then check the loop condition/indexes
+
+ if Present (Iteration_Scheme (N)) then
+ Scheme := Iteration_Scheme (N);
+
+ if Present (Condition (Scheme))
+ or else Present (Iterator_Specification (Scheme))
+ then
+ return False;
+ elsif Present (Loop_Parameter_Specification (Scheme)) then
+ Spec := Loop_Parameter_Specification (Scheme);
+ Subt := Discrete_Subtype_Definition (Spec);
+
+ if Present (Subt) then
+ if Nkind (Subt) = N_Range then
+ return Side_Effect_Free (Low_Bound (Subt))
+ and then Side_Effect_Free (High_Bound (Subt));
+ else
+ -- subtype indication
+
+ return True;
+ end if;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ return False;
+ end Side_Effect_Free_Loop;
+
+ ----------------------------------
-- Has_Non_Trivial_Precondition --
----------------------------------
@@ -11639,7 +12065,6 @@ package body Sem_Util is
when N_Component_Definition
| N_Formal_Object_Declaration
- | N_Object_Renaming_Declaration
=>
if Present (Subtype_Mark (N)) then
return Null_Exclusion_Present (N);
@@ -11647,6 +12072,15 @@ package body Sem_Util is
return Null_Exclusion_Present (Access_Definition (N));
end if;
+ when N_Object_Renaming_Declaration =>
+ if Present (Subtype_Mark (N)) then
+ return Null_Exclusion_Present (N);
+ elsif Present (Access_Definition (N)) then
+ return Null_Exclusion_Present (Access_Definition (N));
+ else
+ return False; -- Case of no subtype in renaming (AI12-0275)
+ end if;
+
when N_Discriminant_Specification =>
if Nkind (Discriminant_Type (N)) = N_Access_Definition then
return Null_Exclusion_Present (Discriminant_Type (N));
@@ -11663,7 +12097,8 @@ package body Sem_Util is
when N_Parameter_Specification =>
if Nkind (Parameter_Type (N)) = N_Access_Definition then
- return Null_Exclusion_Present (Parameter_Type (N));
+ return Null_Exclusion_Present (Parameter_Type (N))
+ or else Null_Exclusion_Present (N);
else
return Null_Exclusion_Present (N);
end if;
@@ -11975,14 +12410,10 @@ package body Sem_Util is
function Has_Prefix (N : Node_Id) return Boolean is
begin
- return
- Nkind_In (N, N_Attribute_Reference,
- N_Expanded_Name,
- N_Explicit_Dereference,
- N_Indexed_Component,
- N_Reference,
- N_Selected_Component,
- N_Slice);
+ return Nkind (N) in
+ N_Attribute_Reference | N_Expanded_Name | N_Explicit_Dereference |
+ N_Indexed_Component | N_Reference | N_Selected_Component |
+ N_Slice;
end Has_Prefix;
---------------------------
@@ -12046,6 +12477,147 @@ package body Sem_Util is
end if;
end Has_Private_Component;
+ --------------------------------
+ -- Has_Relaxed_Initialization --
+ --------------------------------
+
+ function Has_Relaxed_Initialization (E : Entity_Id) return Boolean is
+
+ function Denotes_Relaxed_Parameter
+ (Expr : Node_Id;
+ Param : Entity_Id)
+ return Boolean;
+ -- Returns True iff expression Expr denotes a formal parameter or
+ -- function Param (through its attribute Result).
+
+ -------------------------------
+ -- Denotes_Relaxed_Parameter --
+ -------------------------------
+
+ function Denotes_Relaxed_Parameter
+ (Expr : Node_Id;
+ Param : Entity_Id) return Boolean is
+ begin
+ if Nkind (Expr) in N_Identifier | N_Expanded_Name then
+ return Entity (Expr) = Param;
+ else
+ pragma Assert (Is_Attribute_Result (Expr));
+ return Entity (Prefix (Expr)) = Param;
+ end if;
+ end Denotes_Relaxed_Parameter;
+
+ -- Start of processing for Has_Relaxed_Initialization
+
+ begin
+ -- When analyzing, we checked all syntax legality rules for the aspect
+ -- Relaxed_Initialization, but didn't store the property anywhere (e.g.
+ -- as an Einfo flag). To query the property we look directly at the AST,
+ -- but now without any syntactic checks.
+
+ case Ekind (E) is
+ -- Abstract states have option Relaxed_Initialization
+
+ when E_Abstract_State =>
+ return Is_Relaxed_Initialization_State (E);
+
+ -- Constants have this aspect attached directly; for deferred
+ -- constants, the aspect is attached to the partial view.
+
+ when E_Constant =>
+ return Has_Aspect (E, Aspect_Relaxed_Initialization);
+
+ -- Variables have this aspect attached directly
+
+ when E_Variable =>
+ return Has_Aspect (E, Aspect_Relaxed_Initialization);
+
+ -- Types have this aspect attached directly (though we only allow it
+ -- to be specified for the first subtype). For private types, the
+ -- aspect is attached to the partial view.
+
+ when Type_Kind =>
+ pragma Assert (Is_First_Subtype (E));
+ return Has_Aspect (E, Aspect_Relaxed_Initialization);
+
+ -- Formal parameters and functions have the Relaxed_Initialization
+ -- aspect attached to the subprogram entity and must be listed in
+ -- the aspect expression.
+
+ when Formal_Kind
+ | E_Function
+ =>
+ declare
+ Subp_Id : Entity_Id;
+ Aspect_Expr : Node_Id;
+ Param_Expr : Node_Id;
+ Assoc : Node_Id;
+
+ begin
+ if Is_Formal (E) then
+ Subp_Id := Scope (E);
+ else
+ Subp_Id := E;
+ end if;
+
+ if Has_Aspect (Subp_Id, Aspect_Relaxed_Initialization) then
+ Aspect_Expr :=
+ Find_Value_Of_Aspect
+ (Subp_Id, Aspect_Relaxed_Initialization);
+
+ -- Aspect expression is either an aggregate with an optional
+ -- Boolean expression (which defaults to True), e.g.:
+ --
+ -- function F (X : Integer) return Integer
+ -- with Relaxed_Initialization => (X => True, F'Result);
+
+ if Nkind (Aspect_Expr) = N_Aggregate then
+
+ if Present (Component_Associations (Aspect_Expr)) then
+ Assoc := First (Component_Associations (Aspect_Expr));
+
+ while Present (Assoc) loop
+ if Denotes_Relaxed_Parameter
+ (First (Choices (Assoc)), E)
+ then
+ return
+ Is_True
+ (Static_Boolean (Expression (Assoc)));
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end if;
+
+ Param_Expr := First (Expressions (Aspect_Expr));
+
+ while Present (Param_Expr) loop
+ if Denotes_Relaxed_Parameter (Param_Expr, E) then
+ return True;
+ end if;
+
+ Next (Param_Expr);
+ end loop;
+
+ return False;
+
+ -- or it is a single identifier, e.g.:
+ --
+ -- function F (X : Integer) return Integer
+ -- with Relaxed_Initialization => X;
+
+ else
+ return Denotes_Relaxed_Parameter (Aspect_Expr, E);
+ end if;
+ else
+ return False;
+ end if;
+ end;
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end Has_Relaxed_Initialization;
+
----------------------
-- Has_Signed_Zeros --
----------------------
@@ -12217,13 +12789,9 @@ package body Sem_Util is
begin
pragma Assert (Relaxed_RM_Semantics);
- pragma Assert (Nkind_In (N, N_Null,
- N_Op_Eq,
- N_Op_Ge,
- N_Op_Gt,
- N_Op_Le,
- N_Op_Lt,
- N_Op_Ne));
+ pragma Assert
+ (Nkind (N) in
+ N_Null | N_Op_Eq | N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt | N_Op_Ne);
if Nkind (N) = N_Null then
Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
@@ -12274,6 +12842,32 @@ package body Sem_Util is
end if;
end Has_Tagged_Component;
+ --------------------------------------------
+ -- Has_Unconstrained_Access_Discriminants --
+ --------------------------------------------
+
+ function Has_Unconstrained_Access_Discriminants
+ (Subtyp : Entity_Id) return Boolean
+ is
+ Discr : Entity_Id;
+
+ begin
+ if Has_Discriminants (Subtyp)
+ and then not Is_Constrained (Subtyp)
+ then
+ Discr := First_Discriminant (Subtyp);
+ while Present (Discr) loop
+ if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
+ return True;
+ end if;
+
+ Next_Discriminant (Discr);
+ end loop;
+ end if;
+
+ return False;
+ end Has_Unconstrained_Access_Discriminants;
+
-----------------------------
-- Has_Undefined_Reference --
-----------------------------
@@ -12336,7 +12930,7 @@ package body Sem_Util is
return True;
end if;
- Comp := Next_Component (Comp);
+ Next_Component (Comp);
end loop;
end if;
@@ -12402,6 +12996,32 @@ package body Sem_Util is
return False;
end Implements_Interface;
+ --------------------------------
+ -- Implicitly_Designated_Type --
+ --------------------------------
+
+ function Implicitly_Designated_Type (Typ : Entity_Id) return Entity_Id is
+ Desig : constant Entity_Id := Designated_Type (Typ);
+
+ begin
+ -- An implicit dereference is a legal occurrence of an incomplete type
+ -- imported through a limited_with clause, if the full view is visible.
+
+ if Is_Incomplete_Type (Desig)
+ and then From_Limited_With (Desig)
+ and then not From_Limited_With (Scope (Desig))
+ and then
+ (Is_Immediately_Visible (Scope (Desig))
+ or else
+ (Is_Child_Unit (Scope (Desig))
+ and then Is_Visible_Lib_Unit (Scope (Desig))))
+ then
+ return Available_View (Desig);
+ else
+ return Desig;
+ end if;
+ end Implicitly_Designated_Type;
+
------------------------------------
-- In_Assertion_Expression_Pragma --
------------------------------------
@@ -12519,7 +13139,7 @@ package body Sem_Util is
begin
S := Current_Scope;
while Present (S) and then S /= Standard_Standard loop
- if Ekind_In (S, E_Function, E_Procedure)
+ if Ekind (S) in E_Function | E_Procedure
and then Is_Generic_Instance (S)
then
return True;
@@ -12547,7 +13167,7 @@ package body Sem_Util is
begin
S := Current_Scope;
while Present (S) and then S /= Standard_Standard loop
- if Ekind_In (S, E_Function, E_Procedure)
+ if Ekind (S) in E_Function | E_Procedure
and then Is_Generic_Instance (S)
then
return True;
@@ -12751,15 +13371,15 @@ package body Sem_Util is
if Nod = Cont then
return True;
- elsif Nkind_In (Nod, N_Accept_Statement,
- N_Block_Statement,
- N_Compilation_Unit,
- N_Entry_Body,
- N_Package_Body,
- N_Package_Declaration,
- N_Protected_Body,
- N_Subprogram_Body,
- N_Task_Body)
+ elsif Nkind (Nod) in N_Accept_Statement
+ | N_Block_Statement
+ | N_Compilation_Unit
+ | N_Entry_Body
+ | N_Package_Body
+ | N_Package_Declaration
+ | N_Protected_Body
+ | N_Subprogram_Body
+ | N_Task_Body
then
return False;
@@ -12924,9 +13544,9 @@ package body Sem_Util is
-- declaration hold the partial view and the full view is an
-- itype.
- elsif Nkind_In (Decl, N_Full_Type_Declaration,
- N_Private_Extension_Declaration,
- N_Private_Type_Declaration)
+ elsif Nkind (Decl) in N_Full_Type_Declaration
+ | N_Private_Extension_Declaration
+ | N_Private_Type_Declaration
then
Match := Defining_Identifier (Decl);
end if;
@@ -12974,7 +13594,7 @@ package body Sem_Util is
begin
if Present (Pkg)
- and then Ekind_In (Pkg, E_Generic_Package, E_Package)
+ and then Is_Package_Or_Generic_Package (Pkg)
then
while Nkind (Pkg_Decl) /= N_Package_Specification loop
Pkg_Decl := Parent (Pkg_Decl);
@@ -13032,13 +13652,13 @@ package body Sem_Util is
Ent : Entity_Id := First_Entity (Limited_View (Scope (Typ)));
begin
while Present (Ent) loop
- if Ekind (Ent) in Incomplete_Kind
+ if Is_Incomplete_Type (Ent)
and then Non_Limited_View (Ent) = Typ
then
return Ent;
end if;
- Ent := Next_Entity (Ent);
+ Next_Entity (Ent);
end loop;
end;
end if;
@@ -13099,6 +13719,38 @@ package body Sem_Util is
return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind))));
end Indexed_Component_Bit_Offset;
+ -----------------------------
+ -- Inherit_Predicate_Flags --
+ -----------------------------
+
+ procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is
+ begin
+ if Present (Predicate_Function (Subt)) then
+ return;
+ end if;
+
+ Set_Has_Predicates (Subt, Has_Predicates (Par));
+ Set_Has_Static_Predicate_Aspect
+ (Subt, Has_Static_Predicate_Aspect (Par));
+ Set_Has_Dynamic_Predicate_Aspect
+ (Subt, Has_Dynamic_Predicate_Aspect (Par));
+
+ -- A named subtype does not inherit the predicate function of its
+ -- parent but an itype declared for a loop index needs the discrete
+ -- predicate information of its parent to execute the loop properly.
+ -- A non-discrete type may has a static predicate (for example True)
+ -- but has no static_discrete_predicate.
+
+ if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then
+ Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par));
+
+ if Has_Static_Predicate (Par) and then Is_Discrete_Type (Par) then
+ Set_Static_Discrete_Predicate
+ (Subt, Static_Discrete_Predicate (Par));
+ end if;
+ end if;
+ end Inherit_Predicate_Flags;
+
----------------------------
-- Inherit_Rep_Item_Chain --
----------------------------
@@ -13265,7 +13917,7 @@ package body Sem_Util is
procedure Insert_Explicit_Dereference (N : Node_Id) is
New_Prefix : constant Node_Id := Relocate_Node (N);
Ent : Entity_Id := Empty;
- Pref : Node_Id;
+ Pref : Node_Id := Empty;
I : Interp_Index;
It : Interp;
T : Entity_Id;
@@ -13311,13 +13963,12 @@ package body Sem_Util is
-- For a retrieval of a subcomponent of some composite object,
-- retrieve the ultimate entity if there is one.
- elsif Nkind_In (New_Prefix, N_Selected_Component,
- N_Indexed_Component)
+ elsif Nkind (New_Prefix) in N_Selected_Component | N_Indexed_Component
then
Pref := Prefix (New_Prefix);
while Present (Pref)
- and then Nkind_In (Pref, N_Selected_Component,
- N_Indexed_Component)
+ and then Nkind (Pref) in
+ N_Selected_Component | N_Indexed_Component
loop
Pref := Prefix (Pref);
end loop;
@@ -13366,7 +14017,7 @@ package body Sem_Util is
Defining_Identifier (Decl));
end if;
- Decl := Next (Decl);
+ Next (Decl);
end loop;
end Inspect_Deferred_Constant_Completion;
@@ -13591,6 +14242,28 @@ package body Sem_Util is
end if;
end Invalid_Scalar_Value;
+ --------------------------------
+ -- Is_Anonymous_Access_Actual --
+ --------------------------------
+
+ function Is_Anonymous_Access_Actual (N : Node_Id) return Boolean is
+ Par : Node_Id;
+ begin
+ if Ekind (Etype (N)) /= E_Anonymous_Access_Type then
+ return False;
+ end if;
+
+ Par := Parent (N);
+ while Present (Par)
+ and then Nkind (Par) in N_Case_Expression
+ | N_If_Expression
+ | N_Parameter_Association
+ loop
+ Par := Parent (Par);
+ end loop;
+ return Nkind (Par) in N_Subprogram_Call;
+ end Is_Anonymous_Access_Actual;
+
-----------------------------
-- Is_Actual_Out_Parameter --
-----------------------------
@@ -13603,6 +14276,18 @@ package body Sem_Util is
return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
end Is_Actual_Out_Parameter;
+ --------------------------------
+ -- Is_Actual_In_Out_Parameter --
+ --------------------------------
+
+ function Is_Actual_In_Out_Parameter (N : Node_Id) return Boolean is
+ Formal : Entity_Id;
+ Call : Node_Id;
+ begin
+ Find_Actual (N, Formal, Call);
+ return Present (Formal) and then Ekind (Formal) = E_In_Out_Parameter;
+ end Is_Actual_In_Out_Parameter;
+
-------------------------
-- Is_Actual_Parameter --
-------------------------
@@ -13688,10 +14373,17 @@ package body Sem_Util is
and then Has_Aliased_Components
(Designated_Type (Etype (Prefix (Obj)))));
- elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
+ elsif Nkind (Obj) in N_Unchecked_Type_Conversion | N_Type_Conversion then
return Is_Tagged_Type (Etype (Obj))
and then Is_Aliased_View (Expression (Obj));
+ -- Ada 202x AI12-0228
+
+ elsif Nkind (Obj) = N_Qualified_Expression
+ and then Ada_Version >= Ada_2012
+ then
+ return Is_Aliased_View (Expression (Obj));
+
elsif Nkind (Obj) = N_Explicit_Dereference then
return Nkind (Original_Node (Obj)) /= N_Function_Call;
@@ -13796,6 +14488,16 @@ package body Sem_Util is
return Is_Atomic_Object (N) or else Is_Volatile_Full_Access_Object (N);
end Is_Atomic_Or_VFA_Object;
+ -----------------------------
+ -- Is_Attribute_Loop_Entry --
+ -----------------------------
+
+ function Is_Attribute_Loop_Entry (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Attribute_Reference
+ and then Attribute_Name (N) = Name_Loop_Entry;
+ end Is_Attribute_Loop_Entry;
+
----------------------
-- Is_Attribute_Old --
----------------------
@@ -13854,6 +14556,17 @@ package body Sem_Util is
Is_RTE (Root_Type (Under), RO_WW_Super_String));
end Is_Bounded_String;
+ -------------------------------
+ -- Is_By_Protected_Procedure --
+ -------------------------------
+
+ function Is_By_Protected_Procedure (Id : Entity_Id) return Boolean is
+ begin
+ return Ekind (Id) = E_Procedure
+ and then Present (Get_Rep_Pragma (Id, Name_Implemented))
+ and then Implementation_Kind (Id) = Name_By_Protected_Procedure;
+ end Is_By_Protected_Procedure;
+
---------------------
-- Is_CCT_Instance --
---------------------
@@ -13863,21 +14576,17 @@ package body Sem_Util is
Context_Id : Entity_Id) return Boolean
is
begin
- pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type));
+ pragma Assert (Ekind (Ref_Id) in E_Protected_Type | E_Task_Type);
if Is_Single_Task_Object (Context_Id) then
return Scope_Within_Or_Same (Etype (Context_Id), Ref_Id);
else
- pragma Assert (Ekind_In (Context_Id, E_Entry,
- E_Entry_Family,
- E_Function,
- E_Package,
- E_Procedure,
- E_Protected_Type,
- E_Task_Type)
- or else
- Is_Record_Type (Context_Id));
+ pragma Assert
+ (Ekind (Context_Id) in
+ E_Entry | E_Entry_Family | E_Function | E_Package |
+ E_Procedure | E_Protected_Type | E_Task_Type
+ or else Is_Record_Type (Context_Id));
return Scope_Within_Or_Same (Context_Id, Ref_Id);
end if;
end Is_CCT_Instance;
@@ -14191,10 +14900,10 @@ package body Sem_Util is
elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then
return False;
- elsif Nkind_In
- (Nkind (Parent (Par)), N_Function_Call,
- N_Procedure_Call_Statement,
- N_Entry_Call_Statement)
+ elsif Nkind (Parent (Par)) in
+ N_Function_Call |
+ N_Procedure_Call_Statement |
+ N_Entry_Call_Statement
then
-- Check that the element is not part of an actual for an
-- in-out parameter.
@@ -14354,9 +15063,9 @@ package body Sem_Util is
P := Parent (N);
while Present (P) loop
- if Nkind_In (P, N_Full_Type_Declaration,
- N_Private_Type_Declaration,
- N_Subtype_Declaration)
+ if Nkind (P) in N_Full_Type_Declaration
+ | N_Private_Type_Declaration
+ | N_Subtype_Declaration
and then Comes_From_Source (P)
and then Defining_Entity (P) = Typ
then
@@ -14388,6 +15097,59 @@ package body Sem_Util is
return False;
end Is_Current_Instance;
+ --------------------------------------------------
+ -- Is_Current_Instance_Reference_In_Type_Aspect --
+ --------------------------------------------------
+
+ function Is_Current_Instance_Reference_In_Type_Aspect
+ (N : Node_Id) return Boolean
+ is
+ begin
+ -- When a current_instance is referenced within an aspect_specification
+ -- of a type or subtype, it will show up as a reference to the formal
+ -- parameter of the aspect's associated subprogram rather than as a
+ -- reference to the type or subtype itself (in fact, the original name
+ -- is never even analyzed). We check for predicate, invariant, and
+ -- Default_Initial_Condition subprograms (in theory there could be
+ -- other cases added, in which case this function will need updating).
+
+ if Is_Entity_Name (N) then
+ return Present (Entity (N))
+ and then Ekind (Entity (N)) = E_In_Parameter
+ and then Ekind (Scope (Entity (N))) in E_Function | E_Procedure
+ and then
+ (Is_Predicate_Function (Scope (Entity (N)))
+ or else Is_Predicate_Function_M (Scope (Entity (N)))
+ or else Is_Invariant_Procedure (Scope (Entity (N)))
+ or else Is_Partial_Invariant_Procedure (Scope (Entity (N)))
+ or else Is_DIC_Procedure (Scope (Entity (N))));
+
+ else
+ case Nkind (N) is
+ when N_Indexed_Component
+ | N_Slice
+ =>
+ return
+ Is_Current_Instance_Reference_In_Type_Aspect (Prefix (N));
+
+ when N_Selected_Component =>
+ return
+ Is_Current_Instance_Reference_In_Type_Aspect (Prefix (N));
+
+ when N_Type_Conversion =>
+ return Is_Current_Instance_Reference_In_Type_Aspect
+ (Expression (N));
+
+ when N_Qualified_Expression =>
+ return Is_Current_Instance_Reference_In_Type_Aspect
+ (Expression (N));
+
+ when others =>
+ return False;
+ end case;
+ end if;
+ end Is_Current_Instance_Reference_In_Type_Aspect;
+
--------------------
-- Is_Declaration --
--------------------
@@ -14531,13 +15293,14 @@ package body Sem_Util is
begin
-- Find the dereference node if any
- while Nkind_In (Deref, N_Indexed_Component,
- N_Selected_Component,
- N_Slice)
+ while Nkind (Deref) in
+ N_Indexed_Component | N_Selected_Component | N_Slice
loop
Deref := Prefix (Deref);
end loop;
+ Deref := Original_Node (Deref);
+
-- If the prefix is a qualified expression of a variable, then function
-- Is_Variable will return False for that because a qualified expression
-- denotes a constant view, so we need to get the name being qualified
@@ -14555,9 +15318,11 @@ package body Sem_Util is
if Is_Variable (Object)
or else Is_Variable (Deref)
- or else (Ada_Version >= Ada_2005
- and then (Nkind (Deref) = N_Explicit_Dereference
- or else Is_Access_Type (Etype (Deref))))
+ or else
+ (Ada_Version >= Ada_2005
+ and then (Nkind (Deref) = N_Explicit_Dereference
+ or else (Present (Etype (Deref))
+ and then Is_Access_Type (Etype (Deref)))))
then
if Nkind (Object) = N_Selected_Component then
@@ -14565,8 +15330,8 @@ package body Sem_Util is
-- False (it could be a function selector in a prefix form call
-- occurring in an iterator specification).
- if not Ekind_In (Entity (Selector_Name (Object)), E_Component,
- E_Discriminant)
+ if Ekind (Entity (Selector_Name (Object))) not in
+ E_Component | E_Discriminant
then
return False;
end if;
@@ -14732,10 +15497,10 @@ package body Sem_Util is
function Is_Dereferenced (N : Node_Id) return Boolean is
P : constant Node_Id := Parent (N);
begin
- return Nkind_In (P, N_Selected_Component,
- N_Explicit_Dereference,
- N_Indexed_Component,
- N_Slice)
+ return Nkind (P) in N_Selected_Component
+ | N_Explicit_Dereference
+ | N_Indexed_Component
+ | N_Slice
and then Prefix (P) = N;
end Is_Dereferenced;
@@ -14867,22 +15632,24 @@ package body Sem_Util is
-- effectively volatile.
elsif Is_Array_Type (Id) then
- declare
- Anc : Entity_Id := Base_Type (Id);
- begin
- if Is_Private_Type (Anc) then
- Anc := Full_View (Anc);
- end if;
+ if Has_Volatile_Components (Id) then
+ return True;
+ else
+ declare
+ Anc : Entity_Id := Base_Type (Id);
+ begin
+ if Is_Private_Type (Anc) then
+ Anc := Full_View (Anc);
+ end if;
- -- Test for presence of ancestor, as the full view of a private
- -- type may be missing in case of error.
+ -- Test for presence of ancestor, as the full view of a
+ -- private type may be missing in case of error.
- return
- Has_Volatile_Components (Id)
- or else
- (Present (Anc)
- and then Is_Effectively_Volatile (Component_Type (Anc)));
- end;
+ return
+ Present (Anc)
+ and then Is_Effectively_Volatile (Component_Type (Anc));
+ end;
+ end if;
-- A protected type is always volatile
@@ -14903,12 +15670,14 @@ package body Sem_Util is
-- Otherwise Id denotes an object
- else
+ else pragma Assert (Is_Object (Id));
-- A volatile object for which No_Caching is enabled is not
-- effectively volatile.
return
- (Is_Volatile (Id) and then not No_Caching_Enabled (Id))
+ (Is_Volatile (Id)
+ and then not
+ (Ekind (Id) = E_Variable and then No_Caching_Enabled (Id)))
or else Has_Volatile_Components (Id)
or else Is_Effectively_Volatile (Etype (Id));
end if;
@@ -14921,9 +15690,10 @@ package body Sem_Util is
function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is
begin
if Is_Entity_Name (N) then
- return Is_Effectively_Volatile (Entity (N));
+ return Is_Object (Entity (N))
+ and then Is_Effectively_Volatile (Entity (N));
- elsif Nkind (N) = N_Indexed_Component then
+ elsif Nkind (N) in N_Indexed_Component | N_Slice then
return Is_Effectively_Volatile_Object (Prefix (N));
elsif Nkind (N) = N_Selected_Component then
@@ -14932,6 +15702,12 @@ package body Sem_Util is
or else
Is_Effectively_Volatile_Object (Selector_Name (N));
+ elsif Nkind (N) in N_Qualified_Expression
+ | N_Unchecked_Type_Conversion
+ | N_Type_Conversion
+ then
+ return Is_Effectively_Volatile_Object (Expression (N));
+
else
return False;
end if;
@@ -14944,7 +15720,7 @@ package body Sem_Util is
function Is_Entry_Body (Id : Entity_Id) return Boolean is
begin
return
- Ekind_In (Id, E_Entry, E_Entry_Family)
+ Is_Entry (Id)
and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Body;
end Is_Entry_Body;
@@ -14955,7 +15731,7 @@ package body Sem_Util is
function Is_Entry_Declaration (Id : Entity_Id) return Boolean is
begin
return
- Ekind_In (Id, E_Entry, E_Entry_Family)
+ Is_Entry (Id)
and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Declaration;
end Is_Entry_Declaration;
@@ -14979,7 +15755,7 @@ package body Sem_Util is
function Is_Expression_Function (Subp : Entity_Id) return Boolean is
begin
- if Ekind_In (Subp, E_Function, E_Subprogram_Body) then
+ if Ekind (Subp) in E_Function | E_Subprogram_Body then
return
Nkind (Original_Node (Unit_Declaration_Node (Subp))) =
N_Expression_Function;
@@ -15074,9 +15850,9 @@ package body Sem_Util is
-- A qualified expression or a type conversion is an EVF expression when
-- its operand is an EVF expression.
- elsif Nkind_In (N, N_Qualified_Expression,
- N_Unchecked_Type_Conversion,
- N_Type_Conversion)
+ elsif Nkind (N) in N_Qualified_Expression
+ | N_Unchecked_Type_Conversion
+ | N_Type_Conversion
then
return Is_EVF_Expression (Expression (N));
@@ -15084,9 +15860,9 @@ package body Sem_Util is
-- their prefix denotes an EVF expression.
elsif Nkind (N) = N_Attribute_Reference
- and then Nam_In (Attribute_Name (N), Name_Loop_Entry,
- Name_Old,
- Name_Update)
+ and then Attribute_Name (N) in Name_Loop_Entry
+ | Name_Old
+ | Name_Update
then
return Is_EVF_Expression (Prefix (N));
end if;
@@ -15412,14 +16188,14 @@ package body Sem_Util is
begin
-- Package/subprogram body
- if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body)
+ if Nkind (Decl) in N_Package_Body | N_Subprogram_Body
and then Present (Corresponding_Spec (Decl))
then
Spec_Decl := Unit_Declaration_Node (Corresponding_Spec (Decl));
-- Package/subprogram body stub
- elsif Nkind_In (Decl, N_Package_Body_Stub, N_Subprogram_Body_Stub)
+ elsif Nkind (Decl) in N_Package_Body_Stub | N_Subprogram_Body_Stub
and then Present (Corresponding_Spec_Of_Stub (Decl))
then
Spec_Decl :=
@@ -15437,8 +16213,8 @@ package body Sem_Util is
-- calls.
return
- Nkind_In (Spec_Decl, N_Generic_Package_Declaration,
- N_Generic_Subprogram_Declaration);
+ Nkind (Spec_Decl) in N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration;
end Is_Generic_Declaration_Or_Body;
---------------------------
@@ -15560,7 +16336,7 @@ package body Sem_Util is
and then not Is_Dispatching_Operation (Subp)
and then Needs_Finalization (Etype (Subp))
and then not Is_Class_Wide_Type (Etype (Subp))
- and then not (Has_Invariants (Etype (Subp)))
+ and then not Has_Invariants (Etype (Subp))
and then Present (Subprogram_Body (Subp))
and then Was_Expression_Function (Subprogram_Body (Subp))
then
@@ -15597,8 +16373,7 @@ package body Sem_Util is
-- a predefined unit, i.e the one that declares iterator interfaces.
return
- Nam_In (Chars (Iter_Typ), Name_Forward_Iterator,
- Name_Reversible_Iterator)
+ Chars (Iter_Typ) in Name_Forward_Iterator | Name_Reversible_Iterator
and then In_Predefined_Unit (Root_Type (Iter_Typ));
end Denotes_Iterator;
@@ -15674,7 +16449,7 @@ package body Sem_Util is
-- Case of prefix of indexed or selected component or slice
- elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
+ elsif Nkind (P) in N_Indexed_Component | N_Selected_Component | N_Slice
and then N = Prefix (P)
then
-- Here we have the case where the parent P is N.Q or N(Q .. R).
@@ -15752,7 +16527,7 @@ package body Sem_Util is
Ent : constant Entity_Id := Entity (Expr);
Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
begin
- if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
+ if Ekind (Ent) not in E_Variable | E_In_Out_Parameter then
return False;
else
return Present (Sub) and then Sub = Current_Subprogram;
@@ -15782,8 +16557,7 @@ package body Sem_Util is
-- Attributes 'Input, 'Old and 'Result produce objects
when N_Attribute_Reference =>
- return
- Nam_In (Attribute_Name (N), Name_Input, Name_Old, Name_Result);
+ return Attribute_Name (N) in Name_Input | Name_Old | Name_Result;
when N_Selected_Component =>
return
@@ -16016,6 +16790,9 @@ package body Sem_Util is
Visit (Discrete_Subtype_Definition (Nod));
+ when N_Parameter_Association =>
+ Visit (Explicit_Actual_Parameter (N));
+
when N_Protected_Definition =>
-- End_Label is left out because it is not relevant for
@@ -16181,6 +16958,21 @@ package body Sem_Util is
Visit_List (Actions (Expr));
Visit (Expression (Expr));
+ when N_Function_Call =>
+
+ -- Ada 2020 (AI12-0175): Calls to certain functions that are
+ -- essentially unchecked conversions are preelaborable.
+
+ if Ada_Version >= Ada_2020
+ and then Nkind (Expr) = N_Function_Call
+ and then Is_Entity_Name (Name (Expr))
+ and then Is_Preelaborable_Function (Entity (Name (Expr)))
+ then
+ Visit_List (Parameter_Associations (Expr));
+ else
+ raise Non_Preelaborable;
+ end if;
+
when N_If_Expression =>
Visit_List (Expressions (Expr));
@@ -16214,7 +17006,7 @@ package body Sem_Util is
if Ekind (Id) = E_Discriminant then
null;
- elsif Ekind_In (Id, E_Constant, E_In_Parameter)
+ elsif Ekind (Id) in E_Constant | E_In_Parameter
and then Present (Discriminal_Link (Id))
then
null;
@@ -16306,13 +17098,6 @@ package body Sem_Util is
function Is_Object_Image (Prefix : Node_Id) return Boolean is
begin
- -- When the type of the prefix is not scalar, then the prefix is not
- -- valid in any scenario.
-
- if not Is_Scalar_Type (Etype (Prefix)) then
- return False;
- end if;
-
-- Here we test for the case that the prefix is not a type and assume
-- if it is not then it must be a named value or an object reference.
-- This is because the parser always checks that prefixes of attributes
@@ -16326,36 +17111,14 @@ package body Sem_Util is
-------------------------
function Is_Object_Reference (N : Node_Id) return Boolean is
- function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean;
- -- Determine whether N is the name of an internally-generated renaming
-
- --------------------------------------
- -- Is_Internally_Generated_Renaming --
- --------------------------------------
-
- function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is
- P : Node_Id;
-
- begin
- P := N;
- while Present (P) loop
- if Nkind (P) = N_Object_Renaming_Declaration then
- return not Comes_From_Source (P);
- elsif Is_List_Member (P) then
- return False;
- end if;
-
- P := Parent (P);
- end loop;
-
- return False;
- end Is_Internally_Generated_Renaming;
-
- -- Start of processing for Is_Object_Reference
-
begin
+ -- AI12-0068: Note that a current instance reference in a type or
+ -- subtype's aspect_specification is considered a value, not an object
+ -- (see RM 8.6(18/5)).
+
if Is_Entity_Name (N) then
- return Present (Entity (N)) and then Is_Object (Entity (N));
+ return Present (Entity (N)) and then Is_Object (Entity (N))
+ and then not Is_Current_Instance_Reference_In_Type_Aspect (N);
else
case Nkind (N) is
@@ -16372,20 +17135,20 @@ package body Sem_Util is
-- Note that predefined operators are functions as well, and so
-- are attributes that are (can be renamed as) functions.
- when N_Binary_Op
- | N_Function_Call
- | N_Unary_Op
+ when N_Function_Call
+ | N_Op
=>
return Etype (N) /= Standard_Void_Type;
- -- Attributes references 'Loop_Entry, 'Old, and 'Result yield
- -- objects, even though they are not functions.
+ -- Attributes references 'Loop_Entry, 'Old, 'Priority and 'Result
+ -- yield objects, even though they are not functions.
when N_Attribute_Reference =>
return
- Nam_In (Attribute_Name (N), Name_Loop_Entry,
- Name_Old,
- Name_Result)
+ Attribute_Name (N) in Name_Loop_Entry
+ | Name_Old
+ | Name_Priority
+ | Name_Result
or else Is_Function_Attribute_Name (Attribute_Name (N));
when N_Selected_Component =>
@@ -16401,15 +17164,25 @@ package body Sem_Util is
-- names.
when N_Explicit_Dereference =>
- return not Nkind_In (Original_Node (N), N_Case_Expression,
- N_If_Expression);
+ return Nkind (Original_Node (N)) not in
+ N_Case_Expression | N_If_Expression;
-- A view conversion of a tagged object is an object reference
when N_Type_Conversion =>
- return Is_Tagged_Type (Etype (Subtype_Mark (N)))
- and then Is_Tagged_Type (Etype (Expression (N)))
- and then Is_Object_Reference (Expression (N));
+ if Ada_Version <= Ada_2012 then
+ -- A view conversion of a tagged object is an object
+ -- reference.
+ return Is_Tagged_Type (Etype (Subtype_Mark (N)))
+ and then Is_Tagged_Type (Etype (Expression (N)))
+ and then Is_Object_Reference (Expression (N));
+
+ else
+ -- AI12-0226: In Ada 202x a value conversion of an object is
+ -- an object.
+
+ return Is_Object_Reference (Expression (N));
+ end if;
-- An unchecked type conversion is considered to be an object if
-- the operand is an object (this construction arises only as a
@@ -16418,25 +17191,31 @@ package body Sem_Util is
when N_Unchecked_Type_Conversion =>
return True;
- -- Allow string literals to act as objects as long as they appear
- -- in internally-generated renamings. The expansion of iterators
- -- may generate such renamings when the range involves a string
- -- literal.
-
- when N_String_Literal =>
- return Is_Internally_Generated_Renaming (Parent (N));
-
-- AI05-0003: In Ada 2012 a qualified expression is a name.
-- This allows disambiguation of function calls and the use
-- of aggregates in more contexts.
when N_Qualified_Expression =>
- if Ada_Version < Ada_2012 then
- return False;
- else
- return Is_Object_Reference (Expression (N))
- or else Nkind (Expression (N)) = N_Aggregate;
- end if;
+ return Ada_Version >= Ada_2012
+ and then Is_Object_Reference (Expression (N));
+
+ -- In Ada 95 an aggregate is an object reference
+
+ when N_Aggregate =>
+ return Ada_Version >= Ada_95;
+
+ -- A string literal is not an object reference, but it might come
+ -- from rewriting of an object reference, e.g. from folding of an
+ -- aggregate.
+
+ when N_String_Literal =>
+ return Is_Rewrite_Substitution (N)
+ and then Is_Object_Reference (Original_Node (N));
+
+ -- AI12-0125: Target name represents a constant object
+
+ when N_Target_Name =>
+ return True;
when others =>
return False;
@@ -16470,10 +17249,9 @@ package body Sem_Util is
-- check whether the context requires an access_to_variable type.
elsif Nkind (AV) = N_Explicit_Dereference
- and then Ada_Version >= Ada_2012
- and then Nkind (Original_Node (AV)) = N_Indexed_Component
and then Present (Etype (Original_Node (AV)))
and then Has_Implicit_Dereference (Etype (Original_Node (AV)))
+ and then Ada_Version >= Ada_2012
then
return not Is_Access_Constant (Etype (Prefix (AV)));
@@ -16486,7 +17264,7 @@ package body Sem_Util is
-- expansion of a packed array aggregate).
elsif Nkind (AV) = N_Unchecked_Type_Conversion then
- if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then
+ if Nkind (Original_Node (AV)) in N_Function_Call | N_Aggregate then
return False;
elsif Comes_From_Source (AV)
@@ -16531,28 +17309,7 @@ package body Sem_Util is
-- but we still want to allow the conversion if it converts a variable).
elsif Is_Rewrite_Substitution (AV) then
-
- -- In Ada 2012, the explicit dereference may be a rewritten call to a
- -- Reference function.
-
- if Ada_Version >= Ada_2012
- and then Nkind (Original_Node (AV)) = N_Function_Call
- and then
- Has_Implicit_Dereference (Etype (Name (Original_Node (AV))))
- then
-
- -- Check that this is not a constant reference.
-
- return not Is_Access_Constant (Etype (Prefix (AV)));
-
- elsif Has_Implicit_Dereference (Etype (Original_Node (AV))) then
- return
- not Is_Access_Constant (Etype
- (Get_Reference_Discriminant (Etype (Original_Node (AV)))));
-
- else
- return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
- end if;
+ return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
-- All other non-variables are rejected
@@ -16603,10 +17360,8 @@ package body Sem_Util is
and then Is_Protected_Type (Etype (Pref))
and then Is_Entity_Name (Subp)
and then Present (Entity (Subp))
- and then Ekind_In (Entity (Subp), E_Entry,
- E_Entry_Family,
- E_Function,
- E_Procedure);
+ and then Ekind (Entity (Subp)) in
+ E_Entry | E_Entry_Family | E_Function | E_Procedure;
else
return False;
end if;
@@ -16651,7 +17406,7 @@ package body Sem_Util is
Func_Id := Id;
while Present (Func_Id) and then Func_Id /= Standard_Standard loop
- if Ekind_In (Func_Id, E_Function, E_Generic_Function) then
+ if Ekind (Func_Id) in E_Function | E_Generic_Function then
return Is_Volatile_Function (Func_Id);
end if;
@@ -16679,6 +17434,7 @@ package body Sem_Util is
elsif Nkind (Context) = N_Object_Declaration
and then Present (Expression (Context))
and then Expression (Context) = Obj_Ref
+ and then Nkind (Parent (Context)) /= N_Expression_With_Actions
then
Obj_Id := Defining_Entity (Context);
@@ -16730,11 +17486,12 @@ package body Sem_Util is
-- The volatile object appears as the prefix of a name occurring in a
-- non-interfering context.
- elsif Nkind_In (Context, N_Attribute_Reference,
- N_Explicit_Dereference,
- N_Indexed_Component,
- N_Selected_Component,
- N_Slice)
+ elsif Nkind (Context) in
+ N_Attribute_Reference |
+ N_Explicit_Dereference |
+ N_Indexed_Component |
+ N_Selected_Component |
+ N_Slice
and then Prefix (Context) = Obj_Ref
and then Is_OK_Volatile_Context
(Context => Parent (Context),
@@ -16748,25 +17505,26 @@ package body Sem_Util is
elsif Nkind (Context) = N_Attribute_Reference
and then Prefix (Context) = Obj_Ref
- and then Nam_In (Attribute_Name (Context), Name_Address,
- Name_Alignment,
- Name_Component_Size,
- Name_First,
- Name_First_Bit,
- Name_Last,
- Name_Last_Bit,
- Name_Length,
- Name_Position,
- Name_Size,
- Name_Storage_Size)
+ and then Attribute_Name (Context) in Name_Address
+ | Name_Alignment
+ | Name_Component_Size
+ | Name_First
+ | Name_First_Bit
+ | Name_Last
+ | Name_Last_Bit
+ | Name_Length
+ | Name_Position
+ | Name_Size
+ | Name_Storage_Size
then
return True;
-- The volatile object appears as the expression of a type conversion
-- occurring in a non-interfering context.
- elsif Nkind_In (Context, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ elsif Nkind (Context) in N_Qualified_Expression
+ | N_Type_Conversion
+ | N_Unchecked_Type_Conversion
and then Expression (Context) = Obj_Ref
and then Is_OK_Volatile_Context
(Context => Parent (Context),
@@ -16832,7 +17590,7 @@ package body Sem_Util is
is
begin
if Is_Scalar_Type (Typ) then
- return False;
+ return Has_Default_Aspect (Base_Type (Typ));
elsif Is_Access_Type (Typ) then
return Include_Implicit;
@@ -16841,8 +17599,9 @@ package body Sem_Util is
-- If component type is partially initialized, so is array type
- if Is_Partially_Initialized_Type
- (Component_Type (Typ), Include_Implicit)
+ if Has_Default_Aspect (Base_Type (Typ))
+ or else Is_Partially_Initialized_Type
+ (Component_Type (Typ), Include_Implicit)
then
return True;
@@ -16871,7 +17630,7 @@ package body Sem_Util is
else
declare
- Ent : Entity_Id;
+ Comp : Entity_Id;
Component_Present : Boolean := False;
-- Set True if at least one component is present. If no
@@ -16881,30 +17640,28 @@ package body Sem_Util is
begin
-- Loop through components
- Ent := First_Entity (Typ);
- while Present (Ent) loop
- if Ekind (Ent) = E_Component then
- Component_Present := True;
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ Component_Present := True;
- -- If a component has an initialization expression then
- -- the enclosing record type is partially initialized
+ -- If a component has an initialization expression then the
+ -- enclosing record type is partially initialized
- if Present (Parent (Ent))
- and then Present (Expression (Parent (Ent)))
- then
- return True;
+ if Present (Parent (Comp))
+ and then Present (Expression (Parent (Comp)))
+ then
+ return True;
- -- If a component is of a type which is itself partially
- -- initialized, then the enclosing record type is also.
+ -- If a component is of a type which is itself partially
+ -- initialized, then the enclosing record type is also.
- elsif Is_Partially_Initialized_Type
- (Etype (Ent), Include_Implicit)
- then
- return True;
- end if;
+ elsif Is_Partially_Initialized_Type
+ (Etype (Comp), Include_Implicit)
+ then
+ return True;
end if;
- Next_Entity (Ent);
+ Next_Component (Comp);
end loop;
-- No initialized components found. If we found any components
@@ -17018,9 +17775,181 @@ package body Sem_Util is
--------------------------------
function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is
+ function Has_Null_Others_Choice (Aggr : Node_Id) return Boolean;
+ -- Aggr is an array aggregate with static bounds and an others clause;
+ -- return True if the others choice of the given array aggregate does
+ -- not cover any component (i.e. is null).
+
+ function Immediate_Context_Implies_Is_Potentially_Unevaluated
+ (Expr : Node_Id) return Boolean;
+ -- Return True if the *immediate* context of this expression tells us
+ -- that it is potentially unevaluated; return False if the *immediate*
+ -- context doesn't provide an answer to this question and we need to
+ -- keep looking.
+
+ function Non_Static_Or_Null_Range (N : Node_Id) return Boolean;
+ -- Return True if the given range is nonstatic or null
+
+ ----------------------------
+ -- Has_Null_Others_Choice --
+ ----------------------------
+
+ function Has_Null_Others_Choice (Aggr : Node_Id) return Boolean is
+ Idx : constant Node_Id := First_Index (Etype (Aggr));
+ Hiv : constant Uint := Expr_Value (Type_High_Bound (Etype (Idx)));
+ Lov : constant Uint := Expr_Value (Type_Low_Bound (Etype (Idx)));
+
+ begin
+ declare
+ Intervals : constant Interval_Lists.Discrete_Interval_List :=
+ Interval_Lists.Aggregate_Intervals (Aggr);
+
+ begin
+ -- The others choice is null if, after normalization, we
+ -- have a single interval covering the whole aggregate.
+
+ return Intervals'Length = 1
+ and then
+ Intervals (Intervals'First).Low = Lov
+ and then
+ Intervals (Intervals'First).High = Hiv;
+ end;
+
+ -- If the aggregate is malformed (that is, indexes are not disjoint)
+ -- then no action is needed at this stage; the error will be reported
+ -- later by the frontend.
+
+ exception
+ when Interval_Lists.Intervals_Error =>
+ return False;
+ end Has_Null_Others_Choice;
+
+ ----------------------------------------------------------
+ -- Immediate_Context_Implies_Is_Potentially_Unevaluated --
+ ----------------------------------------------------------
+
+ function Immediate_Context_Implies_Is_Potentially_Unevaluated
+ (Expr : Node_Id) return Boolean
+ is
+ Par : constant Node_Id := Parent (Expr);
+
+ begin
+ if Nkind (Par) = N_If_Expression then
+ return Is_Elsif (Par) or else Expr /= First (Expressions (Par));
+
+ elsif Nkind (Par) = N_Case_Expression then
+ return Expr /= Expression (Par);
+
+ elsif Nkind (Par) in N_And_Then | N_Or_Else then
+ return Expr = Right_Opnd (Par);
+
+ elsif Nkind (Par) in N_In | N_Not_In then
+
+ -- If the membership includes several alternatives, only the first
+ -- is definitely evaluated.
+
+ if Present (Alternatives (Par)) then
+ return Expr /= First (Alternatives (Par));
+
+ -- If this is a range membership both bounds are evaluated
+
+ else
+ return False;
+ end if;
+
+ elsif Nkind (Par) = N_Quantified_Expression then
+ return Expr = Condition (Par);
+
+ elsif Nkind (Par) = N_Aggregate
+ and then Present (Etype (Par))
+ and then Etype (Par) /= Any_Composite
+ and then Is_Array_Type (Etype (Par))
+ and then Nkind (Expr) = N_Component_Association
+ then
+ declare
+ Choice : Node_Id;
+ In_Others_Choice : Boolean := False;
+
+ begin
+ -- The expression of an array_component_association is
+ -- potentially unevaluated if the associated choice is a
+ -- subtype_indication or range that defines a nonstatic or
+ -- null range.
+
+ Choice := First (Choices (Expr));
+ while Present (Choice) loop
+ if Nkind (Choice) = N_Range
+ and then Non_Static_Or_Null_Range (Choice)
+ then
+ return True;
+
+ elsif Nkind (Choice) = N_Identifier
+ and then Present (Scalar_Range (Etype (Choice)))
+ and then
+ Non_Static_Or_Null_Range (Scalar_Range (Etype (Choice)))
+ then
+ return True;
+
+ elsif Nkind (Choice) = N_Others_Choice then
+ In_Others_Choice := True;
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ -- It is also potentially unevaluated if the associated choice
+ -- is an others choice and the applicable index constraint is
+ -- nonstatic or null.
+
+ if In_Others_Choice then
+ if not Compile_Time_Known_Bounds (Etype (Par)) then
+ return True;
+ else
+ return Has_Null_Others_Choice (Par);
+ end if;
+ end if;
+ end;
+
+ return False;
+
+ else
+ return False;
+ end if;
+ end Immediate_Context_Implies_Is_Potentially_Unevaluated;
+
+ ------------------------------
+ -- Non_Static_Or_Null_Range --
+ ------------------------------
+
+ function Non_Static_Or_Null_Range (N : Node_Id) return Boolean is
+ Low, High : Node_Id;
+
+ begin
+ Get_Index_Bounds (N, Low, High);
+
+ -- Check static bounds
+
+ if not Compile_Time_Known_Value (Low)
+ or else not Compile_Time_Known_Value (High)
+ then
+ return True;
+
+ -- Check null range
+
+ elsif Expr_Value (High) < Expr_Value (Low) then
+ return True;
+ end if;
+
+ return False;
+ end Non_Static_Or_Null_Range;
+
+ -- Local variables
+
Par : Node_Id;
Expr : Node_Id;
+ -- Start of processing for Is_Potentially_Unevaluated
+
begin
Expr := N;
Par := N;
@@ -17049,22 +17978,27 @@ package body Sem_Util is
-- conjunct in a postcondition) with a potentially unevaluated operand.
Par := Parent (Expr);
- while not Nkind_In (Par, N_And_Then,
- N_Case_Expression,
- N_If_Expression,
- N_In,
- N_Not_In,
- N_Or_Else,
- N_Quantified_Expression)
+
+ while Present (Par)
+ and then Nkind (Par) /= N_Pragma_Argument_Association
loop
- Expr := Par;
- Par := Parent (Par);
+ if Comes_From_Source (Par)
+ and then
+ Immediate_Context_Implies_Is_Potentially_Unevaluated (Expr)
+ then
+ return True;
+
+ -- For component associations continue climbing; it may be part of
+ -- an array aggregate.
+
+ elsif Nkind (Par) = N_Component_Association then
+ null;
-- If the context is not an expression, or if is the result of
-- expansion of an enclosing construct (such as another attribute)
-- the predicate does not apply.
- if Nkind (Par) = N_Case_Expression_Alternative then
+ elsif Nkind (Par) = N_Case_Expression_Alternative then
null;
elsif Nkind (Par) not in N_Subexpr
@@ -17072,37 +18006,12 @@ package body Sem_Util is
then
return False;
end if;
- end loop;
-
- if Nkind (Par) = N_If_Expression then
- return Is_Elsif (Par) or else Expr /= First (Expressions (Par));
-
- elsif Nkind (Par) = N_Case_Expression then
- return Expr /= Expression (Par);
-
- elsif Nkind_In (Par, N_And_Then, N_Or_Else) then
- return Expr = Right_Opnd (Par);
-
- elsif Nkind_In (Par, N_In, N_Not_In) then
-
- -- If the membership includes several alternatives, only the first is
- -- definitely evaluated.
-
- if Present (Alternatives (Par)) then
- return Expr /= First (Alternatives (Par));
- -- If this is a range membership both bounds are evaluated
-
- else
- return False;
- end if;
-
- elsif Nkind (Par) = N_Quantified_Expression then
- return Expr = Condition (Par);
+ Expr := Par;
+ Par := Parent (Par);
+ end loop;
- else
- return False;
- end if;
+ return False;
end Is_Potentially_Unevaluated;
-----------------------------------------
@@ -17130,7 +18039,7 @@ package body Sem_Util is
TSS_Name_Type
(Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
- if Nam_In (Chars (E), Name_uAssign, Name_uSize)
+ if Chars (E) in Name_uAssign | Name_uSize
or else
(Chars (E) = Name_Op_Eq
and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
@@ -17140,6 +18049,7 @@ package body Sem_Util is
or else TSS_Name = TSS_Stream_Output
or else TSS_Name = TSS_Stream_Read
or else TSS_Name = TSS_Stream_Write
+ or else TSS_Name = TSS_Put_Image
or else Is_Predefined_Interface_Primitive (E)
then
return True;
@@ -17160,12 +18070,12 @@ package body Sem_Util is
-- these primitives.
return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion)
- and then Nam_In (Chars (E), Name_uDisp_Asynchronous_Select,
- Name_uDisp_Conditional_Select,
- Name_uDisp_Get_Prim_Op_Kind,
- Name_uDisp_Get_Task_Id,
- Name_uDisp_Requeue,
- Name_uDisp_Timed_Select);
+ and then Chars (E) in Name_uDisp_Asynchronous_Select
+ | Name_uDisp_Conditional_Select
+ | Name_uDisp_Get_Prim_Op_Kind
+ | Name_uDisp_Get_Task_Id
+ | Name_uDisp_Requeue
+ | Name_uDisp_Timed_Select;
end Is_Predefined_Interface_Primitive;
---------------------------------------
@@ -17193,7 +18103,7 @@ package body Sem_Util is
TSS_Name_Type
(Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
- if Nam_In (Chars (E), Name_uSize, Name_uAssign)
+ if Chars (E) in Name_uSize | Name_uAssign
or else
(Chars (E) = Name_Op_Eq
and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
@@ -17323,7 +18233,7 @@ package body Sem_Util is
begin
-- Aggregates
- if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
+ if Nkind (N) in N_Aggregate | N_Extension_Aggregate then
return Is_Preelaborable_Aggregate (N);
-- Attributes are allowed in general, even if their prefix is a formal
@@ -17348,7 +18258,7 @@ package body Sem_Util is
and then Present (Entity (N))
and then
(Ekind (Entity (N)) = E_Discriminant
- or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter)
+ or else (Ekind (Entity (N)) in E_Constant | E_In_Parameter
and then Present (Discriminal_Link (Entity (N)))))
then
return True;
@@ -17358,6 +18268,30 @@ package body Sem_Util is
elsif Nkind (N) = N_Null then
return True;
+ -- Ada 2020 (AI12-0175): Calls to certain functions that are essentially
+ -- unchecked conversions are preelaborable.
+
+ elsif Ada_Version >= Ada_2020
+ and then Nkind (N) = N_Function_Call
+ and then Is_Entity_Name (Name (N))
+ and then Is_Preelaborable_Function (Entity (Name (N)))
+ then
+ declare
+ A : Node_Id;
+ begin
+ A := First_Actual (N);
+
+ while Present (A) loop
+ if not Is_Preelaborable_Construct (A) then
+ return False;
+ end if;
+
+ Next_Actual (A);
+ end loop;
+ end;
+
+ return True;
+
-- Otherwise the construct is not preelaborable
else
@@ -17365,6 +18299,50 @@ package body Sem_Util is
end if;
end Is_Preelaborable_Construct;
+ -------------------------------
+ -- Is_Preelaborable_Function --
+ -------------------------------
+
+ function Is_Preelaborable_Function (Id : Entity_Id) return Boolean is
+ SATAC : constant Rtsfind.RTU_Id := System_Address_To_Access_Conversions;
+ Scop : constant Entity_Id := Scope (Id);
+
+ begin
+ -- Small optimization: every allowed function has convention Intrinsic
+ -- (see Analyze_Subprogram_Instantiation for the subtlety in the test).
+
+ if not Is_Intrinsic_Subprogram (Id)
+ and then Convention (Id) /= Convention_Intrinsic
+ then
+ return False;
+ end if;
+
+ -- An instance of Unchecked_Conversion
+
+ if Is_Unchecked_Conversion_Instance (Id) then
+ return True;
+ end if;
+
+ -- A function declared in System.Storage_Elements
+
+ if Is_RTU (Scop, System_Storage_Elements) then
+ return True;
+ end if;
+
+ -- The functions To_Pointer and To_Address declared in an instance of
+ -- System.Address_To_Access_Conversions (they are the only ones).
+
+ if Ekind (Scop) = E_Package
+ and then Nkind (Parent (Scop)) = N_Package_Specification
+ and then Present (Generic_Parent (Parent (Scop)))
+ and then Is_RTU (Generic_Parent (Parent (Scop)), SATAC)
+ then
+ return True;
+ end if;
+
+ return False;
+ end Is_Preelaborable_Function;
+
---------------------------------
-- Is_Protected_Self_Reference --
---------------------------------
@@ -17568,28 +18546,6 @@ package body Sem_Util is
return False;
end Is_Renamed_Entry;
- -----------------------------
- -- Is_Renaming_Declaration --
- -----------------------------
-
- function Is_Renaming_Declaration (N : Node_Id) return Boolean is
- begin
- case Nkind (N) is
- when N_Exception_Renaming_Declaration
- | N_Generic_Function_Renaming_Declaration
- | N_Generic_Package_Renaming_Declaration
- | N_Generic_Procedure_Renaming_Declaration
- | N_Object_Renaming_Declaration
- | N_Package_Renaming_Declaration
- | N_Subprogram_Renaming_Declaration
- =>
- return True;
-
- when others =>
- return False;
- end case;
- end Is_Renaming_Declaration;
-
----------------------------
-- Is_Reversible_Iterator --
----------------------------
@@ -17636,12 +18592,12 @@ package body Sem_Util is
begin
if not Is_List_Member (N) then
declare
- P : constant Node_Id := Parent (N);
+ P : constant Node_Id := Parent (N);
begin
- return Nkind_In (P, N_Expanded_Name,
- N_Generic_Association,
- N_Parameter_Association,
- N_Selected_Component)
+ return Nkind (P) in N_Expanded_Name
+ | N_Generic_Association
+ | N_Parameter_Association
+ | N_Selected_Component
and then Selector_Name (P) = N;
end;
@@ -17676,7 +18632,7 @@ package body Sem_Util is
function Is_Single_Concurrent_Type (Id : Entity_Id) return Boolean is
begin
return
- Ekind_In (Id, E_Protected_Type, E_Task_Type)
+ Ekind (Id) in E_Protected_Type | E_Task_Type
and then Is_Single_Concurrent_Type_Declaration
(Declaration_Node (Id));
end Is_Single_Concurrent_Type;
@@ -17689,8 +18645,8 @@ package body Sem_Util is
(N : Node_Id) return Boolean
is
begin
- return Nkind_In (Original_Node (N), N_Single_Protected_Declaration,
- N_Single_Task_Declaration);
+ return Nkind (Original_Node (N)) in
+ N_Single_Protected_Declaration | N_Single_Task_Declaration;
end Is_Single_Concurrent_Type_Declaration;
---------------------------------------------
@@ -17731,157 +18687,42 @@ package body Sem_Util is
and then Is_Single_Concurrent_Type (Etype (Id));
end Is_Single_Task_Object;
- -------------------------------------
- -- Is_SPARK_05_Initialization_Expr --
- -------------------------------------
-
- function Is_SPARK_05_Initialization_Expr (N : Node_Id) return Boolean is
- Is_Ok : Boolean;
- Expr : Node_Id;
- Comp_Assn : Node_Id;
- Orig_N : constant Node_Id := Original_Node (N);
+ --------------------------------------
+ -- Is_Special_Aliased_Formal_Access --
+ --------------------------------------
+ function Is_Special_Aliased_Formal_Access
+ (Exp : Node_Id;
+ Scop : Entity_Id) return Boolean is
begin
- Is_Ok := True;
+ -- Verify the expression is an access reference to 'Access within a
+ -- return statement as this is the only time an explicitly aliased
+ -- formal has different semantics.
- if not Comes_From_Source (Orig_N) then
- goto Done;
+ if Nkind (Exp) /= N_Attribute_Reference
+ or else Get_Attribute_Id (Attribute_Name (Exp)) /= Attribute_Access
+ or else Nkind (Parent (Exp)) /= N_Simple_Return_Statement
+ then
+ return False;
end if;
- pragma Assert (Nkind (Orig_N) in N_Subexpr);
-
- case Nkind (Orig_N) is
- when N_Character_Literal
- | N_Integer_Literal
- | N_Real_Literal
- | N_String_Literal
- =>
- null;
-
- when N_Expanded_Name
- | N_Identifier
- =>
- if Is_Entity_Name (Orig_N)
- and then Present (Entity (Orig_N)) -- needed in some cases
- then
- case Ekind (Entity (Orig_N)) is
- when E_Constant
- | E_Enumeration_Literal
- | E_Named_Integer
- | E_Named_Real
- =>
- null;
-
- when others =>
- if Is_Type (Entity (Orig_N)) then
- null;
- else
- Is_Ok := False;
- end if;
- end case;
- end if;
-
- when N_Qualified_Expression
- | N_Type_Conversion
- =>
- Is_Ok := Is_SPARK_05_Initialization_Expr (Expression (Orig_N));
-
- when N_Unary_Op =>
- Is_Ok := Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N));
-
- when N_Binary_Op
- | N_Membership_Test
- | N_Short_Circuit
- =>
- Is_Ok := Is_SPARK_05_Initialization_Expr (Left_Opnd (Orig_N))
- and then
- Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N));
-
- when N_Aggregate
- | N_Extension_Aggregate
- =>
- if Nkind (Orig_N) = N_Extension_Aggregate then
- Is_Ok :=
- Is_SPARK_05_Initialization_Expr (Ancestor_Part (Orig_N));
- end if;
-
- Expr := First (Expressions (Orig_N));
- while Present (Expr) loop
- if not Is_SPARK_05_Initialization_Expr (Expr) then
- Is_Ok := False;
- goto Done;
- end if;
-
- Next (Expr);
- end loop;
-
- Comp_Assn := First (Component_Associations (Orig_N));
- while Present (Comp_Assn) loop
- Expr := Expression (Comp_Assn);
-
- -- Note: test for Present here needed for box assocation
-
- if Present (Expr)
- and then not Is_SPARK_05_Initialization_Expr (Expr)
- then
- Is_Ok := False;
- goto Done;
- end if;
-
- Next (Comp_Assn);
- end loop;
-
- when N_Attribute_Reference =>
- if Nkind (Prefix (Orig_N)) in N_Subexpr then
- Is_Ok := Is_SPARK_05_Initialization_Expr (Prefix (Orig_N));
- end if;
-
- Expr := First (Expressions (Orig_N));
- while Present (Expr) loop
- if not Is_SPARK_05_Initialization_Expr (Expr) then
- Is_Ok := False;
- goto Done;
- end if;
-
- Next (Expr);
- end loop;
+ -- Check if the prefix of the reference is indeed an explicitly aliased
+ -- formal parameter for the function Scop. Additionally, we must check
+ -- that Scop returns an anonymous access type, otherwise the special
+ -- rules dictating a need for a dynamic check are not in effect.
- -- Selected components might be expanded named not yet resolved, so
- -- default on the safe side. (Eg on sparklex.ads)
-
- when N_Selected_Component =>
- null;
-
- when others =>
- Is_Ok := False;
- end case;
-
- <<Done>>
- return Is_Ok;
- end Is_SPARK_05_Initialization_Expr;
-
- ----------------------------------
- -- Is_SPARK_05_Object_Reference --
- ----------------------------------
-
- function Is_SPARK_05_Object_Reference (N : Node_Id) return Boolean is
- begin
- if Is_Entity_Name (N) then
- return Present (Entity (N))
- and then
- (Ekind_In (Entity (N), E_Constant, E_Variable)
- or else Ekind (Entity (N)) in Formal_Kind);
-
- else
- case Nkind (N) is
- when N_Selected_Component =>
- return Is_SPARK_05_Object_Reference (Prefix (N));
-
- when others =>
- return False;
- end case;
- end if;
- end Is_SPARK_05_Object_Reference;
+ declare
+ P_Ult : constant Node_Id := Ultimate_Prefix (Prefix (Exp));
+ begin
+ return Is_Entity_Name (P_Ult)
+ and then Is_Aliased (Entity (P_Ult))
+ and then Is_Formal (Entity (P_Ult))
+ and then Scope (Entity (P_Ult)) = Scop
+ and then Ekind (Scop) in
+ E_Function | E_Operator | E_Subprogram_Type
+ and then Needs_Result_Accessibility_Level (Scop);
+ end;
+ end Is_Special_Aliased_Formal_Access;
-----------------------------
-- Is_Specific_Tagged_Type --
@@ -17915,6 +18756,74 @@ package body Sem_Util is
or else Nkind (N) = N_Procedure_Call_Statement;
end Is_Statement;
+ ------------------------
+ -- Is_Static_Function --
+ ------------------------
+
+ function Is_Static_Function (Subp : Entity_Id) return Boolean is
+ begin
+ return Has_Aspect (Subp, Aspect_Static)
+ and then
+ (No (Find_Value_Of_Aspect (Subp, Aspect_Static))
+ or else Is_True (Static_Boolean
+ (Find_Value_Of_Aspect (Subp, Aspect_Static))));
+ end Is_Static_Function;
+
+ ------------------------------
+ -- Is_Static_Function_Call --
+ ------------------------------
+
+ function Is_Static_Function_Call (Call : Node_Id) return Boolean is
+ function Has_All_Static_Actuals (Call : Node_Id) return Boolean;
+ -- Return whether all actual parameters of Call are static expressions
+
+ ----------------------------
+ -- Has_All_Static_Actuals --
+ ----------------------------
+
+ function Has_All_Static_Actuals (Call : Node_Id) return Boolean is
+ Actual : Node_Id := First_Actual (Call);
+ String_Result : constant Boolean :=
+ Is_String_Type (Etype (Entity (Name (Call))));
+
+ begin
+ while Present (Actual) loop
+ if not Is_Static_Expression (Actual) then
+
+ -- ??? In the string-returning case we want to avoid a call
+ -- being made to Establish_Transient_Scope in Resolve_Call,
+ -- but at the point where that's tested for (which now includes
+ -- a call to test Is_Static_Function_Call), the actuals of the
+ -- call haven't been resolved, so expressions of the actuals
+ -- may not have been marked Is_Static_Expression yet, so we
+ -- force them to be resolved here, so we can tell if they're
+ -- static. Calling Resolve here is admittedly a kludge, and we
+ -- limit this call to string-returning cases.
+
+ if String_Result then
+ Resolve (Actual);
+ end if;
+
+ -- Test flag again in case it's now True due to above Resolve
+
+ if not Is_Static_Expression (Actual) then
+ return False;
+ end if;
+ end if;
+
+ Next_Actual (Actual);
+ end loop;
+
+ return True;
+ end Has_All_Static_Actuals;
+
+ begin
+ return Nkind (Call) = N_Function_Call
+ and then Is_Entity_Name (Name (Call))
+ and then Is_Static_Function (Entity (Name (Call)))
+ and then Has_All_Static_Actuals (Call);
+ end Is_Static_Function_Call;
+
----------------------------------------
-- Is_Subcomponent_Of_Atomic_Object --
----------------------------------------
@@ -17925,7 +18834,7 @@ package body Sem_Util is
begin
R := Get_Referenced_Object (N);
- while Nkind_In (R, N_Indexed_Component, N_Selected_Component, N_Slice)
+ while Nkind (R) in N_Indexed_Component | N_Selected_Component | N_Slice
loop
R := Get_Referenced_Object (Prefix (R));
@@ -18281,7 +19190,7 @@ package body Sem_Util is
end if;
end if;
- Idx := Next_Index (Idx);
+ Next_Index (Idx);
end loop;
return False;
@@ -18461,14 +19370,14 @@ package body Sem_Util is
or else
Is_Variable_Prefix (Original_Node (Prefix (N)));
- -- in Ada 2012, the dereference may have been added for a type with
- -- a declared implicit dereference aspect. Check that it is not an
- -- access to constant.
+ -- Generalized indexing operations are rewritten as explicit
+ -- dereferences, and it is only during resolution that we can
+ -- check whether the context requires an access_to_variable type.
elsif Nkind (N) = N_Explicit_Dereference
and then Present (Etype (Orig_Node))
- and then Ada_Version >= Ada_2012
and then Has_Implicit_Dereference (Etype (Orig_Node))
+ and then Ada_Version >= Ada_2012
then
return not Is_Access_Constant (Etype (Prefix (N)));
@@ -18567,6 +19476,31 @@ package body Sem_Util is
end if;
end Is_Variable;
+ ------------------------
+ -- Is_View_Conversion --
+ ------------------------
+
+ function Is_View_Conversion (N : Node_Id) return Boolean is
+ begin
+ if Nkind (N) = N_Type_Conversion
+ and then Nkind (Unqual_Conv (N)) = N_Identifier
+ then
+ if Is_Tagged_Type (Etype (N))
+ and then Is_Tagged_Type (Etype (Unqual_Conv (N)))
+ then
+ return True;
+
+ elsif Is_Actual_Parameter (N)
+ and then (Is_Actual_Out_Parameter (N)
+ or else Is_Actual_In_Out_Parameter (N))
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_View_Conversion;
+
---------------------------
-- Is_Visibly_Controlled --
---------------------------
@@ -18624,7 +19558,7 @@ package body Sem_Util is
function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean is
begin
- pragma Assert (Ekind_In (Func_Id, E_Function, E_Generic_Function));
+ pragma Assert (Ekind (Func_Id) in E_Function | E_Generic_Function);
-- A function declared within a protected type is volatile
@@ -18755,8 +19689,8 @@ package body Sem_Util is
begin
pragma Assert (Is_Itype (Id));
return Present (Parent (Id))
- and then Nkind_In (Parent (Id), N_Full_Type_Declaration,
- N_Subtype_Declaration)
+ and then Nkind (Parent (Id)) in
+ N_Full_Type_Declaration | N_Subtype_Declaration
and then Defining_Entity (Parent (Id)) = Id;
end Itype_Has_Declaration;
@@ -19167,9 +20101,8 @@ package body Sem_Util is
-- Obj := new ...'(new Coextension ...);
if Nkind (Context_Nod) = N_Assignment_Statement then
- Is_Dynamic :=
- Nkind_In (Expression (Context_Nod), N_Allocator,
- N_Qualified_Expression);
+ Is_Dynamic := Nkind (Expression (Context_Nod)) in
+ N_Allocator | N_Qualified_Expression;
-- An allocator that appears within the expression of a simple return
-- statement is treated as a potentially dynamic coextension when the
@@ -19179,10 +20112,8 @@ package body Sem_Util is
-- return new ...'(new Coextension ...);
elsif Nkind (Context_Nod) = N_Simple_Return_Statement then
- Is_Dynamic :=
- Nkind_In (Expression (Context_Nod), N_Aggregate,
- N_Allocator,
- N_Qualified_Expression);
+ Is_Dynamic := Nkind (Expression (Context_Nod)) in
+ N_Aggregate | N_Allocator | N_Qualified_Expression;
-- An alloctor that appears within the initialization expression of an
-- object declaration is considered a potentially dynamic coextension
@@ -19198,10 +20129,8 @@ package body Sem_Util is
-- return Obj : ... := (new Coextension ...);
elsif Nkind (Context_Nod) = N_Object_Declaration then
- Is_Dynamic :=
- Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression)
- or else
- Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
+ Is_Dynamic := Nkind (Root_Nod) in N_Allocator | N_Qualified_Expression
+ or else Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
-- This routine should not be called with constructs that cannot contain
-- coextensions.
@@ -19367,12 +20296,12 @@ package body Sem_Util is
-- suppressed. As a result the elaboration checks of the call must
-- be disabled in order to preserve this dependency.
- if Nkind_In (N, N_Entry_Call_Statement,
- N_Function_Call,
- N_Function_Instantiation,
- N_Package_Instantiation,
- N_Procedure_Call_Statement,
- N_Procedure_Instantiation)
+ if Nkind (N) in N_Entry_Call_Statement
+ | N_Function_Call
+ | N_Function_Instantiation
+ | N_Package_Instantiation
+ | N_Procedure_Call_Statement
+ | N_Procedure_Instantiation
then
Nam := Extract_Name (N);
@@ -19451,16 +20380,16 @@ package body Sem_Util is
-- Obtain the complimentary unit of the main unit
- if Nkind_In (Main_Unit, N_Generic_Package_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Package_Declaration,
- N_Subprogram_Declaration)
+ if Nkind (Main_Unit) in N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Package_Declaration
+ | N_Subprogram_Declaration
then
Aux_Id := Corresponding_Body (Main_Unit);
- elsif Nkind_In (Main_Unit, N_Package_Body,
- N_Subprogram_Body,
- N_Subprogram_Renaming_Declaration)
+ elsif Nkind (Main_Unit) in N_Package_Body
+ | N_Subprogram_Body
+ | N_Subprogram_Renaming_Declaration
then
Aux_Id := Corresponding_Spec (Main_Unit);
end if;
@@ -19791,12 +20720,10 @@ package body Sem_Util is
function Process (N : Node_Id) return Traverse_Result is
begin
- if Nkind_In (N, N_Procedure_Call_Statement,
- N_Function_Call,
- N_Raise_Statement,
- N_Raise_Constraint_Error,
- N_Raise_Program_Error,
- N_Raise_Storage_Error)
+ if Nkind (N) in N_Procedure_Call_Statement
+ | N_Function_Call
+ | N_Raise_Statement
+ | N_Raise_xxx_Error
then
Result := True;
return Abandon;
@@ -19978,6 +20905,144 @@ package body Sem_Util is
end if;
end Needs_One_Actual;
+ --------------------------------------
+ -- Needs_Result_Accessibility_Level --
+ --------------------------------------
+
+ function Needs_Result_Accessibility_Level
+ (Func_Id : Entity_Id) return Boolean
+ is
+ Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
+
+ function Has_Unconstrained_Access_Discriminant_Component
+ (Comp_Typ : Entity_Id) return Boolean;
+ -- Returns True if any component of the type has an unconstrained access
+ -- discriminant.
+
+ -----------------------------------------------------
+ -- Has_Unconstrained_Access_Discriminant_Component --
+ -----------------------------------------------------
+
+ function Has_Unconstrained_Access_Discriminant_Component
+ (Comp_Typ : Entity_Id) return Boolean
+ is
+ begin
+ if not Is_Limited_Type (Comp_Typ) then
+ return False;
+
+ -- Only limited types can have access discriminants with
+ -- defaults.
+
+ elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then
+ return True;
+
+ elsif Is_Array_Type (Comp_Typ) then
+ return Has_Unconstrained_Access_Discriminant_Component
+ (Underlying_Type (Component_Type (Comp_Typ)));
+
+ elsif Is_Record_Type (Comp_Typ) then
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Component (Comp_Typ);
+ while Present (Comp) loop
+ if Has_Unconstrained_Access_Discriminant_Component
+ (Underlying_Type (Etype (Comp)))
+ then
+ return True;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Has_Unconstrained_Access_Discriminant_Component;
+
+ Disable_Coextension_Cases : constant Boolean := True;
+ -- Flag used to temporarily disable a "True" result for types with
+ -- access discriminants and related coextension cases.
+
+ -- Start of processing for Needs_Result_Accessibility_Level
+
+ begin
+ -- False if completion unavailable (how does this happen???)
+
+ if not Present (Func_Typ) then
+ return False;
+
+ -- False if not a function, also handle enum-lit renames case
+
+ elsif Func_Typ = Standard_Void_Type
+ or else Is_Scalar_Type (Func_Typ)
+ then
+ return False;
+
+ -- Handle a corner case, a cross-dialect subp renaming. For example,
+ -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when
+ -- an Ada 2005 (or earlier) unit references predefined run-time units.
+
+ elsif Present (Alias (Func_Id)) then
+
+ -- Unimplemented: a cross-dialect subp renaming which does not set
+ -- the Alias attribute (e.g., a rename of a dereference of an access
+ -- to subprogram value). ???
+
+ return Present (Extra_Accessibility_Of_Result (Alias (Func_Id)));
+
+ -- Remaining cases require Ada 2012 mode
+
+ elsif Ada_Version < Ada_2012 then
+ return False;
+
+ -- Handle the situation where a result is an anonymous access type
+ -- RM 3.10.2 (10.3/3).
+
+ elsif Ekind (Func_Typ) = E_Anonymous_Access_Type then
+ return True;
+
+ -- The following cases are related to coextensions and do not fully
+ -- cover everything mentioned in RM 3.10.2 (12) ???
+
+ -- Temporarily disabled ???
+
+ elsif Disable_Coextension_Cases then
+ return False;
+
+ -- In the case of, say, a null tagged record result type, the need for
+ -- this extra parameter might not be obvious so this function returns
+ -- True for all tagged types for compatibility reasons.
+
+ -- A function with, say, a tagged null controlling result type might
+ -- be overridden by a primitive of an extension having an access
+ -- discriminant and the overrider and overridden must have compatible
+ -- calling conventions (including implicitly declared parameters).
+
+ -- Similarly, values of one access-to-subprogram type might designate
+ -- both a primitive subprogram of a given type and a function which is,
+ -- for example, not a primitive subprogram of any type. Again, this
+ -- requires calling convention compatibility. It might be possible to
+ -- solve these issues by introducing wrappers, but that is not the
+ -- approach that was chosen.
+
+ elsif Is_Tagged_Type (Func_Typ) then
+ return True;
+
+ elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then
+ return True;
+
+ elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then
+ return True;
+
+ -- False for all other cases
+
+ else
+ return False;
+ end if;
+ end Needs_Result_Accessibility_Level;
+
---------------------------------
-- Needs_Simple_Initialization --
---------------------------------
@@ -20087,9 +21152,9 @@ package body Sem_Util is
-- subprogram call, and the caller requests this behavior.
elsif not Calls_OK
- and then Nkind_In (Par, N_Entry_Call_Statement,
- N_Function_Call,
- N_Procedure_Call_Statement)
+ and then Nkind (Par) in N_Entry_Call_Statement
+ | N_Function_Call
+ | N_Procedure_Call_Statement
then
return False;
@@ -20120,12 +21185,6 @@ package body Sem_Util is
if Legacy_Elaboration_Checks then
return False;
- -- No marker needs to be created for ASIS because ABE diagnostics and
- -- checks are not performed in this mode.
-
- elsif ASIS_Mode then
- return False;
-
-- No marker needs to be created when the reference is preanalyzed
-- because the marker will be inserted in the wrong place.
@@ -20134,7 +21193,7 @@ package body Sem_Util is
-- Only references warrant a marker
- elsif not Nkind_In (N, N_Expanded_Name, N_Identifier) then
+ elsif Nkind (N) not in N_Expanded_Name | N_Identifier then
return False;
-- Only source references warrant a marker
@@ -20198,13 +21257,125 @@ package body Sem_Util is
while Present (E) loop
Append (New_Copy_Tree (E), NL);
- E := Next (E);
+ Next (E);
end loop;
return NL;
end if;
end New_Copy_List_Tree;
+ ----------------------------
+ -- New_Copy_Separate_List --
+ ----------------------------
+
+ function New_Copy_Separate_List (List : List_Id) return List_Id is
+ begin
+ if List = No_List then
+ return No_List;
+
+ else
+ declare
+ List_Copy : constant List_Id := New_List;
+ N : Node_Id := First (List);
+
+ begin
+ while Present (N) loop
+ Append (New_Copy_Separate_Tree (N), List_Copy);
+ Next (N);
+ end loop;
+
+ return List_Copy;
+ end;
+ end if;
+ end New_Copy_Separate_List;
+
+ ----------------------------
+ -- New_Copy_Separate_Tree --
+ ----------------------------
+
+ function New_Copy_Separate_Tree (Source : Node_Id) return Node_Id is
+ function Search_Decl (N : Node_Id) return Traverse_Result;
+ -- Subtree visitor which collects declarations
+
+ procedure Search_Declarations is new Traverse_Proc (Search_Decl);
+ -- Subtree visitor instantiation
+
+ -----------------
+ -- Search_Decl --
+ -----------------
+
+ Decls : Elist_Id;
+
+ function Search_Decl (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) in N_Declaration then
+ if No (Decls) then
+ Decls := New_Elmt_List;
+ end if;
+
+ Append_Elmt (N, Decls);
+ end if;
+
+ return OK;
+ end Search_Decl;
+
+ -- Local variables
+
+ Source_Copy : constant Node_Id := New_Copy_Tree (Source);
+
+ -- Start of processing for New_Copy_Separate_Tree
+
+ begin
+ Decls := No_Elist;
+ Search_Declarations (Source_Copy);
+
+ -- Associate a new Entity with all the subtree declarations (keeping
+ -- their original name).
+
+ if Present (Decls) then
+ declare
+ Elmt : Elmt_Id;
+ Decl : Node_Id;
+ New_E : Entity_Id;
+
+ begin
+ Elmt := First_Elmt (Decls);
+ while Present (Elmt) loop
+ Decl := Node (Elmt);
+ New_E := Make_Defining_Identifier (Sloc (Decl),
+ New_Internal_Name ('P'));
+
+ if Nkind (Decl) = N_Expression_Function then
+ Decl := Specification (Decl);
+ end if;
+
+ if Nkind (Decl) in N_Function_Instantiation
+ | N_Function_Specification
+ | N_Generic_Function_Renaming_Declaration
+ | N_Generic_Package_Renaming_Declaration
+ | N_Generic_Procedure_Renaming_Declaration
+ | N_Package_Body
+ | N_Package_Instantiation
+ | N_Package_Renaming_Declaration
+ | N_Package_Specification
+ | N_Procedure_Instantiation
+ | N_Procedure_Specification
+ then
+ Set_Chars (New_E, Chars (Defining_Unit_Name (Decl)));
+ Set_Defining_Unit_Name (Decl, New_E);
+ else
+ Set_Chars (New_E, Chars (Defining_Identifier (Decl)));
+ Set_Defining_Identifier (Decl, New_E);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+ end if;
+
+ return Source_Copy;
+ end New_Copy_Separate_Tree;
+
-------------------
-- New_Copy_Tree --
-------------------
@@ -20312,7 +21483,7 @@ package body Sem_Util is
-- New_Id is the corresponding new entity generated during Phase 1.
procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id);
- pragma Inline (Add_New_Entity);
+ pragma Inline (Add_Pending_Itype);
-- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to
-- value Itype. Assoc_Nod is the associated node of an itype. Itype is
-- an itype.
@@ -20633,6 +21804,65 @@ package body Sem_Util is
New_Par : Node_Id := Empty;
Semantic : Boolean := False) return Union_Id
is
+ function Has_More_Ids (N : Node_Id) return Boolean;
+ -- Return True when N has attribute More_Ids set to True
+
+ function Is_Syntactic_Node return Boolean;
+ -- Return True when Field is a syntactic node
+
+ ------------------
+ -- Has_More_Ids --
+ ------------------
+
+ function Has_More_Ids (N : Node_Id) return Boolean is
+ begin
+ if Nkind (N) in N_Component_Declaration
+ | N_Discriminant_Specification
+ | N_Exception_Declaration
+ | N_Formal_Object_Declaration
+ | N_Number_Declaration
+ | N_Object_Declaration
+ | N_Parameter_Specification
+ | N_Use_Package_Clause
+ | N_Use_Type_Clause
+ then
+ return More_Ids (N);
+ else
+ return False;
+ end if;
+ end Has_More_Ids;
+
+ -----------------------
+ -- Is_Syntactic_Node --
+ -----------------------
+
+ function Is_Syntactic_Node return Boolean is
+ Old_N : constant Node_Id := Node_Id (Field);
+
+ begin
+ if Parent (Old_N) = Old_Par then
+ return True;
+
+ elsif not Has_More_Ids (Old_Par) then
+ return False;
+
+ -- Perform the check using the last last id in the syntactic chain
+
+ else
+ declare
+ N : Node_Id := Old_Par;
+
+ begin
+ while Present (N) and then More_Ids (N) loop
+ Next (N);
+ end loop;
+
+ pragma Assert (Prev_Ids (N));
+ return Parent (Old_N) = N;
+ end;
+ end if;
+ end Is_Syntactic_Node;
+
begin
-- The field is empty
@@ -20644,7 +21874,7 @@ package body Sem_Util is
elsif Field in Node_Range then
declare
Old_N : constant Node_Id := Node_Id (Field);
- Syntactic : constant Boolean := Parent (Old_N) = Old_Par;
+ Syntactic : constant Boolean := Is_Syntactic_Node;
New_N : Node_Id;
@@ -20835,9 +22065,9 @@ package body Sem_Util is
-- Update the First/Next_Named_Association chain for a replicated
-- call.
- if Nkind_In (N, N_Entry_Call_Statement,
- N_Function_Call,
- N_Procedure_Call_Statement)
+ if Nkind (N) in N_Entry_Call_Statement
+ | N_Function_Call
+ | N_Procedure_Call_Statement
then
Update_Named_Associations
(Old_Call => N,
@@ -20872,6 +22102,11 @@ package body Sem_Util is
Set_Chars (Result, Chars (Entity (Result)));
end if;
end if;
+
+ if Has_Aspects (N) then
+ Set_Aspect_Specifications (Result,
+ Copy_List_With_Replacement (Aspect_Specifications (N)));
+ end if;
end if;
return Result;
@@ -21254,12 +22489,9 @@ package body Sem_Util is
-- an entity declaration that must be replaced when the expander is
-- active if the expression has been preanalyzed or analyzed.
- elsif not Ekind_In (Id, E_Block,
- E_Constant,
- E_Label,
- E_Loop_Parameter,
- E_Procedure,
- E_Variable)
+ elsif Ekind (Id) not in
+ E_Block | E_Constant | E_Label | E_Loop_Parameter |
+ E_Procedure | E_Variable
and then not Is_Type (Id)
then
return;
@@ -21464,7 +22696,7 @@ package body Sem_Util is
-- shared. Thus cloned_Subtype must be set to indicate the sharing.
-- ??? What does this do?
- if Ekind_In (Itype, E_Class_Wide_Subtype, E_Record_Subtype) then
+ if Ekind (Itype) in E_Class_Wide_Subtype | E_Record_Subtype then
Set_Cloned_Subtype (New_Itype, Itype);
end if;
@@ -21552,9 +22784,9 @@ package body Sem_Util is
EWA_Level := EWA_Level + 1;
elsif EWA_Level > 0
- and then Nkind_In (N, N_Block_Statement,
- N_Subprogram_Body,
- N_Subprogram_Declaration)
+ and then Nkind (N) in N_Block_Statement
+ | N_Subprogram_Body
+ | N_Subprogram_Declaration
then
EWA_Inner_Scope_Level := EWA_Inner_Scope_Level + 1;
end if;
@@ -21580,9 +22812,9 @@ package body Sem_Util is
Par_Nod => N);
if EWA_Level > 0
- and then Nkind_In (N, N_Block_Statement,
- N_Subprogram_Body,
- N_Subprogram_Declaration)
+ and then Nkind (N) in N_Block_Statement
+ | N_Subprogram_Body
+ | N_Subprogram_Declaration
then
EWA_Inner_Scope_Level := EWA_Inner_Scope_Level - 1;
@@ -21849,9 +23081,9 @@ package body Sem_Util is
-- In case of a build-in-place call, the call will no longer be a
-- call; it will have been rewritten.
- if Nkind_In (Par, N_Entry_Call_Statement,
- N_Function_Call,
- N_Procedure_Call_Statement)
+ if Nkind (Par) in N_Entry_Call_Statement
+ | N_Function_Call
+ | N_Procedure_Call_Statement
then
return First_Named_Actual (Par);
@@ -21939,36 +23171,34 @@ package body Sem_Util is
Comp : Entity_Id;
begin
- Comp := First_Entity (Typ);
+ Comp := First_Component (Typ);
while Present (Comp) loop
-- Only look at E_Component entities. No need to look at
-- E_Discriminant entities, and we must ignore internal
-- subtypes generated for constrained components.
- if Ekind (Comp) = E_Component then
- declare
- Comp_Type : constant Entity_Id :=
- Underlying_Type (Etype (Comp));
+ declare
+ Comp_Type : constant Entity_Id :=
+ Underlying_Type (Etype (Comp));
- begin
- if Is_Record_Type (Comp_Type)
- or else
- Is_Protected_Type (Comp_Type)
- then
- if not Caller_Known_Size_Record (Comp_Type) then
- return False;
- end if;
+ begin
+ if Is_Record_Type (Comp_Type)
+ or else
+ Is_Protected_Type (Comp_Type)
+ then
+ if not Caller_Known_Size_Record (Comp_Type) then
+ return False;
+ end if;
- elsif Is_Array_Type (Comp_Type) then
- if Size_Depends_On_Discriminant (Comp_Type) then
- return False;
- end if;
+ elsif Is_Array_Type (Comp_Type) then
+ if Size_Depends_On_Discriminant (Comp_Type) then
+ return False;
end if;
- end;
- end if;
+ end if;
+ end;
- Next_Entity (Comp);
+ Next_Component (Comp);
end loop;
end;
@@ -22015,41 +23245,39 @@ package body Sem_Util is
Comp : Entity_Id;
begin
- Comp := First_Entity (Typ);
+ Comp := First_Component (Typ);
while Present (Comp) loop
- if Ekind (Comp) = E_Component then
- declare
- Comp_Type : constant Entity_Id :=
- Underlying_Type (Etype (Comp));
+ declare
+ Comp_Type : constant Entity_Id :=
+ Underlying_Type (Etype (Comp));
- Hi : Node_Id;
- Indx : Node_Id;
- Ityp : Entity_Id;
+ Hi : Node_Id;
+ Indx : Node_Id;
+ Ityp : Entity_Id;
- begin
- if Is_Array_Type (Comp_Type) then
- Indx := First_Index (Comp_Type);
-
- while Present (Indx) loop
- Ityp := Etype (Indx);
- Hi := Type_High_Bound (Ityp);
-
- if Nkind (Hi) = N_Identifier
- and then Ekind (Entity (Hi)) = E_Discriminant
- and then Is_Large_Discrete_Type (Ityp)
- and then Is_Large_Discrete_Type
- (Etype (Entity (Hi)))
- then
- return True;
- end if;
+ begin
+ if Is_Array_Type (Comp_Type) then
+ Indx := First_Index (Comp_Type);
+
+ while Present (Indx) loop
+ Ityp := Etype (Indx);
+ Hi := Type_High_Bound (Ityp);
+
+ if Nkind (Hi) = N_Identifier
+ and then Ekind (Entity (Hi)) = E_Discriminant
+ and then Is_Large_Discrete_Type (Ityp)
+ and then Is_Large_Discrete_Type
+ (Etype (Entity (Hi)))
+ then
+ return True;
+ end if;
- Next_Index (Indx);
- end loop;
- end if;
- end;
- end if;
+ Next_Index (Indx);
+ end loop;
+ end if;
+ end;
- Next_Entity (Comp);
+ Next_Component (Comp);
end loop;
end;
end if;
@@ -22134,6 +23362,7 @@ package body Sem_Util is
------------------------
function No_Caching_Enabled (Id : Entity_Id) return Boolean is
+ pragma Assert (Ekind (Id) = E_Variable);
Prag : constant Node_Id := Get_Pragma (Id, Pragma_No_Caching);
Arg1 : Node_Id;
@@ -22167,7 +23396,7 @@ package body Sem_Util is
function No_Heap_Finalization (Typ : Entity_Id) return Boolean is
begin
- if Ekind_In (Typ, E_Access_Type, E_General_Access_Type)
+ if Ekind (Typ) in E_Access_Type | E_General_Access_Type
and then Is_Library_Level_Entity (Typ)
then
-- A global No_Heap_Finalization pragma applies to all library-level
@@ -22397,9 +23626,9 @@ package body Sem_Util is
then
if No (Actuals)
and then
- Nkind_In (Parent (N), N_Procedure_Call_Statement,
- N_Function_Call,
- N_Parameter_Association)
+ Nkind (Parent (N)) in N_Procedure_Call_Statement
+ | N_Function_Call
+ | N_Parameter_Association
and then Ekind (S) /= E_Function
then
Set_Etype (N, Etype (S));
@@ -22551,15 +23780,13 @@ package body Sem_Util is
end if;
end;
- elsif Nkind_In (Exp, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ elsif Nkind (Exp) in N_Type_Conversion | N_Unchecked_Type_Conversion
then
Exp := Expression (Exp);
goto Continue;
- elsif Nkind_In (Exp, N_Slice,
- N_Indexed_Component,
- N_Selected_Component)
+ elsif Nkind (Exp) in
+ N_Slice | N_Indexed_Component | N_Selected_Component
then
-- Special check, if the prefix is an access type, then return
-- since we are modifying the thing pointed to, not the prefix.
@@ -22620,7 +23847,7 @@ package body Sem_Util is
-- Follow renaming chain
- if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
+ if Ekind (Ent) in E_Variable | E_Constant
and then Present (Renamed_Object (Ent))
then
Exp := Renamed_Object (Ent);
@@ -22643,8 +23870,8 @@ package body Sem_Util is
-- a modification of the container.
elsif Comes_From_Source (Original_Node (Exp))
- and then Nkind_In (Original_Node (Exp), N_Selected_Component,
- N_Indexed_Component)
+ and then Nkind (Original_Node (Exp)) in
+ N_Selected_Component | N_Indexed_Component
then
Exp := Prefix (Original_Node (Exp));
goto Continue;
@@ -22737,13 +23964,12 @@ package body Sem_Util is
function Is_Null_Excluding_Def (Def : Node_Id) return Boolean is
begin
- return
- Nkind_In (Def, N_Access_Definition,
- N_Access_Function_Definition,
- N_Access_Procedure_Definition,
- N_Access_To_Object_Definition,
- N_Component_Definition,
- N_Derived_Type_Definition)
+ return Nkind (Def) in N_Access_Definition
+ | N_Access_Function_Definition
+ | N_Access_Procedure_Definition
+ | N_Access_To_Object_Definition
+ | N_Component_Definition
+ | N_Derived_Type_Definition
and then Null_Exclusion_Present (Def);
end Is_Null_Excluding_Def;
@@ -22765,12 +23991,12 @@ package body Sem_Util is
if Is_Imported (Id) or else Is_Exported (Id) then
return Unknown;
- elsif Nkind_In (Decl, N_Component_Declaration,
- N_Discriminant_Specification,
- N_Formal_Object_Declaration,
- N_Object_Declaration,
- N_Object_Renaming_Declaration,
- N_Parameter_Specification)
+ elsif Nkind (Decl) in N_Component_Declaration
+ | N_Discriminant_Specification
+ | N_Formal_Object_Declaration
+ | N_Object_Declaration
+ | N_Object_Renaming_Declaration
+ | N_Parameter_Specification
then
-- A component declaration yields a non-null value when either
-- its component definition or access definition carries a null
@@ -22891,9 +24117,9 @@ package body Sem_Util is
-- Taking the 'Access of something yields a non-null value
elsif Nkind (N) = N_Attribute_Reference
- and then Nam_In (Attribute_Name (N), Name_Access,
- Name_Unchecked_Access,
- Name_Unrestricted_Access)
+ and then Attribute_Name (N) in Name_Access
+ | Name_Unchecked_Access
+ | Name_Unrestricted_Access
then
return Is_Non_Null;
@@ -22937,7 +24163,8 @@ package body Sem_Util is
if Nkind (N) = N_Null then
return Present (Typ) and then Is_Descendant_Of_Address (Typ);
- elsif Nkind_In (N, N_Op_Eq, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt, N_Op_Ne)
+ elsif Nkind (N) in
+ N_Op_Eq | N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt | N_Op_Ne
then
declare
L : constant Node_Id := Left_Opnd (N);
@@ -23061,18 +24288,31 @@ package body Sem_Util is
-- Local variables
- E : Entity_Id;
+ E : Entity_Id;
+ Orig_Obj : Node_Id := Original_Node (Obj);
+ Orig_Pre : Node_Id;
-- Start of processing for Object_Access_Level
begin
- if Nkind (Obj) = N_Defining_Identifier
- or else Is_Entity_Name (Obj)
+ -- In the case of an expanded implicit dereference we swap the original
+ -- object to be the expanded conversion.
+
+ if Nkind (Obj) = N_Explicit_Dereference
+ and then Nkind (Orig_Obj) /= N_Explicit_Dereference
+ then
+ Orig_Obj := Obj;
+ end if;
+
+ -- Calculate the object node's accessibility level
+
+ if Nkind (Orig_Obj) = N_Defining_Identifier
+ or else Is_Entity_Name (Orig_Obj)
then
- if Nkind (Obj) = N_Defining_Identifier then
- E := Obj;
+ if Nkind (Orig_Obj) = N_Defining_Identifier then
+ E := Orig_Obj;
else
- E := Entity (Obj);
+ E := Entity (Orig_Obj);
end if;
if Is_Prival (E) then
@@ -23085,7 +24325,7 @@ package body Sem_Util is
-- than the level of any visible named access type (see 3.10.2(21)).
if Is_Type (E) then
- return Type_Access_Level (E) + 1;
+ return Type_Access_Level (E) + 1;
elsif Present (Renamed_Object (E)) then
return Object_Access_Level (Renamed_Object (E));
@@ -23102,31 +24342,27 @@ package body Sem_Util is
then
return Type_Access_Level (Scope (E)) + 1;
- else
- -- Aliased formals of functions take their access level from the
- -- point of call, i.e. require a dynamic check. For static check
- -- purposes, this is smaller than the level of the subprogram
- -- itself. For procedures the aliased makes no difference.
-
- if Is_Formal (E)
- and then Is_Aliased (E)
- and then Ekind (Scope (E)) = E_Function
- then
- return Type_Access_Level (Etype (E));
+ -- An object of a named access type gets its level from its
+ -- associated type.
- else
- return Scope_Depth (Enclosing_Dynamic_Scope (E));
- end if;
+ elsif Is_Named_Access_Type (Etype (E)) then
+ return Type_Access_Level (Etype (E));
+
+ else
+ return Scope_Depth (Enclosing_Dynamic_Scope (E));
end if;
- elsif Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
- if Is_Access_Type (Etype (Prefix (Obj))) then
- return Type_Access_Level (Etype (Prefix (Obj)));
+ elsif Nkind (Orig_Obj) in N_Indexed_Component | N_Selected_Component then
+ Orig_Pre := Original_Node (Prefix (Orig_Obj));
+
+ if Is_Access_Type (Etype (Orig_Pre)) then
+ return Type_Access_Level (Etype (Orig_Pre));
else
- return Object_Access_Level (Prefix (Obj));
+ return Object_Access_Level (Prefix (Orig_Obj));
end if;
- elsif Nkind (Obj) = N_Explicit_Dereference then
+ elsif Nkind (Orig_Obj) = N_Explicit_Dereference then
+ Orig_Pre := Original_Node (Prefix (Orig_Obj));
-- If the prefix is a selected access discriminant then we make a
-- recursive call on the prefix, which will in turn check the level
@@ -23138,46 +24374,47 @@ package body Sem_Util is
-- otherwise expansion will already have transformed the prefix into
-- a temporary.
- if Nkind (Prefix (Obj)) = N_Selected_Component
- and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
+ if Nkind (Orig_Pre) = N_Selected_Component
+ and then Ekind (Etype (Orig_Pre)) = E_Anonymous_Access_Type
and then
- Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
+ Ekind (Entity (Selector_Name (Orig_Pre))) = E_Discriminant
and then
(not Has_Implicit_Dereference
- (Entity (Selector_Name (Prefix (Obj))))
+ (Entity (Selector_Name (Orig_Pre)))
or else Nkind (Parent (Obj)) /= N_Selected_Component)
then
- return Object_Access_Level (Prefix (Obj));
+ return Object_Access_Level (Prefix (Orig_Obj));
-- Detect an interface conversion in the context of a dispatching
-- call. Use the original form of the conversion to find the access
-- level of the operand.
- elsif Is_Interface (Etype (Obj))
- and then Is_Interface_Conversion (Prefix (Obj))
- and then Nkind (Original_Node (Obj)) = N_Type_Conversion
+ elsif Is_Interface (Etype (Orig_Obj))
+ and then Is_Interface_Conversion (Orig_Pre)
+ and then Nkind (Orig_Obj) = N_Type_Conversion
then
- return Object_Access_Level (Original_Node (Obj));
+ return Object_Access_Level (Orig_Obj);
- elsif not Comes_From_Source (Obj) then
+ elsif not Comes_From_Source (Orig_Obj) then
declare
- Ref : constant Node_Id := Reference_To (Obj);
+ Ref : constant Node_Id := Reference_To (Orig_Obj);
begin
if Present (Ref) then
return Object_Access_Level (Ref);
else
- return Type_Access_Level (Etype (Prefix (Obj)));
+ return Type_Access_Level (Etype (Prefix (Orig_Obj)));
end if;
end;
else
- return Type_Access_Level (Etype (Prefix (Obj)));
+ return Type_Access_Level (Etype (Prefix (Orig_Obj)));
end if;
- elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then
- return Object_Access_Level (Expression (Obj));
+ elsif Nkind (Orig_Obj) in N_Type_Conversion | N_Unchecked_Type_Conversion
+ then
+ return Object_Access_Level (Expression (Orig_Obj));
- elsif Nkind (Obj) = N_Function_Call then
+ elsif Nkind (Orig_Obj) = N_Function_Call then
-- Function results are objects, so we get either the access level of
-- the function or, in the case of an indirect call, the level of the
@@ -23188,10 +24425,10 @@ package body Sem_Util is
-- compiled with -gnat95. ???)
if Ada_Version < Ada_2005 then
- if Is_Entity_Name (Name (Obj)) then
- return Subprogram_Access_Level (Entity (Name (Obj)));
+ if Is_Entity_Name (Name (Orig_Obj)) then
+ return Subprogram_Access_Level (Entity (Name (Orig_Obj)));
else
- return Type_Access_Level (Etype (Prefix (Name (Obj))));
+ return Type_Access_Level (Etype (Prefix (Name (Orig_Obj))));
end if;
-- For Ada 2005, the level of the result object of a function call is
@@ -23291,6 +24528,9 @@ package body Sem_Util is
-- Start of processing for Return_Master_Scope_Depth_Of_Call
begin
+ -- Expanded code may have clobbered the scoping data from the
+ -- original object node - so use the expanded one.
+
return Innermost_Master_Scope_Depth (Obj);
end Return_Master_Scope_Depth_Of_Call;
end if;
@@ -23298,15 +24538,34 @@ package body Sem_Util is
-- For convenience we handle qualified expressions, even though they
-- aren't technically object names.
- elsif Nkind (Obj) = N_Qualified_Expression then
- return Object_Access_Level (Expression (Obj));
+ elsif Nkind (Orig_Obj) = N_Qualified_Expression then
+ return Object_Access_Level (Expression (Orig_Obj));
-- Ditto for aggregates. They have the level of the temporary that
-- will hold their value.
- elsif Nkind (Obj) = N_Aggregate then
+ elsif Nkind (Orig_Obj) = N_Aggregate then
+ return Object_Access_Level (Current_Scope);
+
+ -- Treat an Old/Loop_Entry attribute reference like an aggregate.
+ -- AARM 6.1.1(27.d) says "... the implicit constant declaration
+ -- defines the accessibility level of X'Old", so that is what
+ -- we are trying to implement here.
+
+ elsif Nkind (Orig_Obj) = N_Attribute_Reference
+ and then Attribute_Name (Orig_Obj) in Name_Old | Name_Loop_Entry
+ then
return Object_Access_Level (Current_Scope);
+ -- Move up the attribute reference when we encounter a 'Access variation
+
+ elsif Nkind (Orig_Obj) = N_Attribute_Reference
+ and then Attribute_Name (Orig_Obj) in Name_Access
+ | Name_Unchecked_Access
+ | Name_Unrestricted_Access
+ then
+ return Object_Access_Level (Prefix (Orig_Obj));
+
-- Otherwise return the scope level of Standard. (If there are cases
-- that fall through to this point they will be treated as having
-- global accessibility for now. ???)
@@ -23424,7 +24683,7 @@ package body Sem_Util is
Item_Nam : Name_Id;
begin
- pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma));
+ pragma Assert (Nkind (N) in N_Aspect_Specification | N_Pragma);
Item := N;
@@ -23463,8 +24722,7 @@ package body Sem_Util is
elsif Item_Nam = Name_Pre then
Item_Nam := Name_uPre;
- elsif Nam_In (Item_Nam, Name_Type_Invariant,
- Name_Type_Invariant_Class)
+ elsif Item_Nam in Name_Type_Invariant | Name_Type_Invariant_Class
then
Item_Nam := Name_uType_Invariant;
@@ -23572,7 +24830,7 @@ package body Sem_Util is
-- The current Check_Policy pragma matches the requested policy or
-- appears in the single argument form (Assertion, policy_id).
- if Nam_In (Chars (Arg1), Name_Assertion, Policy) then
+ if Chars (Arg1) in Name_Assertion | Policy then
return Chars (Arg2);
end if;
@@ -23619,7 +24877,7 @@ package body Sem_Util is
-- assertions, unless they are disabled. Force Name_Check on
-- ignored assertions.
- if Nam_In (Kind, Name_Ignore, Name_Off)
+ if Kind in Name_Ignore | Name_Off
and then (CodePeer_Mode or GNATprove_Mode)
then
Kind := Name_Check;
@@ -23628,6 +24886,17 @@ package body Sem_Util is
return Kind;
end Policy_In_Effect;
+ -----------------------
+ -- Predicate_Enabled --
+ -----------------------
+
+ function Predicate_Enabled (Typ : Entity_Id) return Boolean is
+ begin
+ return Present (Predicate_Function (Typ))
+ and then not Predicates_Ignored (Typ)
+ and then not Predicate_Checks_Suppressed (Empty);
+ end Predicate_Enabled;
+
----------------------------------
-- Predicate_Tests_On_Arguments --
----------------------------------
@@ -23966,19 +25235,6 @@ package body Sem_Util is
Get_Decoded_Name_String (Chars (Endl));
Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
-
- else
- -- In SPARK mode, no missing label is allowed for packages and
- -- subprogram bodies. Detect those cases by testing whether
- -- Process_End_Label was called for a body (Typ = 't') or a package.
-
- if Restriction_Check_Required (SPARK_05)
- and then (Typ = 't' or else Ekind (Ent) = E_Package)
- then
- Error_Msg_Node_1 := Endl;
- Check_SPARK_05_Restriction
- ("`END &` required", Endl, Force => True);
- end if;
end if;
-- Now generate the e/t reference
@@ -24046,13 +25302,11 @@ package body Sem_Util is
-- The setting of the attributes is intentionally conservative. This
-- prevents accidental clobbering of enabled attributes.
- if Has_Inherited_DIC (From_Typ)
- and then not Has_Inherited_DIC (Typ)
- then
+ if Has_Inherited_DIC (From_Typ) then
Set_Has_Inherited_DIC (Typ);
end if;
- if Has_Own_DIC (From_Typ) and then not Has_Own_DIC (Typ) then
+ if Has_Own_DIC (From_Typ) then
Set_Has_Own_DIC (Typ);
end if;
@@ -24090,21 +25344,15 @@ package body Sem_Util is
-- The setting of the attributes is intentionally conservative. This
-- prevents accidental clobbering of enabled attributes.
- if Has_Inheritable_Invariants (From_Typ)
- and then not Has_Inheritable_Invariants (Typ)
- then
+ if Has_Inheritable_Invariants (From_Typ) then
Set_Has_Inheritable_Invariants (Typ);
end if;
- if Has_Inherited_Invariants (From_Typ)
- and then not Has_Inherited_Invariants (Typ)
- then
+ if Has_Inherited_Invariants (From_Typ) then
Set_Has_Inherited_Invariants (Typ);
end if;
- if Has_Own_Invariants (From_Typ)
- and then not Has_Own_Invariants (Typ)
- then
+ if Has_Own_Invariants (From_Typ) then
Set_Has_Own_Invariants (Typ);
end if;
@@ -24119,6 +25367,48 @@ package body Sem_Util is
end if;
end Propagate_Invariant_Attributes;
+ ------------------------------------
+ -- Propagate_Predicate_Attributes --
+ ------------------------------------
+
+ procedure Propagate_Predicate_Attributes
+ (Typ : Entity_Id;
+ From_Typ : Entity_Id)
+ is
+ Pred_Func : Entity_Id;
+ Pred_Func_M : Entity_Id;
+
+ begin
+ if Present (Typ) and then Present (From_Typ) then
+ pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ));
+
+ -- Nothing to do if both the source and the destination denote the
+ -- same type.
+
+ if From_Typ = Typ then
+ return;
+ end if;
+
+ Pred_Func := Predicate_Function (From_Typ);
+ Pred_Func_M := Predicate_Function_M (From_Typ);
+
+ -- The setting of the attributes is intentionally conservative. This
+ -- prevents accidental clobbering of enabled attributes.
+
+ if Has_Predicates (From_Typ) then
+ Set_Has_Predicates (Typ);
+ end if;
+
+ if Present (Pred_Func) and then No (Predicate_Function (Typ)) then
+ Set_Predicate_Function (Typ, Pred_Func);
+ end if;
+
+ if Present (Pred_Func_M) and then No (Predicate_Function_M (Typ)) then
+ Set_Predicate_Function_M (Typ, Pred_Func_M);
+ end if;
+ end if;
+ end Propagate_Predicate_Attributes;
+
---------------------------------------
-- Record_Possible_Part_Of_Reference --
---------------------------------------
@@ -24316,7 +25606,7 @@ package body Sem_Util is
-- The entity denotes a primitive subprogram. Remove it from the list of
-- primitives of the associated controlling type.
- if Ekind_In (Id, E_Function, E_Procedure) and then Is_Primitive (Id) then
+ if Ekind (Id) in E_Function | E_Procedure and then Is_Primitive (Id) then
Formal := First_Formal (Id);
while Present (Formal) loop
if Is_Controlling_Formal (Formal) then
@@ -24369,11 +25659,64 @@ package body Sem_Util is
function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id);
+ procedure Ensure_Minimum_Decoration (Typ : Entity_Id);
+ -- If Typ is not frozen then add to Typ the minimum decoration required
+ -- by Requires_Transient_Scope to reliably provide its functionality;
+ -- otherwise no action is performed.
+
+ -------------------------------
+ -- Ensure_Minimum_Decoration --
+ -------------------------------
+
+ procedure Ensure_Minimum_Decoration (Typ : Entity_Id) is
+ begin
+ -- Do not set Has_Controlled_Component on a class-wide equivalent
+ -- type. See Make_CW_Equivalent_Type.
+
+ if Present (Typ)
+ and then not Is_Frozen (Typ)
+ and then (Is_Record_Type (Typ)
+ or else Is_Concurrent_Type (Typ)
+ or else Is_Incomplete_Or_Private_Type (Typ))
+ and then not Is_Class_Wide_Equivalent_Type (Typ)
+ then
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ if Has_Controlled_Component (Etype (Comp))
+ or else
+ (Chars (Comp) /= Name_uParent
+ and then Is_Controlled (Etype (Comp)))
+ or else
+ (Is_Protected_Type (Etype (Comp))
+ and then
+ Present (Corresponding_Record_Type (Etype (Comp)))
+ and then
+ Has_Controlled_Component
+ (Corresponding_Record_Type (Etype (Comp))))
+ then
+ Set_Has_Controlled_Component (Typ);
+ exit;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+ end;
+ end if;
+ end Ensure_Minimum_Decoration;
+
+ -- Start of processing for Requires_Transient_Scope
+
begin
if Debug_Flag_QQ then
return Old_Result;
end if;
+ Ensure_Minimum_Decoration (Id);
+
declare
New_Result : constant Boolean := New_Requires_Transient_Scope (Id);
@@ -24500,23 +25843,25 @@ package body Sem_Util is
is
begin
-- The only entities for which we track constant values are variables
- -- which are not renamings, constants, out parameters, and in out
- -- parameters, so check if we have this case.
+ -- which are not renamings, constants and formal parameters, so check
+ -- if we have this case.
-- Note: it may seem odd to track constant values for constants, but in
-- fact this routine is used for other purposes than simply capturing
- -- the value. In particular, the setting of Known[_Non]_Null.
+ -- the value. In particular, the setting of Known[_Non]_Null and
+ -- Is_Known_Valid.
if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
- or else
- Ekind_In (Ent, E_Constant, E_Out_Parameter, E_In_Out_Parameter)
+ or else
+ Ekind (Ent) = E_Constant
+ or else
+ Is_Formal (Ent)
then
null;
- -- For conditionals, we also allow loop parameters and all formals,
- -- including in parameters.
+ -- For conditionals, we also allow loop parameters
- elsif Cond and then Ekind_In (Ent, E_Loop_Parameter, E_In_Parameter) then
+ elsif Cond and then Ekind (Ent) = E_Loop_Parameter then
null;
-- For all other cases, not just unsafe, but impossible to capture
@@ -24556,7 +25901,7 @@ package body Sem_Util is
while R_Scope /= Standard_Standard loop
exit when R_Scope = E_Scope;
- if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
+ if Ekind (R_Scope) not in E_Package | E_Block | E_Loop then
return False;
else
R_Scope := Scope (R_Scope);
@@ -24670,7 +26015,7 @@ package body Sem_Util is
EN2 : constant Entity_Id := Entity (N2);
begin
if Present (EN1) and then Present (EN2)
- and then (Ekind_In (EN1, E_Variable, E_Constant)
+ and then (Ekind (EN1) in E_Variable | E_Constant
or else Is_Formal (EN1))
and then EN1 = EN2
then
@@ -24960,8 +26305,8 @@ package body Sem_Util is
Typ : constant Entity_Id := Etype (E);
begin
- if Ekind_In (Typ, E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
+ if Ekind (Typ) in E_Anonymous_Access_Type
+ | E_Anonymous_Access_Subprogram_Type
and then not Has_Convention_Pragma (Typ)
then
Basic_Set_Convention (Typ, Val);
@@ -25099,7 +26444,7 @@ package body Sem_Util is
begin
while Present (Indx) loop
Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
- Indx := Next_Index (Indx);
+ Next_Index (Indx);
end loop;
end;
@@ -25166,6 +26511,17 @@ package body Sem_Util is
end if;
end Set_Debug_Info_Needed;
+ --------------------------------
+ -- Set_Debug_Info_Defining_Id --
+ --------------------------------
+
+ procedure Set_Debug_Info_Defining_Id (N : Node_Id) is
+ begin
+ if Comes_From_Source (Defining_Identifier (N)) then
+ Set_Debug_Info_Needed (Defining_Identifier (N));
+ end if;
+ end Set_Debug_Info_Defining_Id;
+
----------------------------
-- Set_Entity_With_Checks --
----------------------------
@@ -25279,7 +26635,7 @@ package body Sem_Util is
or else
(Present (Scope (Val))
and then Is_Implementation_Defined (Scope (Val))))
- and then not (Ekind_In (Val, E_Package, E_Generic_Package)
+ and then not (Is_Package_Or_Generic_Package (Val)
and then Is_Library_Level_Entity (Val))
then
Check_Restriction (No_Implementation_Identifiers, Post_Node);
@@ -25418,8 +26774,8 @@ package body Sem_Util is
if No (N) then
return False;
- elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
- N_If_Statement)
+ elsif Nkind (N) in
+ N_Handled_Sequence_Of_Statements | N_If_Statement
then
return True;
end if;
@@ -25445,8 +26801,8 @@ package body Sem_Util is
-- never needs to be made public and furthermore, making it public can
-- cause back end problems.
- elsif Nkind_In (Parent (Id), N_Object_Declaration,
- N_Function_Specification)
+ elsif Nkind (Parent (Id)) in
+ N_Object_Declaration | N_Function_Specification
and then Within_HSS_Or_If (Id)
then
return;
@@ -25478,7 +26834,7 @@ package body Sem_Util is
begin
-- Deal with indexed or selected component where prefix is modified
- if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
+ if Nkind (N) in N_Indexed_Component | N_Selected_Component then
Pref := Prefix (N);
-- If prefix is access type, then it is the designated object that is
@@ -25643,6 +26999,34 @@ package body Sem_Util is
end if;
end Static_Integer;
+ -------------------------------
+ -- Statically_Denotes_Entity --
+ -------------------------------
+ function Statically_Denotes_Entity (N : Node_Id) return Boolean is
+ E : Entity_Id;
+ begin
+ if not Is_Entity_Name (N) then
+ return False;
+ else
+ E := Entity (N);
+ end if;
+
+ return
+ Nkind (Parent (E)) /= N_Object_Renaming_Declaration
+ or else Is_Prival (E)
+ or else Statically_Denotes_Entity (Renamed_Object (E));
+ end Statically_Denotes_Entity;
+
+ -------------------------------
+ -- Statically_Denotes_Object --
+ -------------------------------
+
+ function Statically_Denotes_Object (N : Node_Id) return Boolean is
+ begin
+ return Statically_Denotes_Entity (N)
+ and then Is_Object_Reference (N);
+ end Statically_Denotes_Object;
+
--------------------------
-- Statically_Different --
--------------------------
@@ -25658,6 +27042,162 @@ package body Sem_Util is
and then not Is_Formal (Entity (R2));
end Statically_Different;
+ -----------------------------
+ -- Statically_Names_Object --
+ -----------------------------
+
+ function Statically_Names_Object (N : Node_Id) return Boolean is
+ begin
+ if Statically_Denotes_Object (N) then
+ return True;
+ elsif Is_Entity_Name (N) then
+ declare
+ E : constant Entity_Id := Entity (N);
+ begin
+ return Nkind (Parent (E)) = N_Object_Renaming_Declaration
+ and then Statically_Names_Object (Renamed_Object (E));
+ end;
+ end if;
+
+ case Nkind (N) is
+ when N_Indexed_Component =>
+ if Is_Access_Type (Etype (Prefix (N))) then
+ -- treat implicit dereference same as explicit
+ return False;
+ end if;
+
+ if not Is_Constrained (Etype (Prefix (N))) then
+ return False;
+ end if;
+
+ declare
+ Indx : Node_Id := First_Index (Etype (Prefix (N)));
+ Expr : Node_Id := First (Expressions (N));
+ Index_Subtype : Node_Id;
+ begin
+ loop
+ Index_Subtype := Etype (Indx);
+
+ if not Is_Static_Subtype (Index_Subtype) then
+ return False;
+ end if;
+ if not Is_OK_Static_Expression (Expr) then
+ return False;
+ end if;
+
+ declare
+ Index_Value : constant Uint := Expr_Value (Expr);
+ Low_Value : constant Uint :=
+ Expr_Value (Type_Low_Bound (Index_Subtype));
+ High_Value : constant Uint :=
+ Expr_Value (Type_High_Bound (Index_Subtype));
+ begin
+ if (Index_Value < Low_Value)
+ or (Index_Value > High_Value)
+ then
+ return False;
+ end if;
+ end;
+
+ Next_Index (Indx);
+ Expr := Next (Expr);
+ pragma Assert ((Present (Indx) = Present (Expr))
+ or else (Serious_Errors_Detected > 0));
+ exit when not (Present (Indx) and Present (Expr));
+ end loop;
+ end;
+
+ when N_Selected_Component =>
+ if Is_Access_Type (Etype (Prefix (N))) then
+ -- treat implicit dereference same as explicit
+ return False;
+ end if;
+
+ if Ekind (Entity (Selector_Name (N))) not in
+ E_Component | E_Discriminant
+ then
+ return False;
+ end if;
+
+ declare
+ Comp : constant Entity_Id :=
+ Original_Record_Component (Entity (Selector_Name (N)));
+ begin
+ -- AI12-0373 confirms that we should not call
+ -- Has_Discriminant_Dependent_Constraint here which would be
+ -- too strong.
+
+ if Is_Declared_Within_Variant (Comp) then
+ return False;
+ end if;
+ end;
+
+ when others => -- includes N_Slice, N_Explicit_Dereference
+ return False;
+ end case;
+
+ pragma Assert (Present (Prefix (N)));
+
+ return Statically_Names_Object (Prefix (N));
+ end Statically_Names_Object;
+
+ ---------------------------------
+ -- String_From_Numeric_Literal --
+ ---------------------------------
+
+ function String_From_Numeric_Literal (N : Node_Id) return String_Id is
+ Loc : constant Source_Ptr := Sloc (N);
+ Sbuffer : constant Source_Buffer_Ptr :=
+ Source_Text (Get_Source_File_Index (Loc));
+ Src_Ptr : Source_Ptr := Loc;
+
+ C : Character := Sbuffer (Src_Ptr);
+ -- Current source program character
+
+ function Belongs_To_Numeric_Literal (C : Character) return Boolean;
+ -- Return True if C belongs to the numeric literal
+
+ --------------------------------
+ -- Belongs_To_Numeric_Literal --
+ --------------------------------
+
+ function Belongs_To_Numeric_Literal (C : Character) return Boolean is
+ begin
+ case C is
+ when '0' .. '9'
+ | '_' | '.' | 'e' | '#' | 'A' | 'B' | 'C' | 'D' | 'E' | 'F'
+ =>
+ return True;
+
+ -- Make sure '+' or '-' is part of an exponent
+
+ when '+' | '-' =>
+ declare
+ Prev_C : constant Character := Sbuffer (Src_Ptr - 1);
+ begin
+ return Prev_C = 'e' or else Prev_C = 'E';
+ end;
+
+ -- Other characters cannot belong to a numeric literal
+
+ when others =>
+ return False;
+ end case;
+ end Belongs_To_Numeric_Literal;
+
+ -- Start of processing for String_From_Numeric_Literal
+
+ begin
+ Start_String;
+ while Belongs_To_Numeric_Literal (C) loop
+ Store_String_Char (C);
+ Src_Ptr := Src_Ptr + 1;
+ C := Sbuffer (Src_Ptr);
+ end loop;
+
+ return End_String;
+ end String_From_Numeric_Literal;
+
--------------------------------------
-- Subject_To_Loop_Entry_Attributes --
--------------------------------------
@@ -25672,7 +27212,7 @@ package body Sem_Util is
-- 'Loop_Entry attribute into a conditional block. Infinite loops lack
-- the conditional part.
- if Nkind_In (Stmt, N_Block_Statement, N_If_Statement)
+ if Nkind (Stmt) in N_Block_Statement | N_If_Statement
and then Nkind (Original_Node (N)) = N_Loop_Statement
then
Stmt := Original_Node (N);
@@ -26334,10 +27874,10 @@ package body Sem_Util is
begin
Pref := N;
- while Nkind_In (Pref, N_Explicit_Dereference,
- N_Indexed_Component,
- N_Selected_Component,
- N_Slice)
+ while Nkind (Pref) in N_Explicit_Dereference
+ | N_Indexed_Component
+ | N_Selected_Component
+ | N_Slice
loop
Pref := Prefix (Pref);
end loop;
@@ -26808,9 +28348,9 @@ package body Sem_Util is
-- Recurse to handle unlikely case of multiple levels of qualification
-- and/or conversion.
- if Nkind_In (Expr, N_Qualified_Expression,
- N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ if Nkind (Expr) in N_Qualified_Expression
+ | N_Type_Conversion
+ | N_Unchecked_Type_Conversion
then
return Unqual_Conv (Expression (Expr));
@@ -26964,9 +28504,9 @@ package body Sem_Util is
Par := N;
while Present (Par) loop
- if Nkind_In (Par, N_Entry_Call_Statement,
- N_Function_Call,
- N_Procedure_Call_Statement)
+ if Nkind (Par) in N_Entry_Call_Statement
+ | N_Function_Call
+ | N_Procedure_Call_Statement
then
return True;
@@ -27040,8 +28580,8 @@ package body Sem_Util is
if No (E) then
return False;
- elsif not Ekind_In (E, E_Discriminant, E_Component)
- or else Nam_In (Chars (E), Name_uTag, Name_uParent)
+ elsif Ekind (E) not in E_Discriminant | E_Component
+ or else Chars (E) in Name_uTag | Name_uParent
then
Next_Entity (E);
@@ -27096,12 +28636,12 @@ package body Sem_Util is
then
return;
- -- In an instance, there is an ongoing problem with completion of
+ -- In an instance, there is an ongoing problem with completion of
-- types derived from private types. Their structure is what Gigi
- -- expects, but the Etype is the parent type rather than the
- -- derived private type itself. Do not flag error in this case. The
- -- private completion is an entity without a parent, like an Itype.
- -- Similarly, full and partial views may be incorrect in the instance.
+ -- expects, but the Etype is the parent type rather than the derived
+ -- private type itself. Do not flag error in this case. The private
+ -- completion is an entity without a parent, like an Itype. Similarly,
+ -- full and partial views may be incorrect in the instance.
-- There is no simple way to insure that it is consistent ???
-- A similar view discrepancy can happen in an inlined body, for the
@@ -27195,7 +28735,7 @@ package body Sem_Util is
elsif Is_Integer_Type (Expec_Type)
and then Is_RTE (Found_Type, RE_Address)
- and then Nkind_In (Parent (Expr), N_Op_Add, N_Op_Subtract)
+ and then Nkind (Parent (Expr)) in N_Op_Add | N_Op_Subtract
and then Expr = Left_Opnd (Parent (Expr))
and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
then
@@ -27285,7 +28825,7 @@ package body Sem_Util is
Error_Msg_N ("\\found package name!", Expr);
elsif Is_Entity_Name (Expr)
- and then Ekind_In (Entity (Expr), E_Procedure, E_Generic_Procedure)
+ and then Ekind (Entity (Expr)) in E_Procedure | E_Generic_Procedure
then
if Ekind (Expec_Type) = E_Access_Subprogram_Type then
Error_Msg_N
@@ -27333,7 +28873,7 @@ package body Sem_Util is
if Expec_Type = Standard_Boolean
and then Is_Modular_Integer_Type (Found_Type)
- and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
+ and then Nkind (Parent (Expr)) in N_Op_And | N_Op_Or | N_Op_Xor
and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
then
declare
@@ -27472,7 +29012,7 @@ package body Sem_Util is
begin
-- Integer and real literals are of a universal type
- if Nkind_In (N, N_Integer_Literal, N_Real_Literal) then
+ if Nkind (N) in N_Integer_Literal | N_Real_Literal then
return True;
-- The values of certain attributes are of a universal type
@@ -27490,26 +29030,113 @@ package body Sem_Util is
package body Interval_Lists is
+ procedure Check_Consistency (Intervals : Discrete_Interval_List);
+ -- Check that list is sorted, lacks null intervals, and has gaps
+ -- between intervals.
+
+ function Chosen_Interval (Choice : Node_Id) return Discrete_Interval;
+ -- Given an element of a Discrete_Choices list, a
+ -- Static_Discrete_Predicate list, or an Others_Discrete_Choices
+ -- list (but not an N_Others_Choice node) return the corresponding
+ -- interval. If an element that does not represent a single
+ -- contiguous interval due to a static predicate (or which
+ -- represents a single contiguous interval whose bounds depend on
+ -- a static predicate) is encountered, then that is an error on the
+ -- part of whoever built the list in question.
+
function In_Interval
(Value : Uint; Interval : Discrete_Interval) return Boolean;
-- Does the given value lie within the given interval?
- -----------------
- -- In_Interval --
- -----------------
- function In_Interval
- (Value : Uint; Interval : Discrete_Interval) return Boolean is
+ procedure Normalize_Interval_List
+ (List : in out Discrete_Interval_List; Last : out Nat);
+ -- Perform sorting and merging as required by Check_Consistency.
+
+ -------------------------
+ -- Aggregate_Intervals --
+ -------------------------
+
+ function Aggregate_Intervals (N : Node_Id) return Discrete_Interval_List
+ is
+ pragma Assert (Nkind (N) = N_Aggregate
+ and then Is_Array_Type (Etype (N)));
+
+ function Unmerged_Intervals_Count return Nat;
+ -- Count the number of intervals given in the aggregate N; the others
+ -- choice (if present) is not taken into account.
+
+ function Unmerged_Intervals_Count return Nat is
+ Count : Nat := 0;
+ Choice : Node_Id;
+ Comp : Node_Id;
+ begin
+ Comp := First (Component_Associations (N));
+ while Present (Comp) loop
+ Choice := First (Choices (Comp));
+
+ while Present (Choice) loop
+ if Nkind (Choice) /= N_Others_Choice then
+ Count := Count + 1;
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ Next (Comp);
+ end loop;
+
+ return Count;
+ end Unmerged_Intervals_Count;
+
+ -- Local variables
+
+ Comp : Node_Id;
+ Max_I : constant Nat := Unmerged_Intervals_Count;
+ Intervals : Discrete_Interval_List (1 .. Max_I);
+ Num_I : Nat := 0;
+
+ -- Start of processing for Aggregate_Intervals
+
begin
- return Value >= Interval.Low and then Value <= Interval.High;
- end In_Interval;
+ -- No action needed if there are no intervals
- procedure Check_Consistency (Intervals : Discrete_Interval_List);
- -- Check that list is sorted, lacks null intervals, and has gaps
- -- between intervals.
+ if Max_I = 0 then
+ return Intervals;
+ end if;
+
+ -- Internally store all the unsorted intervals
+
+ Comp := First (Component_Associations (N));
+ while Present (Comp) loop
+ declare
+ Choice_Intervals : constant Discrete_Interval_List
+ := Choice_List_Intervals (Choices (Comp));
+ begin
+ for J in Choice_Intervals'Range loop
+ Num_I := Num_I + 1;
+ Intervals (Num_I) := Choice_Intervals (J);
+ end loop;
+ end;
+
+ Next (Comp);
+ end loop;
+
+ -- Normalize the lists sorting and merging the intervals
+
+ declare
+ Aggr_Intervals : Discrete_Interval_List (1 .. Num_I)
+ := Intervals (1 .. Num_I);
+ begin
+ Normalize_Interval_List (Aggr_Intervals, Num_I);
+ Check_Consistency (Aggr_Intervals (1 .. Num_I));
+ return Aggr_Intervals (1 .. Num_I);
+ end;
+ end Aggregate_Intervals;
------------------------
-- Check_Consistency --
------------------------
+
procedure Check_Consistency (Intervals : Discrete_Interval_List) is
begin
if Serious_Errors_Detected > 0 then
@@ -27530,19 +29157,79 @@ package body Sem_Util is
end loop;
end Check_Consistency;
- function Chosen_Interval (Choice : Node_Id) return Discrete_Interval;
- -- Given an element of a Discrete_Choices list, a
- -- Static_Discrete_Predicate list, or an Others_Discrete_Choices
- -- list (but not an N_Others_Choice node) return the corresponding
- -- interval. If an element that does not represent a single
- -- contiguous interval due to a static predicate (or which
- -- represents a single contiguous interval whose bounds depend on
- -- a static predicate) is encountered, then that is an error on the
- -- part of whoever built the list in question.
+ ---------------------------
+ -- Choice_List_Intervals --
+ ---------------------------
+
+ function Choice_List_Intervals
+ (Discrete_Choices : List_Id) return Discrete_Interval_List
+ is
+ function Unmerged_Choice_Count return Nat;
+ -- The number of intervals before adjacent intervals are merged.
+
+ ---------------------------
+ -- Unmerged_Choice_Count --
+ ---------------------------
+
+ function Unmerged_Choice_Count return Nat is
+ Choice : Node_Id := First (Discrete_Choices);
+ Count : Nat := 0;
+ begin
+ while Present (Choice) loop
+ -- Non-contiguous choices involving static predicates
+ -- have already been normalized away.
+
+ if Nkind (Choice) = N_Others_Choice then
+ Count :=
+ Count + List_Length (Others_Discrete_Choices (Choice));
+ else
+ Count := Count + 1; -- an ordinary expression or range
+ end if;
+
+ Next (Choice);
+ end loop;
+ return Count;
+ end Unmerged_Choice_Count;
+
+ -- Local variables
+
+ Choice : Node_Id := First (Discrete_Choices);
+ Result : Discrete_Interval_List (1 .. Unmerged_Choice_Count);
+ Count : Nat := 0;
+
+ -- Start of processing for Choice_List_Intervals
+
+ begin
+ while Present (Choice) loop
+ if Nkind (Choice) = N_Others_Choice then
+ declare
+ Others_Choice : Node_Id
+ := First (Others_Discrete_Choices (Choice));
+ begin
+ while Present (Others_Choice) loop
+ Count := Count + 1;
+ Result (Count) := Chosen_Interval (Others_Choice);
+ Next (Others_Choice);
+ end loop;
+ end;
+ else
+ Count := Count + 1;
+ Result (Count) := Chosen_Interval (Choice);
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ pragma Assert (Count = Result'Last);
+ Normalize_Interval_List (Result, Count);
+ Check_Consistency (Result (1 .. Count));
+ return Result (1 .. Count);
+ end Choice_List_Intervals;
---------------------
-- Chosen_Interval --
---------------------
+
function Chosen_Interval (Choice : Node_Id) return Discrete_Interval is
begin
case Nkind (Choice) is
@@ -27575,97 +29262,105 @@ package body Sem_Util is
end case;
end Chosen_Interval;
- --------------------
- -- Type_Intervals --
- --------------------
- function Type_Intervals
- (Typ : Entity_Id) return Discrete_Interval_List
+ -----------------
+ -- In_Interval --
+ -----------------
+
+ function In_Interval
+ (Value : Uint; Interval : Discrete_Interval) return Boolean is
+ begin
+ return Value >= Interval.Low and then Value <= Interval.High;
+ end In_Interval;
+
+ ---------------
+ -- Is_Subset --
+ ---------------
+
+ function Is_Subset
+ (Subset, Of_Set : Discrete_Interval_List) return Boolean
is
+ -- Returns True iff for each interval of Subset we can find
+ -- a single interval of Of_Set which contains the Subset interval.
begin
- if Has_Static_Predicate (Typ) then
- declare
- -- No sorting or merging needed
- SDP_List : constant List_Id := Static_Discrete_Predicate (Typ);
- Range_Or_Expr : Node_Id := First (SDP_List);
- Result :
- Discrete_Interval_List (1 .. List_Length (SDP_List));
- begin
- for Idx in Result'Range loop
- Result (Idx) := Chosen_Interval (Range_Or_Expr);
- Range_Or_Expr := Next (Range_Or_Expr);
+ if Of_Set'Length = 0 then
+ return Subset'Length = 0;
+ end if;
+
+ declare
+ Set_Index : Pos range Of_Set'Range := Of_Set'First;
+
+ begin
+ for Ss_Idx in Subset'Range loop
+ while not In_Interval
+ (Value => Subset (Ss_Idx).Low,
+ Interval => Of_Set (Set_Index))
+ loop
+ if Set_Index = Of_Set'Last then
+ return False;
+ end if;
+
+ Set_Index := Set_Index + 1;
end loop;
- pragma Assert (not Present (Range_Or_Expr));
- Check_Consistency (Result);
- return Result;
- end;
- else
- declare
- Low : constant Uint := Expr_Value (Type_Low_Bound (Typ));
- High : constant Uint := Expr_Value (Type_High_Bound (Typ));
- begin
- if Low > High then
- declare
- Null_Array : Discrete_Interval_List (1 .. 0);
- begin
- return Null_Array;
- end;
- else
- return (1 => (Low => Low, High => High));
+
+ if not In_Interval
+ (Value => Subset (Ss_Idx).High,
+ Interval => Of_Set (Set_Index))
+ then
+ return False;
end if;
- end;
- end if;
- end Type_Intervals;
+ end loop;
+ end;
- procedure Normalize_Interval_List
- (List : in out Discrete_Interval_List; Last : out Nat);
- -- Perform sorting and merging as required by Check_Consistency.
+ return True;
+ end Is_Subset;
-----------------------------
-- Normalize_Interval_List --
-----------------------------
+
procedure Normalize_Interval_List
- (List : in out Discrete_Interval_List; Last : out Nat) is
+ (List : in out Discrete_Interval_List; Last : out Nat)
+ is
+ Temp_0 : Discrete_Interval := (others => Uint_0);
+ -- Cope with Heap_Sort_G idiosyncrasies.
- procedure Move_Interval (From, To : Natural);
- -- Copy interval from one location to another
+ function Is_Null (Idx : Pos) return Boolean;
+ -- True iff List (Idx) defines a null range
function Lt_Interval (Idx1, Idx2 : Natural) return Boolean;
-- Compare two list elements
- Temp_0 : Discrete_Interval := (others => Uint_0);
- -- cope with Heap_Sort_G idiosyncrasies.
+ procedure Merge_Intervals (Null_Interval_Count : out Nat);
+ -- Merge contiguous ranges by replacing one with merged range and
+ -- the other with a null value. Return a count of the null intervals,
+ -- both preexisting and those introduced by merging.
+
+ procedure Move_Interval (From, To : Natural);
+ -- Copy interval from one location to another
function Read_Interval (From : Natural) return Discrete_Interval;
-- Normal array indexing unless From = 0
- -------------------
- -- Read_Interval --
- -------------------
- function Read_Interval (From : Natural) return Discrete_Interval is
- begin
- if From = 0 then
- return Temp_0;
- else
- return List (Pos (From));
- end if;
- end Read_Interval;
+ ----------------------
+ -- Interval_Sorting --
+ ----------------------
- -------------------
- -- Move_Interval --
- -------------------
- procedure Move_Interval (From, To : Natural) is
- Rhs : constant Discrete_Interval := Read_Interval (From);
+ package Interval_Sorting is
+ new Gnat.Heap_Sort_G (Move_Interval, Lt_Interval);
+
+ -------------
+ -- Is_Null --
+ -------------
+
+ function Is_Null (Idx : Pos) return Boolean is
begin
- if To = 0 then
- Temp_0 := Rhs;
- else
- List (Pos (To)) := Rhs;
- end if;
- end Move_Interval;
+ return List (Idx).Low > List (Idx).High;
+ end Is_Null;
-----------------
-- Lt_Interval --
-----------------
+
function Lt_Interval (Idx1, Idx2 : Natural) return Boolean is
Elem1 : constant Discrete_Interval := Read_Interval (Idx1);
Elem2 : constant Discrete_Interval := Read_Interval (Idx2);
@@ -27675,33 +29370,19 @@ package body Sem_Util is
if Null_1 /= Null_2 then
-- So that sorting moves null intervals to high end
return Null_2;
+
elsif Elem1.Low /= Elem2.Low then
return Elem1.Low < Elem2.Low;
+
else
return Elem1.High < Elem2.High;
end if;
end Lt_Interval;
- package Interval_Sorting is
- new Gnat.Heap_Sort_G (Move_Interval, Lt_Interval);
-
- function Is_Null (Idx : Pos) return Boolean;
- -- True iff List (Idx) defines a null range
-
- function Is_Null (Idx : Pos) return Boolean is
- begin
- return List (Idx).Low > List (Idx).High;
- end Is_Null;
-
- procedure Merge_Intervals (Null_Interval_Count : out Nat);
- -- Merge contiguous ranges by replacing one with merged range
- -- and the other with a null value. Return a count of the
- -- null intervals, both preexisting and those introduced by
- -- merging.
-
---------------------
-- Merge_Intervals --
---------------------
+
procedure Merge_Intervals (Null_Interval_Count : out Nat) is
Not_Null : Pos range List'Range;
-- Index of the most recently examined non-null interval
@@ -27717,30 +29398,74 @@ package body Sem_Util is
Null_Interval_Count := 0;
Not_Null := List'First;
+
for Idx in List'First + 1 .. List'Last loop
if Is_Null (Idx) then
+
-- all remaining elements are null
+
Null_Interval_Count :=
Null_Interval_Count + List (Idx .. List'Last)'Length;
return;
+
elsif List (Idx).Low = List (Not_Null).High + 1 then
+
-- Merge the two intervals into one; discard the other
+
List (Not_Null).High := List (Idx).High;
List (Idx) := Null_Interval;
Null_Interval_Count := Null_Interval_Count + 1;
+
else
+ if List (Idx).Low <= List (Not_Null).High then
+ raise Intervals_Error;
+ end if;
+
pragma Assert (List (Idx).Low > List (Not_Null).High);
Not_Null := Idx;
end if;
end loop;
end Merge_Intervals;
+
+ -------------------
+ -- Move_Interval --
+ -------------------
+
+ procedure Move_Interval (From, To : Natural) is
+ Rhs : constant Discrete_Interval := Read_Interval (From);
+ begin
+ if To = 0 then
+ Temp_0 := Rhs;
+ else
+ List (Pos (To)) := Rhs;
+ end if;
+ end Move_Interval;
+
+ -------------------
+ -- Read_Interval --
+ -------------------
+
+ function Read_Interval (From : Natural) return Discrete_Interval is
+ begin
+ if From = 0 then
+ return Temp_0;
+ else
+ return List (Pos (From));
+ end if;
+ end Read_Interval;
+
+ -- Start of processing for Normalize_Interval_Lists
+
begin
Interval_Sorting.Sort (Natural (List'Last));
+
declare
Null_Interval_Count : Nat;
+
begin
Merge_Intervals (Null_Interval_Count);
Last := List'Last - Null_Interval_Count;
+
if Null_Interval_Count /= 0 then
-- Move null intervals introduced during merging to high end
Interval_Sorting.Sort (Natural (List'Last));
@@ -27748,104 +29473,47 @@ package body Sem_Util is
end;
end Normalize_Interval_List;
- ---------------------------
- -- Choice_List_Intervals --
- ---------------------------
- function Choice_List_Intervals
- (Discrete_Choices : List_Id) return Discrete_Interval_List
- is
- function Unmerged_Choice_Count return Nat;
- -- The number of intervals before adjacent intervals are merged.
-
- ---------------------------
- -- Unmerged_Choice_Count --
- ---------------------------
- function Unmerged_Choice_Count return Nat is
- Choice : Node_Id := First (Discrete_Choices);
- Count : Nat := 0;
- begin
- while Present (Choice) loop
- -- Non-contiguous choices involving static predicates
- -- have already been normalized away.
-
- if Nkind (Choice) = N_Others_Choice then
- Count :=
- Count + List_Length (Others_Discrete_Choices (Choice));
- else
- Count := Count + 1; -- an ordinary expression or range
- end if;
-
- Choice := Next (Choice);
- end loop;
- return Count;
- end Unmerged_Choice_Count;
-
- Choice : Node_Id := First (Discrete_Choices);
- Result : Discrete_Interval_List (1 .. Unmerged_Choice_Count);
- Count : Nat := 0;
- begin
- while Present (Choice) loop
- if Nkind (Choice) = N_Others_Choice then
- declare
- Others_Choice : Node_Id
- := First (Others_Discrete_Choices (Choice));
- begin
- while Present (Others_Choice) loop
- Count := Count + 1;
- Result (Count) := Chosen_Interval (Others_Choice);
- Others_Choice := Next (Others_Choice);
- end loop;
- end;
- else
- Count := Count + 1;
- Result (Count) := Chosen_Interval (Choice);
- end if;
- Choice := Next (Choice);
- end loop;
- pragma Assert (Count = Result'Last);
- Normalize_Interval_List (Result, Count);
- Check_Consistency (Result (1 .. Count));
- return Result (1 .. Count);
- end Choice_List_Intervals;
+ --------------------
+ -- Type_Intervals --
+ --------------------
- ---------------
- -- Is_Subset --
- ---------------
- function Is_Subset
- (Subset, Of_Set : Discrete_Interval_List) return Boolean
+ function Type_Intervals (Typ : Entity_Id) return Discrete_Interval_List
is
- -- Returns True iff for each interval of Subset we can find
- -- a single interval of Of_Set which contains the Subset interval.
begin
- if Of_Set'Length = 0 then
- return Subset'Length = 0;
- end if;
+ if Has_Static_Predicate (Typ) then
+ declare
+ -- No sorting or merging needed
+ SDP_List : constant List_Id := Static_Discrete_Predicate (Typ);
+ Range_Or_Expr : Node_Id := First (SDP_List);
+ Result : Discrete_Interval_List (1 .. List_Length (SDP_List));
- declare
- Set_Index : Pos range Of_Set'Range := Of_Set'First;
- begin
- for Ss_Idx in Subset'Range loop
- while not In_Interval
- (Value => Subset (Ss_Idx).Low,
- Interval => Of_Set (Set_Index))
- loop
- if Set_Index = Of_Set'Last then
- return False;
- end if;
- Set_Index := Set_Index + 1;
+ begin
+ for Idx in Result'Range loop
+ Result (Idx) := Chosen_Interval (Range_Or_Expr);
+ Next (Range_Or_Expr);
end loop;
- if not In_Interval
- (Value => Subset (Ss_Idx).High,
- Interval => Of_Set (Set_Index))
- then
- return False;
+ pragma Assert (not Present (Range_Or_Expr));
+ Check_Consistency (Result);
+ return Result;
+ end;
+ else
+ declare
+ Low : constant Uint := Expr_Value (Type_Low_Bound (Typ));
+ High : constant Uint := Expr_Value (Type_High_Bound (Typ));
+ begin
+ if Low > High then
+ declare
+ Null_Array : Discrete_Interval_List (1 .. 0);
+ begin
+ return Null_Array;
+ end;
+ else
+ return (1 => (Low => Low, High => High));
end if;
- end loop;
- end;
-
- return True;
- end Is_Subset;
+ end;
+ end if;
+ end Type_Intervals;
end Interval_Lists;
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index c148a50..a6bd6e2 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -157,14 +157,12 @@ package Sem_Util is
-- force an error).
function Async_Readers_Enabled (Id : Entity_Id) return Boolean;
- -- Given the entity of an abstract state or a variable, determine whether
- -- Id is subject to external property Async_Readers and if it is, the
- -- related expression evaluates to True.
+ -- Id should be the entity of a state abstraction, a variable, or a type.
+ -- Returns True iff Id is subject to external property Async_Readers.
function Async_Writers_Enabled (Id : Entity_Id) return Boolean;
- -- Given the entity of an abstract state or a variable, determine whether
- -- Id is subject to external property Async_Writers and if it is, the
- -- related expression evaluates to True.
+ -- Id should be the entity of a state abstraction, a variable, or a type.
+ -- Returns True iff Id is subject to external property Async_Writers.
function Available_Full_View_Of_Component (T : Entity_Id) return Boolean;
-- If at the point of declaration an array type has a private or limited
@@ -273,6 +271,27 @@ package Sem_Util is
-- through a type-specific wrapper for all inherited subprograms that
-- may have a modified condition.
+ procedure Build_Constrained_Itype
+ (N : Node_Id;
+ Typ : Entity_Id;
+ New_Assoc_List : List_Id);
+ -- Build a constrained itype for the newly created record aggregate N and
+ -- set it as a type of N. The itype will have Typ as its base type and
+ -- will be constrained by the values of discriminants from the component
+ -- association list New_Assoc_List.
+
+ -- ??? This code used to be pretty much a copy of Build_Subtype, but now
+ -- those two routines behave differently for types with unknown
+ -- discriminants. They are both exported in from this package in the hope
+ -- to eventually unify them (a not duplicate them even more until then).
+
+ -- ??? Performance WARNING. The current implementation creates a new itype
+ -- for all aggregates whose base type is discriminated. This means that
+ -- for record aggregates nested inside an array aggregate we will create
+ -- a new itype for each record aggregate if the array component type has
+ -- discriminants. For large aggregates this may be a problem. What should
+ -- be done in this case is to reuse itypes as much as possible.
+
function Build_Default_Subtype
(T : Entity_Id;
N : Node_Id) return Entity_Id;
@@ -291,14 +310,6 @@ package Sem_Util is
-- the compilation unit, and install it in the Elaboration_Entity field
-- of Spec_Id, the entity for the compilation unit.
- function Build_Overriding_Spec
- (Op : Node_Id;
- Typ : Entity_Id) return Node_Id;
- -- Build a subprogram specification for the wrapper of an inherited
- -- operation with a modified pre- or postcondition (See AI12-0113).
- -- Op is the parent operation, and Typ is the descendant type that
- -- inherits the operation.
-
procedure Build_Explicit_Dereference
(Expr : Node_Id;
Disc : Entity_Id);
@@ -308,6 +319,30 @@ package Sem_Util is
-- loaded with both interpretations, and the dereference interpretation
-- carries the name of the reference discriminant.
+ function Build_Overriding_Spec
+ (Op : Node_Id;
+ Typ : Entity_Id) return Node_Id;
+ -- Build a subprogram specification for the wrapper of an inherited
+ -- operation with a modified pre- or postcondition (See AI12-0113).
+ -- Op is the parent operation, and Typ is the descendant type that
+ -- inherits the operation.
+
+ function Build_Subtype
+ (Related_Node : Node_Id;
+ Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Constraints : List_Id)
+ return Entity_Id;
+ -- Typ is an array or discriminated type, Constraints is a list of
+ -- constraints that apply to Typ. This routine builds the constrained
+ -- subtype using Loc as the source location and attached this subtype
+ -- declaration to Related_Node. The returned subtype inherits predicates
+ -- from Typ.
+
+ -- ??? The routine is mostly a duplicate of Build_Constrained_Itype, so be
+ -- careful which of the two better suits your needs (and certainly do not
+ -- duplicate their code).
+
function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean;
-- Returns True if the expression cannot possibly raise Constraint_Error.
-- The response is conservative in the sense that a result of False does
@@ -419,6 +454,19 @@ package Sem_Util is
-- and the context is external to the protected operation, to warn against
-- a possible unlocked access to data.
+ procedure Check_Volatility_Compatibility
+ (Id1, Id2 : Entity_Id;
+ Description_1, Description_2 : String;
+ Srcpos_Bearer : Node_Id);
+ -- Id1 and Id2 should each be the entity of a state abstraction, a
+ -- variable, or a type (i.e., something suitable for passing to
+ -- Async_Readers_Enabled and similar functions).
+ -- Does nothing if SPARK_Mode /= On. Otherwise, flags a legality violation
+ -- if one or more of the four volatility-related aspects is False for Id1
+ -- and True for Id2. The two descriptions are included in the error message
+ -- text; the source position for the generated message is determined by
+ -- Srcpos_Bearer.
+
function Choice_List (N : Node_Id) return List_Id;
-- Utility to retrieve the choices of a Component_Association or the
-- Discrete_Choices of an Iterated_Component_Association. For various
@@ -526,9 +574,10 @@ package Sem_Util is
-- Find the currently visible definition for a given identifier, that is to
-- say the first entry in the visibility chain for the Chars of N.
+ function Current_Entity_In_Scope (N : Name_Id) return Entity_Id;
function Current_Entity_In_Scope (N : Node_Id) return Entity_Id;
- -- Find whether there is a previous definition for identifier N in the
- -- current scope. Because declarations for a scope are not necessarily
+ -- Find whether there is a previous definition for name or identifier N in
+ -- the current scope. Because declarations for a scope are not necessarily
-- contiguous (e.g. for packages) the first entry on the visibility chain
-- for N is not necessarily in the current scope.
@@ -627,14 +676,12 @@ package Sem_Util is
-- are looked through.
function Effective_Reads_Enabled (Id : Entity_Id) return Boolean;
- -- Given the entity of an abstract state or a variable, determine whether
- -- Id is subject to external property Effective_Reads and if it is, the
- -- related expression evaluates to True.
+ -- Id should be the entity of a state abstraction, a variable, or a type.
+ -- Returns True iff Id is subject to external property Effective_Reads.
function Effective_Writes_Enabled (Id : Entity_Id) return Boolean;
- -- Given the entity of an abstract state or a variable, determine whether
- -- Id is subject to external property Effective_Writes and if it is, the
- -- related expression evaluates to True.
+ -- Id should be the entity of a state abstraction, a variable, or a type.
+ -- Returns True iff Id is subject to external property Effective_Writes.
function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id;
-- Returns the enclosing N_Compilation_Unit node that is the root of a
@@ -694,7 +741,7 @@ package Sem_Util is
-- Insert new name in symbol table of current scope with check for
-- duplications (error message is issued if a conflict is found).
-- Note: Enter_Name is not used for overloadable entities, instead these
- -- are entered using Sem_Ch6.Enter_Overloadable_Entity.
+ -- are entered using Sem_Ch6.Enter_Overloaded_Entity.
function Entity_Of (N : Node_Id) return Entity_Id;
-- Obtain the entity of arbitrary node N. If N is a renaming, return the
@@ -1079,8 +1126,8 @@ package Sem_Util is
function Get_Iterable_Type_Primitive
(Typ : Entity_Id;
Nam : Name_Id) return Entity_Id;
- -- Retrieve one of the primitives First, Next, Has_Element, Element from
- -- the value of the Iterable aspect of a type.
+ -- Retrieve one of the primitives First, Last, Next, Previous, Has_Element,
+ -- Element from the value of the Iterable aspect of a type.
procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id);
-- Retrieve the fully expanded name of the library unit declared by
@@ -1138,9 +1185,10 @@ package Sem_Util is
-- corresponding aspect.
function Get_Referenced_Object (N : Node_Id) return Node_Id;
- -- Given a node, return the renamed object if the node represents a renamed
- -- object, otherwise return the node unchanged. The node may represent an
- -- arbitrary expression.
+ -- Given an arbitrary node, return the renamed object if the node
+ -- represents a renamed object; otherwise return the node unchanged.
+ -- The node can represent an arbitrary expression or any other kind of
+ -- node (such as the name of a type).
function Get_Renamed_Entity (E : Entity_Id) return Entity_Id;
-- Given an entity for an exception, package, subprogram or generic unit,
@@ -1170,15 +1218,15 @@ package Sem_Util is
(Typ : Entity_Id;
Priv_Typ : out Entity_Id;
Full_Typ : out Entity_Id;
- Full_Base : out Entity_Id;
+ UFull_Typ : out Entity_Id;
CRec_Typ : out Entity_Id);
- -- Obtain the partial and full view of type Typ and in addition any extra
- -- types the full view may have. The return entities are as follows:
+ -- Obtain the partial and full views of type Typ and in addition any extra
+ -- types the full views may have. The return entities are as follows:
--
-- Priv_Typ - the partial view (a private type)
-- Full_Typ - the full view
- -- Full_Base - the base type of the full view
- -- CRec_Typ - the corresponding record type of the full view
+ -- UFull_Typ - the underlying full view, if the full view is private
+ -- CRec_Typ - the corresponding record type of the full views
function Has_Access_Values (T : Entity_Id) return Boolean;
-- Returns true if type or subtype T is an access type, or has a component
@@ -1250,6 +1298,7 @@ package Sem_Util is
-- * A task type
-- * A private type with pragma Default_Initial_Condition that provides
-- full default initialization.
+ -- This function is not used in GNATprove anymore, but is used in CodePeer.
function Has_Fully_Default_Initializing_DIC_Pragma
(Typ : Entity_Id) return Boolean;
@@ -1308,6 +1357,13 @@ package Sem_Util is
function Has_Non_Null_Statements (L : List_Id) return Boolean;
-- Return True if L has non-null statements
+ function Side_Effect_Free_Statements (L : List_Id) return Boolean;
+ -- Return True if L has no statements with side effects
+
+ function Side_Effect_Free_Loop (N : Node_Id) return Boolean;
+ -- Return True if the loop has no side effect and can therefore be
+ -- marked for removal. Return False if N is not a N_Loop_Statement.
+
function Has_Overriding_Initialize (T : Entity_Id) return Boolean;
-- Predicate to determine whether a controlled type has a user-defined
-- Initialize primitive (and, in Ada 2012, whether that primitive is
@@ -1325,6 +1381,12 @@ package Sem_Util is
-- Check if a type has a (sub)component of a private type that has not
-- yet received a full declaration.
+ function Has_Relaxed_Initialization (E : Entity_Id) return Boolean;
+ -- Returns True iff entity E is subject to the Relaxed_Initialization
+ -- aspect. Entity E can be either type, variable, constant, subprogram,
+ -- entry or an abstract state. For private types and deferred constants
+ -- E should be the private view, because aspect can only be attached there.
+
function Has_Signed_Zeros (E : Entity_Id) return Boolean;
-- Determines if the floating-point type E supports signed zeros.
-- Returns False if E is not a floating-point type.
@@ -1358,6 +1420,11 @@ package Sem_Util is
-- function is used to check if "=" has to be expanded into a bunch
-- component comparisons.
+ function Has_Unconstrained_Access_Discriminants
+ (Subtyp : Entity_Id) return Boolean;
+ -- Returns True if the given subtype is unconstrained and has one or more
+ -- access discriminants.
+
function Has_Undefined_Reference (Expr : Node_Id) return Boolean;
-- Given arbitrary expression Expr, determine whether it contains at
-- least one name whose entity is Any_Id.
@@ -1377,6 +1444,11 @@ package Sem_Util is
Exclude_Parents : Boolean := False) return Boolean;
-- Returns true if the Typ_Ent implements interface Iface_Ent
+ function Implicitly_Designated_Type (Typ : Entity_Id) return Entity_Id;
+ -- Called when Typ is the type of the prefix of an implicit dereference.
+ -- Return the designated type of Typ, taking into account that this type
+ -- may be a limited view, when the nonlimited view is visible.
+
function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean;
-- Returns True if node N appears within a pragma that acts as an assertion
-- expression. See Sem_Prag for the list of qualifying pragmas.
@@ -1466,6 +1538,10 @@ package Sem_Util is
-- either the value is not yet known before back-end processing or it is
-- not known at compile time after back-end processing.
+ procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id);
+ -- Propagate static and dynamic predicate flags from a parent to the
+ -- subtype in a subtype declaration with and without constraints.
+
procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id);
-- Inherit the rep item chain of type From_Typ without clobbering any
-- existing rep items on Typ's chain. Typ is the destination type.
@@ -1505,6 +1581,18 @@ package Sem_Util is
-- pragma Initialize_Scalars or by the binder. Return an expression created
-- at source location Loc, which denotes the invalid value.
+ function Is_Anonymous_Access_Actual (N : Node_Id) return Boolean;
+ -- Determine if N is used as an actual for a call whose corresponding
+ -- formal is of an anonymous access type.
+
+ function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean;
+ -- True if E is the constructed wrapper for an access_to_subprogram
+ -- type with Pre/Postconditions.
+
+ function Is_Actual_In_Out_Parameter (N : Node_Id) return Boolean;
+ -- Determines if N is an actual parameter of in-out mode in a subprogram
+ -- call
+
function Is_Actual_Out_Parameter (N : Node_Id) return Boolean;
-- Determines if N is an actual parameter of out mode in a subprogram call
@@ -1537,6 +1625,9 @@ package Sem_Util is
-- Determine whether arbitrary node N denotes a reference to an object
-- which is either atomic or Volatile_Full_Access.
+ function Is_Attribute_Loop_Entry (N : Node_Id) return Boolean;
+ -- Determine whether node N denotes attribute 'Loop_Entry
+
function Is_Attribute_Old (N : Node_Id) return Boolean;
-- Determine whether node N denotes attribute 'Old
@@ -1553,6 +1644,10 @@ package Sem_Util is
-- True if T is a bounded string type. Used to make sure "=" composes
-- properly for bounded string types.
+ function Is_By_Protected_Procedure (Id : Entity_Id) return Boolean;
+ -- Determine whether entity Id denotes a procedure with synchronization
+ -- kind By_Protected_Procedure.
+
function Is_Constant_Bound (Exp : Node_Id) return Boolean;
-- Exp is the expression for an array bound. Determines whether the
-- bound is a compile-time known value, or a constant entity, or an
@@ -1609,6 +1704,13 @@ package Sem_Util is
-- declarations. In Ada 2012 it also covers type and subtype declarations
-- with aspects: Invariant, Predicate, and Default_Initial_Condition.
+ function Is_Current_Instance_Reference_In_Type_Aspect
+ (N : Node_Id) return Boolean;
+ -- True if N is a reference to a current instance object that occurs within
+ -- an aspect_specification for a type or subtype. In this case N will be
+ -- a formal parameter of a subprogram created for a predicate, invariant,
+ -- or Default_Initial_Condition aspect.
+
function Is_Declaration
(N : Node_Id;
Body_OK : Boolean := True;
@@ -1828,13 +1930,8 @@ package Sem_Util is
-- null component list.
function Is_Object_Image (Prefix : Node_Id) return Boolean;
- -- Returns True if an 'Image, 'Wide_Image, or 'Wide_Wide_Image attribute
- -- is applied to a given object or named value prefix (see below).
-
- -- AI12-00124: The ARG has adopted the GNAT semantics of 'Img for scalar
- -- types, so that the prefix of any 'Image attribute can be an object, a
- -- named value, or a type, and there is no need for an argument in the
- -- case it is an object reference.
+ -- Returns True if an 'Img, 'Image, 'Wide_Image, or 'Wide_Wide_Image
+ -- attribute is applied to an object.
function Is_Object_Reference (N : Node_Id) return Boolean;
-- Determines if the tree referenced by N represents an object. Both
@@ -1851,7 +1948,7 @@ package Sem_Util is
(Context : Node_Id;
Obj_Ref : Node_Id) return Boolean;
-- Determine whether node Context denotes a "non-interfering context" (as
- -- defined in SPARK RM 7.1.3(12)) where volatile reference Obj_Ref can
+ -- defined in SPARK RM 7.1.3(10)) where volatile reference Obj_Ref can
-- safely reside.
function Is_Package_Contract_Annotation (Item : Node_Id) return Boolean;
@@ -1868,7 +1965,8 @@ package Sem_Util is
-- Typ is a type entity. This function returns true if this type is partly
-- initialized, meaning that an object of the type is at least partly
-- initialized (in particular in the record case, that at least one
- -- component has an initialization expression). Note that initialization
+ -- component has an initialization expression, including via Default_Value
+ -- and Default_Component_Value aspects). Note that initialization
-- resulting from the use of pragma Normalize_Scalars does not count.
-- Include_Implicit controls whether implicit initialization of access
-- values to null, and of discriminant values, is counted as making the
@@ -1931,9 +2029,6 @@ package Sem_Util is
function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean;
-- Return True if Proc_Nam is a procedure renaming of an entry
- function Is_Renaming_Declaration (N : Node_Id) return Boolean;
- -- Determine whether arbitrary node N denotes a renaming declaration
-
function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean;
-- AI05-0139-2: Check whether Typ is derived from the predefined interface
-- Ada.Iterator_Interfaces.Reversible_Iterator.
@@ -1973,16 +2068,16 @@ package Sem_Util is
-- Determine whether arbitrary entity Id denotes the anonymous object
-- created for a single task type.
- function Is_SPARK_05_Initialization_Expr (N : Node_Id) return Boolean;
- -- Determines if the tree referenced by N represents an initialization
- -- expression in SPARK 2005, suitable for initializing an object in an
- -- object declaration.
+ function Is_Special_Aliased_Formal_Access
+ (Exp : Node_Id;
+ Scop : Entity_Id) return Boolean;
+ -- Determines whether a dynamic check must be generated for explicitly
+ -- aliased formals within a function Scop for the expression Exp.
- function Is_SPARK_05_Object_Reference (N : Node_Id) return Boolean;
- -- Determines if the tree referenced by N represents an object in SPARK
- -- 2005. This differs from Is_Object_Reference in that only variables,
- -- constants, formal parameters, and selected_components of those are
- -- valid objects in SPARK 2005.
+ -- More specially, Is_Special_Aliased_Formal_Access checks that Exp is a
+ -- 'Access attribute reference within a return statement where the ultimate
+ -- prefix is an aliased formal of Scop and that Scop returns an anonymous
+ -- access type. See RM 3.10.2 for more details.
function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean;
-- Determine whether an arbitrary [private] type is specifically tagged
@@ -1994,6 +2089,15 @@ package Sem_Util is
-- the N_Statement_Other_Than_Procedure_Call subtype from Sinfo).
-- Note that a label is *not* a statement, and will return False.
+ function Is_Static_Function (Subp : Entity_Id) return Boolean;
+ -- Determine whether subprogram Subp denotes a static function,
+ -- which is a function with the aspect Static with value True.
+
+ function Is_Static_Function_Call (Call : Node_Id) return Boolean;
+ -- Determine whether Call is a static call to a static function,
+ -- meaning that the name of the call denotes a static function
+ -- and all of the call's actual parameters are given by static expressions.
+
function Is_Subcomponent_Of_Atomic_Object (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a reference to a subcomponent
-- of an atomic object as per RM C.6(7).
@@ -2088,6 +2192,12 @@ package Sem_Util is
-- default is True since this routine is commonly invoked as part of the
-- semantic analysis and it must not be disturbed by the rewriten nodes.
+ function Is_View_Conversion (N : Node_Id) return Boolean;
+ -- Returns True if N is a type_conversion whose operand is the name of an
+ -- object and both its target type and operand type are tagged, or it
+ -- appears in a call as an actual parameter of mode out or in out
+ -- (RM 4.6(5/2)).
+
function Is_Visibly_Controlled (T : Entity_Id) return Boolean;
-- Check whether T is derived from a visibly controlled type. This is true
-- if the root type is declared in Ada.Finalization. If T is derived
@@ -2246,6 +2356,12 @@ package Sem_Util is
-- syntactic ambiguity that results from an indexing of a function call
-- that returns an array, so that Obj.F (X, Y) may mean F (Ob) (X, Y).
+ function Needs_Result_Accessibility_Level
+ (Func_Id : Entity_Id) return Boolean;
+ -- Ada 2012 (AI05-0234): Return True if the function needs an implicit
+ -- parameter to identify the accessibility level of the function result
+ -- "determined by the point of call".
+
function Needs_Simple_Initialization
(Typ : Entity_Id;
Consider_IS : Boolean := True) return Boolean;
@@ -2271,6 +2387,16 @@ package Sem_Util is
-- below. As for New_Copy_Tree, it is illegal to attempt to copy extended
-- nodes (entities) either directly or indirectly using this function.
+ function New_Copy_Separate_List (List : List_Id) return List_Id;
+ -- Copy recursively a list of nodes using New_Copy_Separate_Tree
+
+ function New_Copy_Separate_Tree (Source : Node_Id) return Node_Id;
+ -- Perform a deep copy of the subtree rooted at Source using New_Copy_Tree
+ -- replacing entities of local declarations by new entities. This behavior
+ -- is required by the backend to ensure entities uniqueness when a copy of
+ -- a subtree is attached to the tree. The new entities keep their original
+ -- names to facilitate debugging the tree copy.
+
function New_Copy_Tree
(Source : Node_Id;
Map : Elist_Id := No_Elist;
@@ -2400,7 +2526,7 @@ package Sem_Util is
-- with the same mode.
procedure Next_Global (Node : in out Node_Id);
- pragma Inline (Next_Actual);
+ pragma Inline (Next_Global);
-- Next_Global (N) is equivalent to N := Next_Global (N). Note that we
-- inline this procedural form, but not the functional form above.
@@ -2489,6 +2615,11 @@ package Sem_Util is
-- Given a policy, return the policy identifier associated with it. If no
-- such policy is in effect, the value returned is No_Name.
+ function Predicate_Enabled (Typ : Entity_Id) return Boolean;
+ -- Return True if a predicate check should be emitted for the given type
+ -- Typ, taking into account Predicates_Ignored and
+ -- Predicate_Checks_Suppressed.
+
function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean;
-- Subp is the entity for a subprogram call. This function returns True if
-- predicate tests are required for the arguments in this call (this is the
@@ -2542,6 +2673,12 @@ package Sem_Util is
-- Inherit all invariant-related attributes form type From_Typ. Typ is the
-- destination type.
+ procedure Propagate_Predicate_Attributes
+ (Typ : Entity_Id;
+ From_Typ : Entity_Id);
+ -- Inherit some predicate-related attributes form type From_Typ. Typ is the
+ -- destination type. Probably to be completed with more attributes???
+
procedure Record_Possible_Part_Of_Reference
(Var_Id : Entity_Id;
Ref : Node_Id);
@@ -2628,13 +2765,14 @@ package Sem_Util is
(N : Node_Id;
Ent : Entity_Id;
Cond : Boolean := False) return Boolean;
- -- The caller is interested in capturing a value (either the current value,
- -- or an indication that the value is non-null) for the given entity Ent.
- -- This value can only be captured if sequential execution semantics can be
- -- properly guaranteed so that a subsequent reference will indeed be sure
- -- that this current value indication is correct. The node N is the
- -- construct which resulted in the possible capture of the value (this
- -- is used to check if we are in a conditional).
+ -- The caller is interested in capturing a value (either the current
+ -- value, an indication that the value is [non-]null or an indication that
+ -- the value is valid) for the given entity Ent. This value can only be
+ -- captured if sequential execution semantics can be properly guaranteed so
+ -- that a subsequent reference will indeed be sure that this current value
+ -- indication is correct. The node N is the construct which resulted in
+ -- the possible capture of the value (this is used to check if we are in
+ -- a conditional).
--
-- Cond is used to skip the test for being inside a conditional. It is used
-- in the case of capturing values from if/while tests, which already do a
@@ -2702,6 +2840,10 @@ package Sem_Util is
-- Establish the entity E as the currently visible definition of its
-- associated name (i.e. the Node_Id associated with its name).
+ procedure Set_Debug_Info_Defining_Id (N : Node_Id);
+ -- Call Set_Debug_Info_Needed on Defining_Identifier (N) if it comes
+ -- from source.
+
procedure Set_Debug_Info_Needed (T : Entity_Id);
-- Sets the Debug_Info_Needed flag on entity T , and also on any entities
-- that are needed by T (for an object, the type of the object is needed,
@@ -2814,10 +2956,23 @@ package Sem_Util is
-- universal expression is returned, otherwise an error message is output
-- and a value of No_Uint is returned.
+ function Statically_Denotes_Entity (N : Node_Id) return Boolean;
+ -- Return True iff N is a name that "statically denotes" an entity.
+
+ function Statically_Denotes_Object (N : Node_Id) return Boolean;
+ -- Return True iff N is a name that "statically denotes" an object.
+
function Statically_Different (E1, E2 : Node_Id) return Boolean;
-- Return True if it can be statically determined that the Expressions
-- E1 and E2 refer to different objects
+ function Statically_Names_Object (N : Node_Id) return Boolean;
+ -- Return True iff N is a name that "statically names" an object.
+
+ function String_From_Numeric_Literal (N : Node_Id) return String_Id;
+ -- Return the string that corresponds to the numeric literal N as it
+ -- appears in the source.
+
function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean;
-- Determine whether node N is a loop statement subject to at least one
-- 'Loop_Entry attribute.
@@ -2925,10 +3080,10 @@ package Sem_Util is
-- conversions, and unchecked conversions.
function Validated_View (Typ : Entity_Id) return Entity_Id;
- -- Obtain the "validated view" of arbitrary type Typ which is suitable
- -- for verification by attributes 'Valid and 'Valid_Scalars. This view
- -- is the type itself or its full view while stripping away concurrency,
- -- derivations, and privacy.
+ -- Obtain the "validated view" of arbitrary type Typ which is suitable for
+ -- verification by attributes 'Valid_Scalars. This view is the type itself
+ -- or its full view while stripping away concurrency, derivations, and
+ -- privacy.
function Visible_Ancestors (Typ : Entity_Id) return Elist_Id;
-- [Ada 2012:AI-0125-1]: Collect all the visible parents and progenitors
@@ -2984,17 +3139,23 @@ package Sem_Util is
-- successive intervals (i.e., mergeable intervals are merged).
-- Low bound is one; high bound is nonnegative.
+ function Aggregate_Intervals (N : Node_Id) return Discrete_Interval_List;
+ -- Given an array aggregate N, returns the (unique) interval list
+ -- representing the values of the aggregate choices; if all the array
+ -- components are covered by the others choice then the length of the
+ -- result is zero.
+
+ function Choice_List_Intervals
+ (Discrete_Choices : List_Id) return Discrete_Interval_List;
+ -- Given a discrete choice list, returns the (unique) interval
+ -- list representing the chosen values.
+
function Type_Intervals (Typ : Entity_Id) return Discrete_Interval_List;
-- Given a static discrete type or subtype, returns the (unique)
-- interval list representing the values of the type/subtype.
-- If no static predicates are involved, the length of the result
-- will be at most one.
- function Choice_List_Intervals (Discrete_Choices : List_Id)
- return Discrete_Interval_List;
- -- Given a discrete choice list, returns the (unique) interval
- -- list representing the chosen values.
-
function Is_Subset (Subset, Of_Set : Discrete_Interval_List)
return Boolean;
-- Returns True iff every value belonging to some interval of
@@ -3006,5 +3167,9 @@ package Sem_Util is
-- rules that reference "is statically compatible" pertain to
-- discriminants and therefore do require support for real types;
-- the exception is 12.5.1(8).
+
+ Intervals_Error : exception;
+ -- Raised when the list of non-empty pair-wise disjoint intervals cannot
+ -- be built.
end Interval_Lists;
end Sem_Util;
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index 04e7acf..b67bb7d 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1165,7 +1165,7 @@ package body Sem_Warn is
if Ekind (E1) = E_Variable
or else
- (Ekind_In (E1, E_Out_Parameter, E_In_Out_Parameter)
+ (Ekind (E1) in E_Out_Parameter | E_In_Out_Parameter
and then not Is_Protected_Type (Current_Scope))
then
-- If the formal has a class-wide type, retrieve its type
@@ -1469,9 +1469,9 @@ package body Sem_Warn is
UR := Original_Node (UR);
loop
- if Nkind_In (UR, N_Expression_With_Actions,
- N_Qualified_Expression,
- N_Type_Conversion)
+ if Nkind (UR) in N_Expression_With_Actions
+ | N_Qualified_Expression
+ | N_Type_Conversion
then
UR := Expression (UR);
@@ -1612,9 +1612,9 @@ package body Sem_Warn is
and then (Is_Object (E1)
or else Is_Type (E1)
or else Ekind (E1) = E_Label
- or else Ekind_In (E1, E_Exception,
- E_Named_Integer,
- E_Named_Real)
+ or else Ekind (E1) in E_Exception
+ | E_Named_Integer
+ | E_Named_Real
or else Is_Overloadable (E1)
-- Package case, if the main unit is a package spec
@@ -1835,7 +1835,7 @@ package body Sem_Warn is
elsif Nkind (Pref) = N_Explicit_Dereference then
return True;
- -- If prefix is itself a component reference or slice check prefix
+ -- If prefix is itself a component reference or slice check prefix
elsif Nkind (Pref) = N_Slice
or else Nkind (Pref) = N_Indexed_Component
@@ -1872,7 +1872,7 @@ package body Sem_Warn is
-- have a reference from generated code, it is bogus (e.g. calls to init
-- procs to set default discriminant values).
- if not Comes_From_Source (N) then
+ if not Comes_From_Source (Original_Node (N)) then
return;
end if;
@@ -1895,7 +1895,7 @@ package body Sem_Warn is
E : constant Entity_Id := Entity (N);
begin
- if Ekind_In (E, E_Variable, E_Out_Parameter)
+ if Ekind (E) in E_Variable | E_Out_Parameter
and then Never_Set_In_Source_Check_Spec (E)
and then not Has_Initial_Value (E)
and then (No (Unset_Reference (E))
@@ -1975,10 +1975,11 @@ package body Sem_Warn is
Nod := Parent (N);
while Present (Nod) loop
if Nkind (Nod) = N_Pragma
- and then Nam_In (Pragma_Name_Unmapped (Nod),
- Name_Postcondition,
- Name_Refined_Post,
- Name_Contract_Cases)
+ and then
+ Pragma_Name_Unmapped (Nod)
+ in Name_Postcondition
+ | Name_Refined_Post
+ | Name_Contract_Cases
then
return True;
@@ -2102,7 +2103,7 @@ package body Sem_Warn is
P := Parent (P);
exit when No (P);
- if Nkind_In (P, N_If_Statement, N_Elsif_Part)
+ if Nkind (P) in N_If_Statement | N_Elsif_Part
and then Ref_In (Condition (P))
then
return;
@@ -2993,6 +2994,13 @@ package body Sem_Warn is
exception
when others =>
+ -- With debug flag K we will get an exception unless an error has
+ -- already occurred (useful for debugging).
+
+ if Debug_Flag_K then
+ Check_Error_Detected;
+ end if;
+
return False;
end Operand_Has_Warnings_Suppressed;
@@ -3181,7 +3189,7 @@ package body Sem_Warn is
-- Reference to obsolescent component
- elsif Ekind_In (E, E_Component, E_Discriminant) then
+ elsif Ekind (E) in E_Component | E_Discriminant then
Error_Msg_NE
("??reference to obsolescent component& declared#", N, E);
@@ -3386,11 +3394,11 @@ package body Sem_Warn is
if True_Result then
Error_Msg_N
- ("condition can only be False if invalid values present??", Op);
+ ("condition can only be False if invalid values present?c?", Op);
elsif False_Result then
Error_Msg_N
- ("condition can only be True if invalid values present??", Op);
+ ("condition can only be True if invalid values present?c?", Op);
end if;
end if;
end Warn_On_Constant_Valid_Condition;
@@ -3520,6 +3528,7 @@ package body Sem_Warn is
if Constant_Condition_Warnings
and then Is_Known_Branch
and then Comes_From_Source (Orig)
+ and then Nkind (Orig) in N_Has_Entity
and then not In_Instance
then
-- Don't warn if comparison of result of attribute against a constant
@@ -3559,8 +3568,9 @@ package body Sem_Warn is
-- node, since assert pragmas get rewritten at analysis time.
elsif Nkind (Original_Node (P)) = N_Pragma
- and then Nam_In (Pragma_Name_Unmapped (Original_Node (P)),
- Name_Assert, Name_Check)
+ and then
+ Pragma_Name_Unmapped (Original_Node (P))
+ in Name_Assert | Name_Check
then
return;
end if;
@@ -3643,9 +3653,6 @@ package body Sem_Warn is
---------------------------------
procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id) is
- function Is_Covered_Formal (Formal : Node_Id) return Boolean;
- -- Return True if Formal is covered by the rule
-
function Refer_Same_Object
(Act1 : Node_Id;
Act2 : Node_Id) return Boolean;
@@ -3658,19 +3665,6 @@ package body Sem_Warn is
-- (RM 6.4.1(6.11/3))
-----------------------
- -- Is_Covered_Formal --
- -----------------------
-
- function Is_Covered_Formal (Formal : Node_Id) return Boolean is
- begin
- return
- Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter)
- and then (Is_Elementary_Type (Etype (Formal))
- or else Is_Record_Type (Etype (Formal))
- or else Is_Array_Type (Etype (Formal)));
- end Is_Covered_Formal;
-
- -----------------------
-- Refer_Same_Object --
-----------------------
@@ -3690,9 +3684,6 @@ package body Sem_Warn is
Act2 : Node_Id;
Form1 : Entity_Id;
Form2 : Entity_Id;
- Warn_Only : Boolean;
- -- GNAT warns on overlapping in-out parameters of any type, not just for
- -- elementary in-out parameters (as specified in RM 6.4.1 (15/3-17/3)).
-- Start of processing for Warn_On_Overlapping_Actuals
@@ -3702,29 +3693,6 @@ package body Sem_Warn is
return;
end if;
- -- The call is illegal only if there are at least two in-out parameters
- -- of the same elementary type.
-
- Warn_Only := True;
- Form1 := First_Formal (Subp);
- while Present (Form1) loop
- Form2 := Next_Formal (Form1);
- while Present (Form2) loop
- if Is_Elementary_Type (Etype (Form1))
- and then Is_Elementary_Type (Etype (Form2))
- and then Ekind (Form1) /= E_In_Parameter
- and then Ekind (Form2) /= E_In_Parameter
- then
- Warn_Only := False;
- exit;
- end if;
-
- Next_Formal (Form2);
- end loop;
-
- Next_Formal (Form1);
- end loop;
-
-- Exclude calls rewritten as enumeration literals
if Nkind (N) not in N_Subprogram_Call
@@ -3738,91 +3706,137 @@ package body Sem_Warn is
-- N that is passed as a parameter of mode in out or out to the call C,
-- there is no other name among the other parameters of mode in out or
-- out to C that is known to denote the same object (RM 6.4.1(6.15/3))
+ -- This has been clarified in AI12-0216 to indicate that the illegality
+ -- only occurs if both formals are of an elementary type, because of the
+ -- nondeterminism on the write-back of the corresponding actuals.
+ -- Earlier versions of the language made it illegal if only one of the
+ -- actuals was an elementary parameter that overlapped a composite
+ -- actual, and both were writable.
-- If appropriate warning switch is set, we also report warnings on
- -- overlapping parameters that are record types or array types.
+ -- overlapping parameters that are composite types. Users find these
+ -- warnings useful, and they are used in style guides.
+
+ -- It is also worthwhile to warn on overlaps of composite objects when
+ -- only one of the formals is (in)-out. Note that the RM rule above is
+ -- a legality rule. We choose to implement this check as a warning to
+ -- avoid major incompatibilities with legacy code.
+
+ -- Note also that the rule in 6.4.1 (6.17/3), introduced by AI12-0324,
+ -- is potentially more expensive to verify, and is not yet implemented.
Form1 := First_Formal (Subp);
Act1 := First_Actual (N);
while Present (Form1) and then Present (Act1) loop
- if Is_Covered_Formal (Form1) then
- Form2 := First_Formal (Subp);
- Act2 := First_Actual (N);
+ if Is_Generic_Type (Etype (Act1)) then
+ return;
+ end if;
+
+ -- One of the formals must be either (in)-out or composite.
+ -- The other must be (in)-out.
+
+ if Is_Elementary_Type (Etype (Act1))
+ and then Ekind (Form1) = E_In_Parameter
+ then
+ null;
+
+ else
+ Form2 := Next_Formal (Form1);
+ Act2 := Next_Actual (Act1);
while Present (Form2) and then Present (Act2) loop
- if Form1 /= Form2
- and then Is_Covered_Formal (Form2)
- and then Refer_Same_Object (Act1, Act2)
- then
- -- Guard against previous errors
+ if Refer_Same_Object (Act1, Act2) then
+ if Is_Generic_Type (Etype (Act2)) then
+ return;
+ end if;
- if Error_Posted (N)
- or else No (Etype (Act1))
- or else No (Etype (Act2))
- then
- null;
+ -- First case : two writable elementary parameters
+ -- that overlap.
- -- If the actual is a function call in prefix notation,
- -- there is no real overlap.
+ if (Is_Elementary_Type (Etype (Form1))
+ and then Is_Elementary_Type (Etype (Form2))
+ and then Ekind (Form1) /= E_In_Parameter
+ and then Ekind (Form2) /= E_In_Parameter)
- elsif Nkind (Act2) = N_Function_Call then
- null;
+ -- Second case : two composite parameters that overlap,
+ -- one of which is writable.
- -- If type is not by-copy, assume that aliasing is intended
+ or else (Is_Composite_Type (Etype (Form1))
+ and then Is_Composite_Type (Etype (Form2))
+ and then (Ekind (Form1) /= E_In_Parameter
+ or else Ekind (Form2) /= E_In_Parameter))
- elsif
- Present (Underlying_Type (Etype (Form1)))
- and then
- (Is_By_Reference_Type (Underlying_Type (Etype (Form1)))
- or else
- Convention (Underlying_Type (Etype (Form1))) =
- Convention_Ada_Pass_By_Reference)
- then
- null;
+ -- Third case : an elementary writable parameter that
+ -- overlaps a composite one.
- -- Under Ada 2012 we only report warnings on overlapping
- -- arrays and record types if switch is set.
+ or else (Is_Elementary_Type (Etype (Form1))
+ and then Ekind (Form1) /= E_In_Parameter
+ and then Is_Composite_Type (Etype (Form2)))
- elsif Ada_Version >= Ada_2012
- and then not Is_Elementary_Type (Etype (Form1))
- and then not Warn_On_Overlap
+ or else (Is_Elementary_Type (Etype (Form2))
+ and then Ekind (Form2) /= E_In_Parameter
+ and then Is_Composite_Type (Etype (Form1)))
then
- null;
- -- Here we may need to issue overlap message
+ -- Guard against previous errors
- else
- Error_Msg_Warn :=
+ if Error_Posted (N)
+ or else No (Etype (Act1))
+ or else No (Etype (Act2))
+ then
+ null;
- -- Overlap checking is an error only in Ada 2012. For
- -- earlier versions of Ada, this is a warning.
+ -- If the actual is a function call in prefix notation,
+ -- there is no real overlap.
- Ada_Version < Ada_2012
+ elsif Nkind (Act2) = N_Function_Call then
+ null;
- -- Overlap is only illegal in Ada 2012 in the case of
- -- elementary types (passed by copy). For other types,
- -- we always have a warning in all Ada versions.
+ -- If type is explicitly not by-copy, assume that
+ -- aliasing is intended.
+
+ elsif
+ Present (Underlying_Type (Etype (Form1)))
+ and then
+ (Is_By_Reference_Type
+ (Underlying_Type (Etype (Form1)))
+ or else
+ Convention (Underlying_Type (Etype (Form1))) =
+ Convention_Ada_Pass_By_Reference)
+ then
+ null;
- or else not Is_Elementary_Type (Etype (Form1))
+ -- Under Ada 2012 we only report warnings on overlapping
+ -- arrays and record types if switch is set.
- -- debug flag -gnatd.E changes the error to a warning
- -- even in Ada 2012 mode.
+ elsif Ada_Version >= Ada_2012
+ and then not Is_Elementary_Type (Etype (Form1))
+ and then not Warn_On_Overlap
+ then
+ null;
- or else Error_To_Warning
- or else Warn_Only;
+ -- Here we may need to issue overlap message
- declare
- Act : Node_Id;
- Form : Entity_Id;
+ else
+ Error_Msg_Warn :=
- begin
- -- Find matching actual
+ -- Overlap checking is an error only in Ada 2012.
+ -- For earlier versions of Ada, this is a warning.
- Act := First_Actual (N);
- Form := First_Formal (Subp);
- while Act /= Act2 loop
- Next_Formal (Form);
- Next_Actual (Act);
- end loop;
+ Ada_Version < Ada_2012
+
+ -- Overlap is only illegal in Ada 2012 in the case
+ -- of elementary types (passed by copy). For other
+ -- types we always have a warning in all versions.
+ -- This is clarified by AI12-0216.
+
+ or else not
+ (Is_Elementary_Type (Etype (Form1))
+ and then Is_Elementary_Type (Etype (Form2)))
+
+ -- debug flag -gnatd.E changes the error to a
+ -- warning even in Ada 2012 mode.
+
+ or else Error_To_Warning;
if Is_Elementary_Type (Etype (Act1))
and then Ekind (Form2) = E_In_Parameter
@@ -3836,12 +3850,12 @@ package body Sem_Warn is
-- If the call was written in prefix notation, and
-- thus its prefix before rewriting was a selected
- -- component, count only visible actuals in the call.
+ -- component, count only visible actuals in call.
elsif Is_Entity_Name (First_Actual (N))
and then Nkind (Original_Node (N)) = Nkind (N)
and then Nkind (Name (Original_Node (N))) =
- N_Selected_Component
+ N_Selected_Component
and then
Is_Entity_Name (Prefix (Name (Original_Node (N))))
and then
@@ -3850,30 +3864,30 @@ package body Sem_Warn is
then
if Act1 = First_Actual (N) then
Error_Msg_FE
- ("<<`IN OUT` prefix overlaps with "
- & "actual for&", Act1, Form);
+ ("<I<`IN OUT` prefix overlaps with "
+ & "actual for&", Act1, Form2);
else
-- For greater clarity, give name of formal
- Error_Msg_Node_2 := Form;
+ Error_Msg_Node_2 := Form2;
Error_Msg_FE
- ("<<writable actual for & overlaps with "
- & "actual for&", Act1, Form);
+ ("<I<writable actual for & overlaps with "
+ & "actual for&", Act1, Form2);
end if;
else
-- For greater clarity, give name of formal
- Error_Msg_Node_2 := Form;
+ Error_Msg_Node_2 := Form2;
-- This is one of the messages
Error_Msg_FE
- ("<<writable actual for & overlaps with "
+ ("<I<writable actual for & overlaps with "
& "actual for&", Act1, Form1);
end if;
- end;
+ end if;
end if;
return;
@@ -4220,7 +4234,7 @@ package body Sem_Warn is
-- Only process if warnings activated
if Warn_On_Suspicious_Contract then
- if Nkind_In (Par, N_Op_Eq, N_Op_Ne) then
+ if Nkind (Par) in N_Op_Eq | N_Op_Ne then
if N = Left_Opnd (Par) then
Arg := Right_Opnd (Par);
else
@@ -4330,11 +4344,10 @@ package body Sem_Warn is
-- the message if the variable is volatile, has an address
-- clause, is aliased, or is a renaming, or is imported.
- if Referenced_As_LHS_Check_Spec (E)
- and then No (Address_Clause (E))
- and then not Is_Volatile (E)
- then
+ if Referenced_As_LHS_Check_Spec (E) then
if Warn_On_Modified_Unread
+ and then No (Address_Clause (E))
+ and then not Is_Volatile (E)
and then not Is_Imported (E)
and then not Is_Aliased (E)
and then No (Renamed_Object (E))
@@ -4411,10 +4424,10 @@ package body Sem_Warn is
B : constant Node_Id := Parent (Parent (Scope (E)));
S : Entity_Id := Empty;
begin
- if Nkind_In (B,
- N_Expression_Function,
- N_Subprogram_Body,
- N_Subprogram_Renaming_Declaration)
+ if Nkind (B) in
+ N_Expression_Function |
+ N_Subprogram_Body |
+ N_Subprogram_Renaming_Declaration
then
S := Corresponding_Spec (B);
end if;
@@ -4576,10 +4589,10 @@ package body Sem_Warn is
-- When we hit a package/subprogram body, issue warning and exit
- elsif Nkind_In (P, N_Entry_Body,
- N_Package_Body,
- N_Subprogram_Body,
- N_Task_Body)
+ elsif Nkind (P) in N_Entry_Body
+ | N_Package_Body
+ | N_Subprogram_Body
+ | N_Task_Body
then
-- Case of assigned value never referenced
@@ -4603,8 +4616,8 @@ package body Sem_Warn is
-- Give appropriate message, distinguishing between
-- assignment statements and out parameters.
- if Nkind_In (Parent (LA), N_Parameter_Association,
- N_Procedure_Call_Statement)
+ if Nkind (Parent (LA)) in N_Parameter_Association
+ | N_Procedure_Call_Statement
then
Error_Msg_NE
("?m?& modified by call, but value might not be "
@@ -4630,8 +4643,8 @@ package body Sem_Warn is
-- Give appropriate message, distinguishing between
-- assignment statements and out parameters.
- if Nkind_In (Parent (LA), N_Procedure_Call_Statement,
- N_Parameter_Association)
+ if Nkind (Parent (LA)) in N_Procedure_Call_Statement
+ | N_Parameter_Association
then
Error_Msg_NE
("?m?& modified by call, but value overwritten #!",
@@ -4662,10 +4675,10 @@ package body Sem_Warn is
-- not generate the warning, since the variable in question
-- may be accessed after an exception in the outer block.
- if not Nkind_In (Parent (P), N_Entry_Body,
- N_Package_Body,
- N_Subprogram_Body,
- N_Task_Body)
+ if Nkind (Parent (P)) not in N_Entry_Body
+ | N_Package_Body
+ | N_Subprogram_Body
+ | N_Task_Body
then
Set_Last_Assignment (Ent, Empty);
return;
@@ -4690,7 +4703,7 @@ package body Sem_Warn is
return;
end if;
- X := Next (X);
+ Next (X);
end loop;
end if;
end if;
diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads
index 8eab90a..5649a16 100644
--- a/gcc/ada/sem_warn.ads
+++ b/gcc/ada/sem_warn.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/set_targ.adb b/gcc/ada/set_targ.adb
index ae4a8c6..d707c12 100644
--- a/gcc/ada/set_targ.adb
+++ b/gcc/ada/set_targ.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2013-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/set_targ.ads b/gcc/ada/set_targ.ads
index 7c7c72c..aa37770 100644
--- a/gcc/ada/set_targ.ads
+++ b/gcc/ada/set_targ.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2013-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sfn_scan.adb b/gcc/ada/sfn_scan.adb
index 377ea19..1283abc 100644
--- a/gcc/ada/sfn_scan.adb
+++ b/gcc/ada/sfn_scan.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sfn_scan.ads b/gcc/ada/sfn_scan.ads
index 14c17f1..824033f 100644
--- a/gcc/ada/sfn_scan.ads
+++ b/gcc/ada/sfn_scan.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sigtramp-armdroid.c b/gcc/ada/sigtramp-armdroid.c
index eb3c74d..9113a6c 100644
--- a/gcc/ada/sigtramp-armdroid.c
+++ b/gcc/ada/sigtramp-armdroid.c
@@ -6,7 +6,7 @@
* *
* Asm Implementation File *
* *
- * Copyright (C) 2015-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2015-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/sigtramp-ios.c b/gcc/ada/sigtramp-ios.c
index de04c1a..7715ddb 100644
--- a/gcc/ada/sigtramp-ios.c
+++ b/gcc/ada/sigtramp-ios.c
@@ -6,7 +6,7 @@
* *
* Asm Implementation File *
* *
- * Copyright (C) 2015-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2015-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/sigtramp-qnx.c b/gcc/ada/sigtramp-qnx.c
index 8fb95b8..d26099f 100644
--- a/gcc/ada/sigtramp-qnx.c
+++ b/gcc/ada/sigtramp-qnx.c
@@ -6,7 +6,7 @@
* *
* Asm Implementation File *
* *
- * Copyright (C) 2017-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2017-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/sigtramp-vxworks.c b/gcc/ada/sigtramp-vxworks.c
index 2172dfe..e0b4503 100644
--- a/gcc/ada/sigtramp-vxworks.c
+++ b/gcc/ada/sigtramp-vxworks.c
@@ -6,7 +6,7 @@
* *
* Asm Implementation File *
* *
- * Copyright (C) 2011-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2011-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/sigtramp.h b/gcc/ada/sigtramp.h
index 0f543f3..719f9b4 100644
--- a/gcc/ada/sigtramp.h
+++ b/gcc/ada/sigtramp.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2011-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2011-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/sinfo-cn.adb b/gcc/ada/sinfo-cn.adb
index 5b21b0d..f2f9b58 100644
--- a/gcc/ada/sinfo-cn.adb
+++ b/gcc/ada/sinfo-cn.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sinfo-cn.ads b/gcc/ada/sinfo-cn.ads
index ed79069..837a753 100644
--- a/gcc/ada/sinfo-cn.ads
+++ b/gcc/ada/sinfo-cn.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb
index 41cb8c8..082f06f 100644
--- a/gcc/ada/sinfo.adb
+++ b/gcc/ada/sinfo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1278,6 +1278,7 @@ package body Sinfo is
or else NT (N).Nkind = N_Expression_With_Actions
or else NT (N).Nkind = N_Free_Statement
or else NT (N).Nkind = N_Iterated_Component_Association
+ or else NT (N).Nkind = N_Iterated_Element_Association
or else NT (N).Nkind = N_Mod_Clause
or else NT (N).Nkind = N_Modular_Type_Definition
or else NT (N).Nkind = N_Number_Declaration
@@ -1523,15 +1524,6 @@ package body Sinfo is
return Flag10 (N);
end Has_Dynamic_Length_Check;
- function Has_Dynamic_Range_Check
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subtype_Declaration
- or else NT (N).Nkind in N_Subexpr);
- return Flag12 (N);
- end Has_Dynamic_Range_Check;
-
function Has_Init_Expression
(N : Node_Id) return Boolean is
begin
@@ -2089,22 +2081,6 @@ package body Sinfo is
return Flag16 (N);
end Is_Null_Loop;
- function Is_OpenAcc_Environment
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Loop_Statement);
- return Flag13 (N);
- end Is_OpenAcc_Environment;
-
- function Is_OpenAcc_Loop
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Loop_Statement);
- return Flag14 (N);
- end Is_OpenAcc_Loop;
-
function Is_Overloaded
(N : Node_Id) return Boolean is
begin
@@ -2121,6 +2097,14 @@ package body Sinfo is
return Flag13 (N);
end Is_Power_Of_2_For_Shift;
+ function Is_Preelaborable_Call
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Call_Marker);
+ return Flag7 (N);
+ end Is_Preelaborable_Call;
+
function Is_Prefixed_Call
(N : Node_Id) return Boolean is
begin
@@ -2240,6 +2224,15 @@ package body Sinfo is
return Flag5 (N);
end Is_Write;
+ function Iterator_Filter
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Iterator_Specification
+ or else NT (N).Nkind = N_Loop_Parameter_Specification);
+ return Node3 (N);
+ end Iterator_Filter;
+
function Iteration_Scheme
(N : Node_Id) return Node_Id is
begin
@@ -2252,6 +2245,8 @@ package body Sinfo is
(N : Node_Id) return Node_Id is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Iterated_Component_Association
+ or else NT (N).Nkind = N_Iterated_Element_Association
or else NT (N).Nkind = N_Iteration_Scheme
or else NT (N).Nkind = N_Quantified_Expression);
return Node2 (N);
@@ -2265,6 +2260,14 @@ package body Sinfo is
return Node1 (N);
end Itype;
+ function Key_Expression
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Iterated_Element_Association);
+ return Node1 (N);
+ end Key_Expression;
+
function Kill_Range_Check
(N : Node_Id) return Boolean is
begin
@@ -2374,14 +2377,16 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Component_Association
- or else NT (N).Nkind = N_Iterated_Component_Association);
- return List2 (N);
+ or else NT (N).Nkind = N_Iterated_Component_Association
+ or else NT (N).Nkind = N_Iterated_Element_Association);
+ return List5 (N);
end Loop_Actions;
function Loop_Parameter_Specification
(N : Node_Id) return Node_Id is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Iterated_Element_Association
or else NT (N).Nkind = N_Iteration_Scheme
or else NT (N).Nkind = N_Quantified_Expression);
return Node4 (N);
@@ -2554,6 +2559,7 @@ package body Sinfo is
or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_Attribute_Definition_Clause
or else NT (N).Nkind = N_Enumeration_Representation_Clause
+ or else NT (N).Nkind = N_Null_Statement
or else NT (N).Nkind = N_Pragma
or else NT (N).Nkind = N_Record_Representation_Clause);
return Node5 (N);
@@ -3411,17 +3417,6 @@ package body Sinfo is
return List2 (N);
end Then_Statements;
- function Treat_Fixed_As_Integer
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Op_Divide
- or else NT (N).Nkind = N_Op_Mod
- or else NT (N).Nkind = N_Op_Multiply
- or else NT (N).Nkind = N_Op_Rem);
- return Flag14 (N);
- end Treat_Fixed_As_Integer;
-
function Triggering_Alternative
(N : Node_Id) return Node_Id is
begin
@@ -4779,6 +4774,7 @@ package body Sinfo is
or else NT (N).Nkind = N_Expression_With_Actions
or else NT (N).Nkind = N_Free_Statement
or else NT (N).Nkind = N_Iterated_Component_Association
+ or else NT (N).Nkind = N_Iterated_Element_Association
or else NT (N).Nkind = N_Mod_Clause
or else NT (N).Nkind = N_Modular_Type_Definition
or else NT (N).Nkind = N_Number_Declaration
@@ -5024,15 +5020,6 @@ package body Sinfo is
Set_Flag10 (N, Val);
end Set_Has_Dynamic_Length_Check;
- procedure Set_Has_Dynamic_Range_Check
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subtype_Declaration
- or else NT (N).Nkind in N_Subexpr);
- Set_Flag12 (N, Val);
- end Set_Has_Dynamic_Range_Check;
-
procedure Set_Has_Init_Expression
(N : Node_Id; Val : Boolean := True) is
begin
@@ -5592,22 +5579,6 @@ package body Sinfo is
Set_Flag16 (N, Val);
end Set_Is_Null_Loop;
- procedure Set_Is_OpenAcc_Environment
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Loop_Statement);
- Set_Flag13 (N, Val);
- end Set_Is_OpenAcc_Environment;
-
- procedure Set_Is_OpenAcc_Loop
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Loop_Statement);
- Set_Flag14 (N, Val);
- end Set_Is_OpenAcc_Loop;
-
procedure Set_Is_Overloaded
(N : Node_Id; Val : Boolean := True) is
begin
@@ -5624,6 +5595,14 @@ package body Sinfo is
Set_Flag13 (N, Val);
end Set_Is_Power_Of_2_For_Shift;
+ procedure Set_Is_Preelaborable_Call
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Call_Marker);
+ Set_Flag7 (N, Val);
+ end Set_Is_Preelaborable_Call;
+
procedure Set_Is_Prefixed_Call
(N : Node_Id; Val : Boolean := True) is
begin
@@ -5745,6 +5724,15 @@ package body Sinfo is
Set_Flag5 (N, Val);
end Set_Is_Write;
+ procedure Set_Iterator_Filter
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Iterator_Specification
+ or else NT (N).Nkind = N_Loop_Parameter_Specification);
+ Set_Node3_With_Parent (N, Val);
+ end Set_Iterator_Filter;
+
procedure Set_Iteration_Scheme
(N : Node_Id; Val : Node_Id) is
begin
@@ -5757,6 +5745,8 @@ package body Sinfo is
(N : Node_Id; Val : Node_Id) is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Iterated_Component_Association
+ or else NT (N).Nkind = N_Iterated_Element_Association
or else NT (N).Nkind = N_Iteration_Scheme
or else NT (N).Nkind = N_Quantified_Expression);
Set_Node2_With_Parent (N, Val);
@@ -5770,6 +5760,14 @@ package body Sinfo is
Set_Node1 (N, Val); -- no parent, semantic field
end Set_Itype;
+ procedure Set_Key_Expression
+ (N : Node_Id; Val : Entity_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Iterated_Element_Association);
+ Set_Node1_With_Parent (N, Val);
+ end Set_Key_Expression;
+
procedure Set_Kill_Range_Check
(N : Node_Id; Val : Boolean := True) is
begin
@@ -5879,14 +5877,16 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Component_Association
- or else NT (N).Nkind = N_Iterated_Component_Association);
- Set_List2 (N, Val); -- semantic field, no parent set
+ or else NT (N).Nkind = N_Iterated_Component_Association
+ or else NT (N).Nkind = N_Iterated_Element_Association);
+ Set_List5 (N, Val); -- semantic field, no parent set
end Set_Loop_Actions;
procedure Set_Loop_Parameter_Specification
(N : Node_Id; Val : Node_Id) is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Iterated_Element_Association
or else NT (N).Nkind = N_Iteration_Scheme
or else NT (N).Nkind = N_Quantified_Expression);
Set_Node4_With_Parent (N, Val);
@@ -6059,6 +6059,7 @@ package body Sinfo is
or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_Attribute_Definition_Clause
or else NT (N).Nkind = N_Enumeration_Representation_Clause
+ or else NT (N).Nkind = N_Null_Statement
or else NT (N).Nkind = N_Pragma
or else NT (N).Nkind = N_Record_Representation_Clause);
Set_Node5 (N, Val); -- semantic field, no parent set
@@ -6916,17 +6917,6 @@ package body Sinfo is
Set_List2_With_Parent (N, Val);
end Set_Then_Statements;
- procedure Set_Treat_Fixed_As_Integer
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Op_Divide
- or else NT (N).Nkind = N_Op_Mod
- or else NT (N).Nkind = N_Op_Multiply
- or else NT (N).Nkind = N_Op_Rem);
- Set_Flag14 (N, Val);
- end Set_Treat_Fixed_As_Integer;
-
procedure Set_Triggering_Alternative
(N : Node_Id; Val : Node_Id) is
begin
@@ -7133,238 +7123,6 @@ package body Sinfo is
UI_From_Int (Int (S) - Int (Sloc (N))));
end Set_End_Location;
- --------------
- -- Nkind_In --
- --------------
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2;
- end Nkind_In;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3;
- end Nkind_In;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4;
- end Nkind_In;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5;
- end Nkind_In;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6;
- end Nkind_In;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7;
- end Nkind_In;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7 or else
- T = V8;
- end Nkind_In;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind;
- V9 : Node_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7 or else
- T = V8 or else
- T = V9;
- end Nkind_In;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind;
- V9 : Node_Kind;
- V10 : Node_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7 or else
- T = V8 or else
- T = V9 or else
- T = V10;
- end Nkind_In;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind;
- V9 : Node_Kind;
- V10 : Node_Kind;
- V11 : Node_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7 or else
- T = V8 or else
- T = V9 or else
- T = V10 or else
- T = V11;
- end Nkind_In;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind;
- V9 : Node_Kind;
- V10 : Node_Kind;
- V11 : Node_Kind;
- V12 : Node_Kind;
- V13 : Node_Kind;
- V14 : Node_Kind;
- V15 : Node_Kind;
- V16 : Node_Kind) return Boolean
- is
- begin
- return T = V1 or else
- T = V2 or else
- T = V3 or else
- T = V4 or else
- T = V5 or else
- T = V6 or else
- T = V7 or else
- T = V8 or else
- T = V9 or else
- T = V10 or else
- T = V11 or else
- T = V12 or else
- T = V13 or else
- T = V14 or else
- T = V15 or else
- T = V16;
- end Nkind_In;
-
--------------------------
-- Pragma_Name_Unmapped --
--------------------------
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 706007b..2583f91 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -381,7 +381,8 @@ package Sinfo is
-- subprogram instance, and the other is an anonymous subprogram nested
-- within a wrapper package that contains the renamings for the actuals.
-- Both of these entities have the Sloc of the defining entity in the
- -- instantiation node. This simplifies some ASIS queries.
+ -- instantiation node. This simplified for instance in the past some ASIS
+ -- queries.
-----------------------
-- Field Definitions --
@@ -398,10 +399,6 @@ package Sinfo is
-- (defined in Tree_Print_Strings) used to print trees. The following
-- abbreviations are used:
- -- Note: the utility program that creates the Treeprs spec (in the file
- -- xtreeprs.adb) knows about the special fields here, so it must be
- -- modified if any change is made to these fields.
-
-- "plus fields for binary operator"
-- Chars (Name1) Name_Id for the operator
-- Left_Opnd (Node2) left operand expression
@@ -428,10 +425,13 @@ package Sinfo is
-- Must_Not_Freeze (Flag8-Sem) set if must not freeze
-- Do_Range_Check (Flag9-Sem) set if a range check needed
-- Has_Dynamic_Length_Check (Flag10-Sem) set if length check inserted
- -- Has_Dynamic_Range_Check (Flag12-Sem) set if range check inserted
-- Assignment_OK (Flag15-Sem) set if modification is OK
-- Is_Controlling_Actual (Flag16-Sem) set for controlling argument
+ -- Note: the utility program that creates the Treeprs spec (in the file
+ -- xtreeprs.adb) knows about the special fields here, so it must be
+ -- modified if any change is made to these fields.
+
-- Note: see under (EXPRESSION) for further details on the use of
-- the Paren_Count field to record the number of parentheses levels.
@@ -458,72 +458,6 @@ package Sinfo is
-- code is being generated, since they involved expander actions that
-- destroy the tree.
- ---------------
- -- ASIS Mode --
- ---------------
-
- -- When a file is compiled in ASIS mode (-gnatct), expansion is skipped,
- -- and the analysis must generate a tree in a form that meets all ASIS
- -- requirements.
-
- -- ASIS must be able to recover the original tree that corresponds to the
- -- source. It relies heavily on Original_Node for this purpose, which as
- -- described in Atree, records the history when a node is rewritten. ASIS
- -- uses Original_Node to recover the original node before the Rewrite.
-
- -- At least in ASIS mode (not really important in non-ASIS mode), when
- -- N1 is rewritten as N2:
-
- -- The subtree rooted by the original node N1 should be fully decorated,
- -- i.e. all semantic fields noted in sinfo.ads should be set properly
- -- and any referenced entities should be complete (with exceptions for
- -- representation information, noted below).
-
- -- For all the direct descendants of N1 (original node) their Parent
- -- links should point not to N1, but to N2 (rewriting node).
-
- -- The Parent links of rewritten nodes (N1 in this example) are set in
- -- some cases (to point to the rewritten parent), but in other cases
- -- they are set to Empty. This needs sorting out ??? It would be much
- -- cleaner if they could always be set in the original node ???
-
- -- There are a few cases when ASIS has to use not the original, but the
- -- rewritten tree structures. This happens when because of some important
- -- technical reasons it is impossible or very hard to have the original
- -- structure properly decorated by semantic information, and the rewritten
- -- structure fully reproduces the original source. Below is the (incomplete
- -- for the moment???) list of such exceptions:
- --
- -- Generic specifications and generic bodies
- -- Function calls that use prefixed notation (Operand.Operation [(...)])
-
- -- Representation Information
-
- -- For the purposes of the data description annex, the representation
- -- information for source declared entities must be complete in the
- -- ASIS tree.
-
- -- This requires that the front end call the back end (gigi/gcc) in
- -- a special "back annotate only" mode to obtain information on layout
- -- from the back end.
-
- -- For the purposes of this special "back annotate only" mode, the
- -- requirements that would normally need to be met to generate code
- -- are relaxed as follows:
-
- -- Anonymous types need not have full representation information (e.g.
- -- sizes need not be set for types where the front end would normally
- -- set the sizes), since anonymous types can be ignored in this mode.
-
- -- In this mode, gigi will see at least fragments of a fully annotated
- -- unexpanded tree. This means that it will encounter nodes it does
- -- not normally handle (such as stubs, task bodies etc). It should
- -- simply ignore these nodes, since they are not relevant to the task
- -- of back annotating representation information.
-
- -- Some other ASIS-specific issues are covered in specific comments in
- -- sections for particular nodes or flags.
-
----------------
-- Ghost Mode --
----------------
@@ -750,15 +684,15 @@ package Sinfo is
-- These three flags are always set by the front end during semantic
-- analysis, on expression nodes that may trigger the corresponding
-- check. The front end then inserts or not the check during expansion. In
- -- particular, these flags should also be correctly set in ASIS mode and
- -- GNATprove mode. As a special case, the front end does not insert a
- -- Do_Division_Check flag on float exponentiation expressions, for the case
- -- where the value is 0.0 and the exponent is negative, although this case
- -- does lead to a division check failure. As another special case,
- -- the front end does not insert a Do_Range_Check on an allocator where
- -- the designated type is scalar, and the designated type is more
- -- constrained than the type of the initialized allocator value or the type
- -- of the default value for an uninitialized allocator.
+ -- particular, these flags should also be correctly set in GNATprove mode.
+ -- As a special case, the front end does not insert a Do_Division_Check
+ -- flag on float exponentiation expressions, for the case where the value
+ -- is 0.0 and the exponent is negative, although this case does lead to a
+ -- division check failure. As another special case, the front end does not
+ -- insert a Do_Range_Check on an allocator where the designated type is
+ -- scalar, and the designated type is more constrained than the type of the
+ -- initialized allocator value or the type of the default value for an
+ -- uninitialized allocator.
-- Note that the expander always takes care of the Do_Range_Check case, so
-- this flag will never be set in the expanded tree passed to the back end.
@@ -1083,8 +1017,8 @@ package Sinfo is
-- A flag set on type conversion nodes to indicate that the conversion
-- is to be considered as being valid, even though it is the case that
-- the conversion is not valid Ada. This is used for attributes Enum_Rep,
- -- Fixed_Value and Integer_Value, for internal conversions done for
- -- fixed-point operations, and for certain conversions for calls to
+ -- Pos, Val, Fixed_Value and Integer_Value, for internal conversions done
+ -- for fixed-point operations, and for certain conversions for calls to
-- initialization procedures. If Conversion_OK is set, then Etype must be
-- set (the analyzer assumes that Etype has been set). For the case of
-- fixed-point operands, it also indicates that the conversion is to be
@@ -1095,7 +1029,7 @@ package Sinfo is
-- Present in N_Raise_Expression nodes that appear in the body of the
-- special predicateM function used to test a predicate in the context
-- of a membership test, where raise expression results in returning a
- -- value of False rather than raising an exception.
+ -- value of False rather than raising an exception.???obsolete flag
-- Corresponding_Aspect (Node3-Sem)
-- Present in N_Pragma node. Used to point back to the source aspect from
@@ -1120,8 +1054,7 @@ package Sinfo is
-- map generic formals to their actuals. If set, the field points either
-- to a copy of a default expression for an actual of mode IN or to a
-- generic_association which is the original parent of the expression or
- -- name appearing in the declaration. This simplifies ASIS and GNATprove
- -- queries.
+ -- name appearing in the declaration. This simplifies GNATprove queries.
-- Corresponding_Integer_Value (Uint4-Sem)
-- This field is set in real literals of fixed-point types (it is not
@@ -1487,8 +1420,7 @@ package Sinfo is
-- attribute is a function call (possibly dereferenced) that corresponds
-- to the proper expansion of the source indexing operation. Before
-- expansion, the source node is rewritten as the resolved generalized
- -- indexing. In ASIS mode, the expansion does not take place, so that
- -- the source is preserved and properly annotated with types.
+ -- indexing.
-- Generic_Parent (Node5-Sem)
-- Generic_Parent is defined on declaration nodes that are instances. The
@@ -1523,14 +1455,6 @@ package Sinfo is
-- action which has been inserted at the flagged node. This is used to
-- avoid the generation of duplicate checks.
- -- Has_Dynamic_Range_Check (Flag12-Sem)
- -- This flag is present in N_Subtype_Declaration nodes and on all
- -- expression nodes. It is set to indicate that one of the routines in
- -- unit Checks has generated a range check action which has been inserted
- -- at the flagged node. This is used to avoid the generation of duplicate
- -- checks. Why does this occur on N_Subtype_Declaration nodes, what does
- -- it mean in that context???
-
-- Has_Local_Raise (Flag8-Sem)
-- Present in exception handler nodes. Set if the handler can be entered
-- via a local raise that gets transformed to a goto statement. This will
@@ -1838,7 +1762,7 @@ package Sinfo is
-- Test_Case
-- Is_Homogeneous_Aggregate (Flag14)
- -- A flag set on an Ada2020 aggregate that uses square brackets as
+ -- A flag set on an Ada 2020 aggregate that uses square brackets as
-- delimiters, and thus denotes an array or container aggregate, or
-- the prefix of a reduction attribute.
@@ -1908,14 +1832,6 @@ package Sinfo is
-- can be determined to be null at compile time. This is used to remove
-- the loop entirely at expansion time.
- -- Is_OpenAcc_Environment (Flag13-Sem)
- -- This flag is set in an N_Loop_Statement node if it contains an
- -- Acc_Data, Acc_Parallel or Add_Kernels pragma.
-
- -- Is_OpenAcc_Loop (Flag14-Sem)
- -- This flag is set in an N_Loop_Statement node if it contains an
- -- OpenAcc_Loop pragma.
-
-- Is_Overloaded (Flag5-Sem)
-- A flag present in all expression nodes. Used temporarily during
-- overloading determination. The setting of this flag is not relevant
@@ -1933,6 +1849,10 @@ package Sinfo is
-- conditions holds, and the flag is set, then the division or
-- multiplication can be (and is) converted to a shift.
+ -- Is_Preelaborable_Call (Flag7-Sem)
+ -- Present in call marker nodes. Set when the related call is non-static
+ -- but preelaborable.
+
-- Is_Prefixed_Call (Flag17-Sem)
-- This flag is set in a selected component within a generic unit, if
-- it resolves to a prefixed call to a primitive operation. The flag
@@ -2028,10 +1948,9 @@ package Sinfo is
-- Label_Construct (Node2-Sem)
-- Used in an N_Implicit_Label_Declaration node. Refers to an N_Label,
-- N_Block_Statement or N_Loop_Statement node to which the label
- -- declaration applies. This attribute is used both in the compiler and
- -- in the implementation of ASIS queries. The field is left empty for the
- -- special labels generated as part of expanding raise statements with a
- -- local exception handler.
+ -- declaration applies. The field is left empty for the special labels
+ -- generated as part of expanding raise statements with a local exception
+ -- handler.
-- Library_Unit (Node4-Sem)
-- In a stub node, Library_Unit points to the compilation unit node of
@@ -2074,7 +1993,7 @@ package Sinfo is
-- N_Raise_xxx_Error nodes since the transformation of these nodes is
-- handled by the back end (using the N_Push/N_Pop mechanism).
- -- Loop_Actions (List2-Sem)
+ -- Loop_Actions (List5-Sem)
-- A list present in Component_Association nodes in array aggregates.
-- Used to collect actions that must be executed within the loop because
-- they may need to be evaluated anew each time through.
@@ -2162,9 +2081,9 @@ package Sinfo is
-- Next_Rep_Item (Node5-Sem)
-- Present in pragma nodes, attribute definition nodes, enumeration rep
- -- clauses, record rep clauses, aspect specification nodes. Used to link
- -- representation items that apply to an entity. See full description of
- -- First_Rep_Item field in Einfo for further details.
+ -- clauses, record rep clauses, aspect specification and null statement
+ -- nodes. Used to link representation items that apply to an entity. See
+ -- full description of First_Rep_Item field in Einfo for further details.
-- Next_Use_Clause (Node3-Sem)
-- While use clauses are active during semantic processing, they are
@@ -2251,7 +2170,7 @@ package Sinfo is
-- Original_Entity is empty. This field is needed to handle properly
-- named numbers in generic units, where the Associated_Node field
-- interferes with the Entity field, making it impossible to preserve the
- -- original entity at the point of instantiation (ASIS problem).
+ -- original entity at the point of instantiation.
-- Others_Discrete_Choices (List1-Sem)
-- When a case statement or variant is analyzed, the semantic checks
@@ -2289,8 +2208,8 @@ package Sinfo is
-- values, this expression evaluates to False (zero) if variant is not
-- present, and True (non-zero) if it is present. See unit Repinfo for
-- further details on gigi back annotation. This field is used during
- -- ASIS processing (data decomposition annex) to determine if a field is
- -- present or not.
+ -- back-annotation processing (for -gnatR -gnatc) to determine if a field
+ -- is present or not.
-- Prev_Use_Clause (Node1-Sem)
-- Present in both N_Use_Package_Clause and N_Use_Type_Clause. Used in
@@ -2451,20 +2370,6 @@ package Sinfo is
-- need for this field, so in the tree passed to Gigi, this field is
-- always set to No_List.
- -- Treat_Fixed_As_Integer (Flag14-Sem)
- -- This flag appears in operator nodes for divide, multiply, mod, and rem
- -- on fixed-point operands. It indicates that the operands are to be
- -- treated as integer values, ignoring small values. This flag is only
- -- set as a result of expansion of fixed-point operations. Typically a
- -- fixed-point multiplication in the source generates subsidiary
- -- multiplication and division operations that work with the underlying
- -- integer values and have this flag set. Note that this flag is not
- -- needed on other arithmetic operations (add, neg, subtract etc.) since
- -- in these cases it is always the case that fixed is treated as integer.
- -- The Etype field MUST be set if this flag is set. The analyzer knows to
- -- leave such nodes alone, and whoever makes them must set the correct
- -- Etype value.
-
-- TSS_Elist (Elist3-Sem)
-- Present in N_Freeze_Entity nodes. Holds an element list containing
-- entries for each TSS (type support subprogram) associated with the
@@ -2516,10 +2421,7 @@ package Sinfo is
-- Was_Expression_Function (Flag18-Sem)
-- Present in N_Subprogram_Body. True if the original source had an
-- N_Expression_Function, which was converted to the N_Subprogram_Body
- -- by Analyze_Expression_Function. This is needed by ASIS to correctly
- -- recreate the expression function (for the instance body) when the
- -- completion of a generic function declaration is an expression
- -- function.
+ -- by Analyze_Expression_Function.
-- Was_Originally_Stub (Flag13-Sem)
-- This flag is set in the node for a proper body that replaces stub.
@@ -2959,7 +2861,6 @@ package Sinfo is
-- Subtype_Indication (Node5)
-- Generic_Parent_Type (Node4-Sem) (set for an actual derived type).
-- Exception_Junk (Flag8-Sem)
- -- Has_Dynamic_Range_Check (Flag12-Sem)
-------------------------------
-- 3.2.2 Subtype Indication --
@@ -3711,9 +3612,7 @@ package Sinfo is
-- Note: in the list of Discrete_Choices, the tree passed to the back
-- end does not have choice entries corresponding to names of statically
-- predicated subtypes. Such entries are always expanded out to the list
- -- of equivalent values or ranges. The ASIS tree generated in -gnatct
- -- mode also has this expansion, but done with a proper Rewrite call on
- -- the N_Variant node so that ASIS can properly retrieve the original.
+ -- of equivalent values or ranges.
---------------------------------
-- 3.8.1 Discrete Choice List --
@@ -4224,8 +4123,8 @@ package Sinfo is
-- N_Component_Association
-- Sloc points to first selector name
-- Choices (List1)
- -- Loop_Actions (List2-Sem)
-- Expression (Node3) (empty if Box_Present)
+ -- Loop_Actions (List5-Sem)
-- Box_Present (Flag15)
-- Inherited_Discriminant (Flag13)
@@ -4323,9 +4222,10 @@ package Sinfo is
-- N_Iterated_Component_Association
-- Sloc points to FOR
-- Defining_Identifier (Node1)
- -- Loop_Actions (List2-Sem)
+ -- Iterator_Specification (Node2) (set to Empty if no Iterator_Spec)
-- Expression (Node3)
-- Discrete_Choices (List4)
+ -- Loop_Actions (List5-Sem)
-- Box_Present (Flag15)
-- Note that Box_Present is always False, but it is intentionally added
@@ -4339,6 +4239,27 @@ package Sinfo is
-- Sloc points to left parenthesis
-- Expression (Node3)
-- Component_Associations (List2)
+ -- Etype (Node5-Sem)
+
+ ---------------------------------
+ -- 3.4.5 Comtainer_Aggregates --
+ ---------------------------------
+
+ -- N_Iterated_Element_Association
+ -- Key_Expression (Node1)
+ -- Iterator_Specification (Node2)
+ -- Expression (Node3)
+ -- Loop_Parameter_Specification (Node4)
+ -- Loop_Actions (List5-Sem)
+
+ -- Exactly one of Iterator_Specification or Loop_Parameter_
+ -- specification is present. If the Key_Expression is absent,
+ -- the construct is parsed as an Iterated_Component_Association,
+ -- and legality checks are performed during semantic analysis.
+
+ -- Both iterated associations are Ada2020 features that are
+ -- expanded during aggregate construction, and do not appear in
+ -- expanded code.
--------------------------------------------------
-- 4.4 Expression/Relation/Term/Factor/Primary --
@@ -4527,20 +4448,13 @@ package Sinfo is
-- HIGHEST_PRECEDENCE_OPERATOR ::= ** | abs | not
- -- Sprint syntax if Treat_Fixed_As_Integer is set:
-
- -- x #* y
- -- x #/ y
- -- x #mod y
- -- x #rem y
-
- -- Gigi restriction: For * / mod rem with fixed-point operands, Gigi
- -- will only be given nodes with the Treat_Fixed_As_Integer flag set.
- -- All handling of smalls for multiplication and division is handled
- -- by the front end (mod and rem result only from expansion). Gigi
- -- thus never needs to worry about small values (for other operators
- -- operating on fixed-point, e.g. addition, the small value does not
- -- have any semantic effect anyway, these are always integer operations.
+ -- Gigi restriction: Gigi will never be given * / mod rem nodes with
+ -- fixed-point operands. All handling of smalls for multiplication and
+ -- division is handled by the front end (mod and rem result only from
+ -- expansion). Gigi thus never needs to worry about small values (for
+ -- other operators operating on fixed-point, e.g. addition, the small
+ -- value does not have any semantic effect anyway, these are always
+ -- integer operations).
-- Gigi restriction: For all operators taking Boolean operands, the
-- type is always Standard.Boolean. The expander inserts the required
@@ -4613,14 +4527,12 @@ package Sinfo is
-- N_Op_Multiply
-- Sloc points to *
- -- Treat_Fixed_As_Integer (Flag14-Sem)
-- Rounded_Result (Flag18-Sem)
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Divide
-- Sloc points to /
- -- Treat_Fixed_As_Integer (Flag14-Sem)
-- Do_Division_Check (Flag13-Sem)
-- Rounded_Result (Flag18-Sem)
-- plus fields for binary operator
@@ -4628,14 +4540,12 @@ package Sinfo is
-- N_Op_Mod
-- Sloc points to MOD
- -- Treat_Fixed_As_Integer (Flag14-Sem)
-- Do_Division_Check (Flag13-Sem)
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Rem
-- Sloc points to REM
- -- Treat_Fixed_As_Integer (Flag14-Sem)
-- Do_Division_Check (Flag13-Sem)
-- plus fields for binary operator
-- plus fields for expression
@@ -4672,9 +4582,7 @@ package Sinfo is
-- the semantics is to treat these simply as integer operations, with
-- the small values being ignored (the bounds are already stored in
-- units of small, so that constraint checking works as usual). For the
- -- case of multiply/divide/rem/mod operations, Gigi will only see fixed
- -- point operands if the Treat_Fixed_As_Integer flag is set and will
- -- thus treat these nodes in identical manner, ignoring small values.
+ -- case of multiply/divide/rem/mod operations, Gigi will never see them.
-- Note on equality/inequality tests for records. In the expanded tree,
-- record comparisons are always expanded to be a series of component
@@ -4757,6 +4665,7 @@ package Sinfo is
-- Sloc points to CASE
-- Expression (Node3) (the selecting expression)
-- Alternatives (List4) (the case expression alternatives)
+ -- Etype (Node5-Sem)
-- Do_Overflow_Check (Flag17-Sem)
----------------------------------------
@@ -4959,6 +4868,7 @@ package Sinfo is
-- N_Null_Statement
-- Sloc points to NULL
+ -- Next_Rep_Item (Node5-Sem)
----------------
-- 5.1 Label --
@@ -5118,8 +5028,7 @@ package Sinfo is
-- Note: in the list of Discrete_Choices, the tree passed to the back
-- end does not have choice entries corresponding to names of statically
-- predicated subtypes. Such entries are always expanded out to the list
- -- of equivalent values or ranges. The ASIS tree generated in -gnatct
- -- mode does not have this expansion, and has the original choices.
+ -- of equivalent values or ranges.
-------------------------
-- 5.5 Loop Statement --
@@ -5153,8 +5062,6 @@ package Sinfo is
-- Iteration_Scheme (Node2) (set to Empty if no iteration scheme)
-- Statements (List3)
-- End_Label (Node4)
- -- Is_OpenAcc_Environment (Flag13-Sem)
- -- Is_OpenAcc_Loop (Flag14-Sem)
-- Has_Created_Identifier (Flag15)
-- Is_Null_Loop (Flag16)
-- Suppress_Loop_Warnings (Flag17)
@@ -5196,11 +5103,15 @@ package Sinfo is
-- LOOP_PARAMETER_SPECIFICATION ::=
-- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
+ -- [Iterator_Filter]
+
+ -- Note; the optional Iterator_Filter is an Ada_2020 construct.
-- N_Loop_Parameter_Specification
-- Sloc points to first identifier
-- Defining_Identifier (Node1)
-- Reverse_Present (Flag15)
+ -- Iterator_Filter (Node3) (set to Empty if not present)
-- Discrete_Subtype_Definition (Node4)
-----------------------------------
@@ -5217,6 +5128,7 @@ package Sinfo is
-- Name (Node2)
-- Reverse_Present (Flag15)
-- Of_Present (Flag16)
+ -- Iterator_Filter (Node3) (set to Empty if not present)
-- Subtype_Indication (Node5)
-- Note: The Of_Present flag distinguishes the two forms
@@ -6796,8 +6708,7 @@ package Sinfo is
-- limited with clause is changed into a normal with clause, because we
-- are not prepared to deal with limited with in the context of Rtsfind.
-- So in this case, the Limited_Present flag will be False in the final
- -- tree. However, we do NOT do this transformation in ASIS mode, so for
- -- ASIS the flag will remain set in this situation.
+ -- tree.
----------------------
-- With_Type clause --
@@ -7950,6 +7861,7 @@ package Sinfo is
-- Is_Source_Call (Flag4-Sem)
-- Is_Declaration_Level_Node (Flag5-Sem)
-- Is_Dispatching_Call (Flag6-Sem)
+ -- Is_Preelaborable_Call (Flag7-Sem)
-- Is_Known_Guaranteed_ABE (Flag18-Sem)
------------------------
@@ -8109,9 +8021,18 @@ package Sinfo is
-- executing all the actions.
-- If the actions contain declarations, then these declarations may
- -- be referenced within the expression. However note that there is
- -- no proper scope associated with the expression-with-action, so the
- -- back-end will elaborate them in the context of the enclosing scope.
+ -- be referenced within the expression.
+
+ -- (AI12-0236-1): In Ada 2020, for a declare_expression, the parser
+ -- generates an N_Expression_With_Actions. Declare_expressions have
+ -- various restrictions, which we do not enforce on
+ -- N_Expression_With_Actions nodes that are generated by the
+ -- expander. The two cases can be distinguished by looking at
+ -- Comes_From_Source.
+
+ -- ???Perhaps we should change the name of this node to
+ -- N_Declare_Expression, and perhaps we should change the Sprint syntax
+ -- to match the RM syntax for declare_expression.
-- Sprint syntax: do
-- action;
@@ -8707,7 +8628,7 @@ package Sinfo is
N_Op_Expon,
N_Op_Subtract,
- -- N_Binary_Op, N_Op, N_Subexpr, N_Has_Treat_Fixed_As_Integer
+ -- N_Binary_Op, N_Op, N_Subexpr,
-- N_Has_Etype, N_Has_Chars, N_Has_Entity, N_Multiplying_Operator
N_Op_Divide,
@@ -9016,6 +8937,7 @@ package Sinfo is
N_Handled_Sequence_Of_Statements,
N_Index_Or_Discriminant_Constraint,
N_Iterated_Component_Association,
+ N_Iterated_Element_Association,
N_Itype_Reference,
N_Label,
N_Modular_Type_Definition,
@@ -9115,10 +9037,6 @@ package Sinfo is
N_Error ..
N_Subtype_Indication;
- subtype N_Has_Treat_Fixed_As_Integer is Node_Kind range
- N_Op_Divide ..
- N_Op_Rem;
-
subtype N_Multiplying_Operator is Node_Kind range
N_Op_Divide ..
N_Op_Rem;
@@ -9702,9 +9620,6 @@ package Sinfo is
function Has_Dynamic_Length_Check
(N : Node_Id) return Boolean; -- Flag10
- function Has_Dynamic_Range_Check
- (N : Node_Id) return Boolean; -- Flag12
-
function Has_Init_Expression
(N : Node_Id) return Boolean; -- Flag14
@@ -9888,18 +9803,15 @@ package Sinfo is
function Is_Null_Loop
(N : Node_Id) return Boolean; -- Flag16
- function Is_OpenAcc_Environment
- (N : Node_Id) return Boolean; -- Flag13
-
- function Is_OpenAcc_Loop
- (N : Node_Id) return Boolean; -- Flag14
-
function Is_Overloaded
(N : Node_Id) return Boolean; -- Flag5
function Is_Power_Of_2_For_Shift
(N : Node_Id) return Boolean; -- Flag13
+ function Is_Preelaborable_Call
+ (N : Node_Id) return Boolean; -- Flag7
+
function Is_Prefixed_Call
(N : Node_Id) return Boolean; -- Flag17
@@ -9942,12 +9854,18 @@ package Sinfo is
function Iteration_Scheme
(N : Node_Id) return Node_Id; -- Node2
+ function Iterator_Filter
+ (N : Node_Id) return Node_Id; -- Node3
+
function Iterator_Specification
(N : Node_Id) return Node_Id; -- Node2
function Itype
(N : Node_Id) return Entity_Id; -- Node1
+ function Key_Expression
+ (N : Node_Id) return Node_Id; -- Node1
+
function Kill_Range_Check
(N : Node_Id) return Boolean; -- Flag11
@@ -9982,7 +9900,7 @@ package Sinfo is
(N : Node_Id) return Elist_Id; -- Elist1
function Loop_Actions
- (N : Node_Id) return List_Id; -- List2
+ (N : Node_Id) return List_Id; -- List5
function Loop_Parameter_Specification
(N : Node_Id) return Node_Id; -- Node4
@@ -10296,9 +10214,6 @@ package Sinfo is
function Then_Statements
(N : Node_Id) return List_Id; -- List2
- function Treat_Fixed_As_Integer
- (N : Node_Id) return Boolean; -- Flag14
-
function Triggering_Alternative
(N : Node_Id) return Node_Id; -- Node1
@@ -10817,9 +10732,6 @@ package Sinfo is
procedure Set_Has_Dynamic_Length_Check
(N : Node_Id; Val : Boolean := True); -- Flag10
- procedure Set_Has_Dynamic_Range_Check
- (N : Node_Id; Val : Boolean := True); -- Flag12
-
procedure Set_Has_Init_Expression
(N : Node_Id; Val : Boolean := True); -- Flag14
@@ -11003,18 +10915,15 @@ package Sinfo is
procedure Set_Is_Null_Loop
(N : Node_Id; Val : Boolean := True); -- Flag16
- procedure Set_Is_OpenAcc_Environment
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Is_OpenAcc_Loop
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
procedure Set_Is_Overloaded
(N : Node_Id; Val : Boolean := True); -- Flag5
procedure Set_Is_Power_Of_2_For_Shift
(N : Node_Id; Val : Boolean := True); -- Flag13
+ procedure Set_Is_Preelaborable_Call
+ (N : Node_Id; Val : Boolean := True); -- Flag7
+
procedure Set_Is_Prefixed_Call
(N : Node_Id; Val : Boolean := True); -- Flag17
@@ -11054,6 +10963,9 @@ package Sinfo is
procedure Set_Is_Write
(N : Node_Id; Val : Boolean := True); -- Flag5
+ procedure Set_Iterator_Filter
+ (N : Node_Id; Val : Node_Id); -- Node3
+
procedure Set_Iteration_Scheme
(N : Node_Id; Val : Node_Id); -- Node2
@@ -11063,6 +10975,9 @@ package Sinfo is
procedure Set_Itype
(N : Node_Id; Val : Entity_Id); -- Node1
+ procedure Set_Key_Expression
+ (N : Node_Id; Val : Node_Id); -- Node1
+
procedure Set_Kill_Range_Check
(N : Node_Id; Val : Boolean := True); -- Flag11
@@ -11097,7 +11012,7 @@ package Sinfo is
(N : Node_Id; Val : Elist_Id); -- Elist1
procedure Set_Loop_Actions
- (N : Node_Id; Val : List_Id); -- List2
+ (N : Node_Id; Val : List_Id); -- List5
procedure Set_Loop_Parameter_Specification
(N : Node_Id; Val : Node_Id); -- Node4
@@ -11411,9 +11326,6 @@ package Sinfo is
procedure Set_Then_Statements
(N : Node_Id; Val : List_Id); -- List2
- procedure Set_Treat_Fixed_As_Integer
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
procedure Set_Triggering_Alternative
(N : Node_Id; Val : Node_Id); -- Node1
@@ -11498,135 +11410,6 @@ package Sinfo is
-- for the argument. This is Arg itself, or, in the case where Arg is a
-- pragma argument association node, the expression from this node.
- --------------------------------
- -- Node_Kind Membership Tests --
- --------------------------------
-
- -- The following functions allow a convenient notation for testing whether
- -- a Node_Kind value matches any one of a list of possible values. In each
- -- case True is returned if the given T argument is equal to any of the V
- -- arguments. Note that there is a similar set of functions defined in
- -- Atree where the first argument is a Node_Id whose Nkind field is tested.
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind) return Boolean;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind) return Boolean;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind) return Boolean;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind) return Boolean;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind) return Boolean;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind) return Boolean;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind) return Boolean;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind;
- V9 : Node_Kind) return Boolean;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind;
- V9 : Node_Kind;
- V10 : Node_Kind) return Boolean;
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind;
- V9 : Node_Kind;
- V10 : Node_Kind;
- V11 : Node_Kind) return Boolean;
-
- -- 12..15-parameter versions are not yet needed
-
- function Nkind_In
- (T : Node_Kind;
- V1 : Node_Kind;
- V2 : Node_Kind;
- V3 : Node_Kind;
- V4 : Node_Kind;
- V5 : Node_Kind;
- V6 : Node_Kind;
- V7 : Node_Kind;
- V8 : Node_Kind;
- V9 : Node_Kind;
- V10 : Node_Kind;
- V11 : Node_Kind;
- V12 : Node_Kind;
- V13 : Node_Kind;
- V14 : Node_Kind;
- V15 : Node_Kind;
- V16 : Node_Kind) return Boolean;
-
- pragma Inline (Nkind_In);
- -- Inline all above functions
-
-----------------------
-- Utility Functions --
-----------------------
@@ -12003,20 +11786,27 @@ package Sinfo is
N_Component_Association =>
(1 => True, -- Choices (List1)
- 2 => False, -- Loop_Actions (List2-Sem)
+ 2 => False, -- unused
3 => True, -- Expression (Node3)
4 => False, -- unused
- 5 => False), -- unused
+ 5 => True), -- Loop_Actions (List5-Sem);
N_Iterated_Component_Association =>
(1 => True, -- Defining_Identifier (Node1)
- 2 => True, -- Loop_Actions (List2-Sem)
+ 2 => True, -- Iterator_Specification
3 => True, -- Expression (Node3)
4 => True, -- Discrete_Choices (List4)
- 5 => False), -- unused
+ 5 => True), -- Loop_Actions (List5-Sem);
+
+ N_Iterated_Element_Association =>
+ (1 => True, -- Key_expression
+ 2 => True, -- Iterator_Specification
+ 3 => True, -- Expression (Node3)
+ 4 => True, -- Loop_Parameter_Specification
+ 5 => True), -- Loop_Actions (List5-Sem);
N_Delta_Aggregate =>
- (1 => False, -- Expressions (List1-Sem)
+ (1 => False, -- Unused
2 => True, -- Component_Associations (List2)
3 => True, -- Expression (Node3)
4 => False, -- Unused
@@ -12230,7 +12020,7 @@ package Sinfo is
2 => True, -- Iterator_Specification (Node2)
3 => False, -- unused
4 => True, -- Loop_Parameter_Specification (Node4)
- 5 => False), -- Etype (Node5-Sem)
+ 5 => False), -- unused
N_Allocator =>
(1 => False, -- Storage_Pool (Node1-Sem)
@@ -12286,7 +12076,7 @@ package Sinfo is
2 => False, -- unused
3 => True, -- Expression (Node3)
4 => True, -- Alternatives (List4)
- 5 => False), -- unused
+ 5 => False), -- Etype (Node5-Sem)
N_Case_Expression_Alternative =>
(1 => False, -- Actions (List1-Sem)
@@ -12328,7 +12118,7 @@ package Sinfo is
2 => False, -- unused
3 => False, -- unused
4 => True, -- Discrete_Subtype_Definition (Node4)
- 5 => False), -- unused
+ 5 => True), -- Iterator_Filter (Node5)
N_Iterator_Specification =>
(1 => True, -- Defining_Identifier (Node1)
@@ -13479,7 +13269,6 @@ package Sinfo is
pragma Inline (Has_Created_Identifier);
pragma Inline (Has_Dereference_Action);
pragma Inline (Has_Dynamic_Length_Check);
- pragma Inline (Has_Dynamic_Range_Check);
pragma Inline (Has_Init_Expression);
pragma Inline (Has_Local_Raise);
pragma Inline (Has_Self_Reference);
@@ -13542,10 +13331,9 @@ package Sinfo is
pragma Inline (Is_Known_Guaranteed_ABE);
pragma Inline (Is_Machine_Number);
pragma Inline (Is_Null_Loop);
- pragma Inline (Is_OpenAcc_Environment);
- pragma Inline (Is_OpenAcc_Loop);
pragma Inline (Is_Overloaded);
pragma Inline (Is_Power_Of_2_For_Shift);
+ pragma Inline (Is_Preelaborable_Call);
pragma Inline (Is_Prefixed_Call);
pragma Inline (Is_Protected_Subprogram_Body);
pragma Inline (Is_Qualified_Universal_Literal);
@@ -13559,8 +13347,10 @@ package Sinfo is
pragma Inline (Is_Task_Body_Procedure);
pragma Inline (Is_Task_Master);
pragma Inline (Is_Write);
+ pragma Inline (Iterator_Filter);
pragma Inline (Iteration_Scheme);
pragma Inline (Itype);
+ pragma Inline (Key_Expression);
pragma Inline (Kill_Range_Check);
pragma Inline (Last_Bit);
pragma Inline (Last_Name);
@@ -13679,7 +13469,6 @@ package Sinfo is
pragma Inline (Then_Statements);
pragma Inline (Triggering_Alternative);
pragma Inline (Triggering_Statement);
- pragma Inline (Treat_Fixed_As_Integer);
pragma Inline (TSS_Elist);
pragma Inline (Type_Definition);
pragma Inline (Uneval_Old_Accept);
@@ -13847,7 +13636,6 @@ package Sinfo is
pragma Inline (Set_Has_Created_Identifier);
pragma Inline (Set_Has_Dereference_Action);
pragma Inline (Set_Has_Dynamic_Length_Check);
- pragma Inline (Set_Has_Dynamic_Range_Check);
pragma Inline (Set_Has_Init_Expression);
pragma Inline (Set_Has_Local_Raise);
pragma Inline (Set_Has_No_Elaboration_Code);
@@ -13909,10 +13697,9 @@ package Sinfo is
pragma Inline (Set_Is_Known_Guaranteed_ABE);
pragma Inline (Set_Is_Machine_Number);
pragma Inline (Set_Is_Null_Loop);
- pragma Inline (Set_Is_OpenAcc_Environment);
- pragma Inline (Set_Is_OpenAcc_Loop);
pragma Inline (Set_Is_Overloaded);
pragma Inline (Set_Is_Power_Of_2_For_Shift);
+ pragma Inline (Set_Is_Preelaborable_Call);
pragma Inline (Set_Is_Prefixed_Call);
pragma Inline (Set_Is_Protected_Subprogram_Body);
pragma Inline (Set_Is_Qualified_Universal_Literal);
@@ -13926,9 +13713,11 @@ package Sinfo is
pragma Inline (Set_Is_Task_Body_Procedure);
pragma Inline (Set_Is_Task_Master);
pragma Inline (Set_Is_Write);
+ pragma Inline (Set_Iterator_Filter);
pragma Inline (Set_Iteration_Scheme);
pragma Inline (Set_Iterator_Specification);
pragma Inline (Set_Itype);
+ pragma Inline (Set_Key_Expression);
pragma Inline (Set_Kill_Range_Check);
pragma Inline (Set_Label_Construct);
pragma Inline (Set_Last_Bit);
@@ -14044,7 +13833,6 @@ package Sinfo is
pragma Inline (Set_Task_Present);
pragma Inline (Set_Then_Actions);
pragma Inline (Set_Then_Statements);
- pragma Inline (Set_Treat_Fixed_As_Integer);
pragma Inline (Set_Triggering_Alternative);
pragma Inline (Set_Triggering_Statement);
pragma Inline (Set_Type_Definition);
diff --git a/gcc/ada/sinput-c.adb b/gcc/ada/sinput-c.adb
index 3362aae..2a611b9 100644
--- a/gcc/ada/sinput-c.adb
+++ b/gcc/ada/sinput-c.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sinput-c.ads b/gcc/ada/sinput-c.ads
index eaa3270..37f4ebf 100644
--- a/gcc/ada/sinput-c.ads
+++ b/gcc/ada/sinput-c.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sinput-d.adb b/gcc/ada/sinput-d.adb
index 14f071a..5f449c7 100644
--- a/gcc/ada/sinput-d.adb
+++ b/gcc/ada/sinput-d.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sinput-d.ads b/gcc/ada/sinput-d.ads
index caa12d4..112fe30 100644
--- a/gcc/ada/sinput-d.ads
+++ b/gcc/ada/sinput-d.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb
index f77f025..ce6ba5f 100644
--- a/gcc/ada/sinput-l.adb
+++ b/gcc/ada/sinput-l.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sinput-l.ads b/gcc/ada/sinput-l.ads
index d04b737..2437108 100644
--- a/gcc/ada/sinput-l.ads
+++ b/gcc/ada/sinput-l.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb
index dbd7fe7..9f2669e 100644
--- a/gcc/ada/sinput.adb
+++ b/gcc/ada/sinput.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -37,7 +37,6 @@ with Debug; use Debug;
with Opt; use Opt;
with Output; use Output;
with Scans; use Scans;
-with Tree_IO; use Tree_IO;
with Widechar; use Widechar;
with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark;
@@ -938,6 +937,8 @@ package body Sinput is
procedure Sloc_Range (N : Node_Id; Min, Max : out Source_Ptr) is
+ Indx : constant Source_File_Index := Get_Source_File_Index (Sloc (N));
+
function Process (N : Node_Id) return Traverse_Result;
-- Process function for traversing the node tree
@@ -951,6 +952,14 @@ package body Sinput is
Orig : constant Node_Id := Original_Node (N);
begin
+ -- Skip nodes that may have been added during expansion and
+ -- that originate in other units, such as code for contracts
+ -- in subprogram bodies.
+
+ if Get_Source_File_Index (Sloc (Orig)) /= Indx then
+ return Skip;
+ end if;
+
if Sloc (Orig) < Min then
if Sloc (Orig) > No_Location then
Min := Sloc (Orig);
@@ -1004,160 +1013,6 @@ package body Sinput is
return Oldloc;
end Top_Level_Location;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- -- First we must free any old source buffer pointers
-
- for J in Source_File.First .. Source_File.Last loop
- declare
- S : Source_File_Record renames Source_File.Table (J);
- begin
- if S.Instance = No_Instance_Id then
- Free_Source_Buffer (S.Source_Text);
-
- if S.Lines_Table /= null then
- Memory.Free (To_Address (S.Lines_Table));
- S.Lines_Table := null;
- end if;
-
- if S.Logical_Lines_Table /= null then
- Memory.Free (To_Address (S.Logical_Lines_Table));
- S.Logical_Lines_Table := null;
- end if;
-
- else
- Free_Dope (S.Source_Text'Address);
- S.Source_Text := null;
- end if;
- end;
- end loop;
-
- -- Read in source file table and instance table
-
- Source_File.Tree_Read;
- Instances.Tree_Read;
-
- -- The pointers we read in there for the source buffer and lines table
- -- pointers are junk. We now read in the actual data that is referenced
- -- by these two fields.
-
- for J in Source_File.First .. Source_File.Last loop
- declare
- S : Source_File_Record renames Source_File.Table (J);
- begin
- -- Normal case (non-instantiation)
-
- if S.Instance = No_Instance_Id then
- S.Lines_Table := null;
- S.Logical_Lines_Table := null;
- Alloc_Line_Tables (S, Int (S.Last_Source_Line));
-
- for J in 1 .. S.Last_Source_Line loop
- Tree_Read_Int (Int (S.Lines_Table (J)));
- end loop;
-
- if S.Num_SRef_Pragmas /= 0 then
- for J in 1 .. S.Last_Source_Line loop
- Tree_Read_Int (Int (S.Logical_Lines_Table (J)));
- end loop;
- end if;
-
- -- Allocate source buffer and read in the data
-
- declare
- T : constant Source_Buffer_Ptr_Var :=
- new Source_Buffer (S.Source_First .. S.Source_Last);
- begin
- Tree_Read_Data (T (S.Source_First)'Address,
- Int (S.Source_Last) - Int (S.Source_First) + 1);
- S.Source_Text := T.all'Access;
- end;
-
- -- For the instantiation case, we do not read in any data. Instead
- -- we share the data for the generic template entry. Since the
- -- template always occurs first, we can safely refer to its data.
-
- else
- declare
- ST : Source_File_Record renames
- Source_File.Table (S.Template);
-
- begin
- -- The lines tables are copied from the template entry
-
- S.Lines_Table := ST.Lines_Table;
- S.Logical_Lines_Table := ST.Logical_Lines_Table;
-
- -- The Source_Text of the instance is the same data as that
- -- of the template, but with different bounds.
-
- declare
- Dope : constant Dope_Ptr :=
- new Dope_Rec'(S.Source_First, S.Source_Last);
- begin
- S.Source_Text := ST.Source_Text;
- Set_Dope (S.Source_Text'Address, Dope);
- end;
- end;
- end if;
- end;
-
- Set_Source_File_Index_Table (J);
- end loop;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Source_File.Tree_Write;
- Instances.Tree_Write;
-
- -- The pointers we wrote out there for the source buffer and lines
- -- table pointers are junk, we now write out the actual data that
- -- is referenced by these two fields.
-
- for J in Source_File.First .. Source_File.Last loop
- declare
- S : Source_File_Record renames Source_File.Table (J);
-
- begin
- -- For instantiations, there is nothing to do, since the data is
- -- shared with the generic template. When the tree is read, the
- -- pointers must be set, but no extra data needs to be written.
- -- For the normal case, write out the data of the tables.
-
- if S.Instance = No_Instance_Id then
- -- Lines table
-
- for J in 1 .. S.Last_Source_Line loop
- Tree_Write_Int (Int (S.Lines_Table (J)));
- end loop;
-
- -- Logical lines table if present
-
- if S.Num_SRef_Pragmas /= 0 then
- for J in 1 .. S.Last_Source_Line loop
- Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
- end loop;
- end if;
-
- -- Source buffer
-
- Tree_Write_Data
- (S.Source_Text (S.Source_First)'Address,
- Int (S.Source_Last) - Int (S.Source_First) + 1);
- end if;
- end;
- end loop;
- end Tree_Write;
-
--------------------
-- Write_Location --
--------------------
diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads
index c968eed..28c080d 100644
--- a/gcc/ada/sinput.ads
+++ b/gcc/ada/sinput.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -715,14 +715,6 @@ package Sinput is
procedure Write_Time_Stamp (S : Source_File_Index);
-- Writes time stamp of specified file in YY-MM-DD HH:MM.SS format
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
procedure Clear_Source_File_Table;
-- This procedure frees memory allocated in the Source_File table (in the
-- private). It should only be used when it is guaranteed that all source
diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl
index f085b84..ce9c63d 100644
--- a/gcc/ada/snames.adb-tmpl
+++ b/gcc/ada/snames.adb-tmpl
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -103,8 +103,10 @@ package body Snames is
-- xxxDF deep finalize routine for type xxx (Exp_TSS)
-- xxxDI deep initialize routine for type xxx (Exp_TSS)
-- xxxEQ composite equality routine for record type xxx (Exp_TSS)
+ -- xxxFD finalize address routine for type xxx (Exp_TSS)
-- xxxFA PolyORB/DSA From_Any converter for type xxx (Exp_TSS)
-- xxxIP initialization procedure for type xxx (Exp_TSS)
+ -- xxxIC init C++ dispatch tables procedure for type xxx (Exp_TSS)
-- xxxRA RAS type access routine for type xxx (Exp_TSS)
-- xxxRD RAS type dereference routine for type xxx (Exp_TSS)
-- xxxRP Rep to Pos conversion for enumeration type xxx (Exp_TSS)
@@ -113,6 +115,7 @@ package body Snames is
-- xxxSO stream output attribute subprogram for type xxx (Exp_TSS)
-- xxxSR stream read attribute subprogram for type xxx (Exp_TSS)
-- xxxSW stream write attribute subprogram for type xxx (Exp_TSS)
+ -- xxxPI Put_Image attribute subprogram for type xxx (Exp_TSS)
-- xxxTA PolyORB/DSA To_Any converter for type xxx (Exp_TSS)
-- xxxTC PolyORB/DSA Typecode for type xxx (Exp_TSS)
@@ -152,6 +155,23 @@ package body Snames is
Convention_Ada_Pass_By_Reference;
when Name_Assembler => return Convention_Assembler;
when Name_C => return Convention_C;
+ when Name_C_Variadic_0 => return Convention_C_Variadic_0;
+ when Name_C_Variadic_1 => return Convention_C_Variadic_1;
+ when Name_C_Variadic_2 => return Convention_C_Variadic_2;
+ when Name_C_Variadic_3 => return Convention_C_Variadic_3;
+ when Name_C_Variadic_4 => return Convention_C_Variadic_4;
+ when Name_C_Variadic_5 => return Convention_C_Variadic_5;
+ when Name_C_Variadic_6 => return Convention_C_Variadic_6;
+ when Name_C_Variadic_7 => return Convention_C_Variadic_7;
+ when Name_C_Variadic_8 => return Convention_C_Variadic_8;
+ when Name_C_Variadic_9 => return Convention_C_Variadic_9;
+ when Name_C_Variadic_10 => return Convention_C_Variadic_10;
+ when Name_C_Variadic_11 => return Convention_C_Variadic_11;
+ when Name_C_Variadic_12 => return Convention_C_Variadic_12;
+ when Name_C_Variadic_13 => return Convention_C_Variadic_13;
+ when Name_C_Variadic_14 => return Convention_C_Variadic_14;
+ when Name_C_Variadic_15 => return Convention_C_Variadic_15;
+ when Name_C_Variadic_16 => return Convention_C_Variadic_16;
when Name_COBOL => return Convention_COBOL;
when Name_CPP => return Convention_CPP;
when Name_Fortran => return Convention_Fortran;
@@ -186,6 +206,23 @@ package body Snames is
return Name_Ada_Pass_By_Reference;
when Convention_Assembler => return Name_Assembler;
when Convention_C => return Name_C;
+ when Convention_C_Variadic_0 => return Name_C_Variadic_0;
+ when Convention_C_Variadic_1 => return Name_C_Variadic_1;
+ when Convention_C_Variadic_2 => return Name_C_Variadic_2;
+ when Convention_C_Variadic_3 => return Name_C_Variadic_3;
+ when Convention_C_Variadic_4 => return Name_C_Variadic_4;
+ when Convention_C_Variadic_5 => return Name_C_Variadic_5;
+ when Convention_C_Variadic_6 => return Name_C_Variadic_6;
+ when Convention_C_Variadic_7 => return Name_C_Variadic_7;
+ when Convention_C_Variadic_8 => return Name_C_Variadic_8;
+ when Convention_C_Variadic_9 => return Name_C_Variadic_9;
+ when Convention_C_Variadic_10 => return Name_C_Variadic_10;
+ when Convention_C_Variadic_11 => return Name_C_Variadic_11;
+ when Convention_C_Variadic_12 => return Name_C_Variadic_12;
+ when Convention_C_Variadic_13 => return Name_C_Variadic_13;
+ when Convention_C_Variadic_14 => return Name_C_Variadic_14;
+ when Convention_C_Variadic_15 => return Name_C_Variadic_15;
+ when Convention_C_Variadic_16 => return Name_C_Variadic_16;
when Convention_COBOL => return Name_COBOL;
when Convention_CPP => return Name_CPP;
when Convention_Entry => return Name_Entry;
@@ -422,9 +459,9 @@ package body Snames is
return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name;
end Is_Locking_Policy_Name;
- -------------------------------------
- -- Is_Partition_Elaboration_Policy --
- -------------------------------------
+ ------------------------------------------
+ -- Is_Partition_Elaboration_Policy_Name --
+ ------------------------------------------
function Is_Partition_Elaboration_Policy_Name
(N : Name_Id) return Boolean
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 9d8f13b..6310442 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,10 +33,15 @@ with Namet; use Namet;
package Snames is
--- This package contains definitions of standard names (i.e. entries in the
--- Names table) that are used throughout the GNAT compiler. It also contains
--- the definitions of some enumeration types whose definitions are tied to the
--- order of these preset names.
+ -- This package contains definitions of standard names (i.e. entries in
+ -- the Names table) that are used throughout the GNAT compiler. It also
+ -- contains the definitions of some enumeration types whose definitions
+ -- are tied to the order of these preset names.
+
+ -- NOTE WELL: If you add names of attributes, the enumeration type
+ -- Attribute_Id must be kept in synch (same names in same order, with
+ -- some exceptions). See the body of Get_Attribute_Id for details. The
+ -- same is true of other enumeration types declared in this package.
------------------
-- Preset Names --
@@ -143,7 +148,11 @@ package Snames is
Name_Dimension_System : constant Name_Id := N + $;
Name_Disable_Controlled : constant Name_Id := N + $;
Name_Dynamic_Predicate : constant Name_Id := N + $;
+ Name_Integer_Literal : constant Name_Id := N + $;
+ Name_Real_Literal : constant Name_Id := N + $;
+ Name_Relaxed_Initialization : constant Name_Id := N + $;
Name_Static_Predicate : constant Name_Id := N + $;
+ Name_String_Literal : constant Name_Id := N + $;
Name_Synchronization : constant Name_Id := N + $;
Name_Unimplemented : constant Name_Id := N + $;
@@ -481,10 +490,6 @@ package Snames is
Name_Abort_Defer : constant Name_Id := N + $; -- GNAT
Name_Abstract_State : constant Name_Id := N + $; -- GNAT
- Name_Acc_Data : constant Name_Id := N + $;
- Name_Acc_Kernels : constant Name_Id := N + $;
- Name_Acc_Loop : constant Name_Id := N + $;
- Name_Acc_Parallel : constant Name_Id := N + $;
Name_All_Calls_Remote : constant Name_Id := N + $;
Name_Assert : constant Name_Id := N + $; -- Ada 05
Name_Assert_And_Cut : constant Name_Id := N + $; -- GNAT
@@ -509,6 +514,8 @@ package Snames is
Name_CPP_Constructor : constant Name_Id := N + $; -- GNAT
Name_CPP_Virtual : constant Name_Id := N + $; -- GNAT
Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT
+ Name_CUDA_Execute : constant Name_Id := N + $; -- GNAT
+ Name_CUDA_Global : constant Name_Id := N + $; -- GNAT
-- Note: CPU is not in this list because its name matches the name of
-- the corresponding attribute. However, it is included in the definition
@@ -666,10 +673,10 @@ package Snames is
Name_Suppress_Debug_Info : constant Name_Id := N + $; -- GNAT
Name_Suppress_Initialization : constant Name_Id := N + $; -- GNAT
Name_System_Name : constant Name_Id := N + $; -- Ada 83
- Name_Test_Case : constant Name_Id := N + $; -- GNAT
Name_Task_Info : constant Name_Id := N + $; -- GNAT
Name_Task_Name : constant Name_Id := N + $; -- GNAT
Name_Task_Storage : constant Name_Id := N + $; -- GNAT
+ Name_Test_Case : constant Name_Id := N + $; -- GNAT
Name_Thread_Local_Storage : constant Name_Id := N + $; -- GNAT
Name_Time_Slice : constant Name_Id := N + $; -- GNAT
Name_Title : constant Name_Id := N + $; -- GNAT
@@ -704,6 +711,23 @@ package Snames is
Name_Ada_Pass_By_Copy : constant Name_Id := N + $;
Name_Ada_Pass_By_Reference : constant Name_Id := N + $;
Name_Assembler : constant Name_Id := N + $;
+ Name_C_Variadic_0 : constant Name_Id := N + $;
+ Name_C_Variadic_1 : constant Name_Id := N + $;
+ Name_C_Variadic_2 : constant Name_Id := N + $;
+ Name_C_Variadic_3 : constant Name_Id := N + $;
+ Name_C_Variadic_4 : constant Name_Id := N + $;
+ Name_C_Variadic_5 : constant Name_Id := N + $;
+ Name_C_Variadic_6 : constant Name_Id := N + $;
+ Name_C_Variadic_7 : constant Name_Id := N + $;
+ Name_C_Variadic_8 : constant Name_Id := N + $;
+ Name_C_Variadic_9 : constant Name_Id := N + $;
+ Name_C_Variadic_10 : constant Name_Id := N + $;
+ Name_C_Variadic_11 : constant Name_Id := N + $;
+ Name_C_Variadic_12 : constant Name_Id := N + $;
+ Name_C_Variadic_13 : constant Name_Id := N + $;
+ Name_C_Variadic_14 : constant Name_Id := N + $;
+ Name_C_Variadic_15 : constant Name_Id := N + $;
+ Name_C_Variadic_16 : constant Name_Id := N + $;
Name_COBOL : constant Name_Id := N + $;
Name_CPP : constant Name_Id := N + $;
Name_Fortran : constant Name_Id := N + $;
@@ -712,6 +736,9 @@ package Snames is
Name_Stubbed : constant Name_Id := N + $;
Last_Convention_Name : constant Name_Id := N + $;
+ subtype Name_C_Variadic is Name_Id
+ range Name_C_Variadic_0 .. Name_C_Variadic_16;
+
-- The following names are preset as synonyms for Assembler
Name_Asm : constant Name_Id := N + $;
@@ -781,6 +808,7 @@ package Snames is
Name_Info : constant Name_Id := N + $;
Name_Internal : constant Name_Id := N + $;
Name_Ivdep : constant Name_Id := N + $;
+ Name_Jorvik : constant Name_Id := N + $;
Name_Link_Name : constant Name_Id := N + $;
Name_Low_Order_First : constant Name_Id := N + $;
Name_Lowercase : constant Name_Id := N + $;
@@ -866,35 +894,9 @@ package Snames is
Name_Warn : constant Name_Id := N + $;
Name_Working_Storage : constant Name_Id := N + $;
- -- OpenAcc-specific clause names for Parallel, Kernels, Data
-
- Name_Acc_If : constant Name_Id := N + $;
- Name_Acc_Private : constant Name_Id := N + $;
- Name_Attach : constant Name_Id := N + $;
- Name_Copy_In : constant Name_Id := N + $;
- Name_Copy_Out : constant Name_Id := N + $;
- Name_Create : constant Name_Id := N + $;
- Name_Delete : constant Name_Id := N + $;
- Name_Detach : constant Name_Id := N + $;
- Name_Device_Ptr : constant Name_Id := N + $;
- Name_Device_Type : constant Name_Id := N + $;
- Name_First_Private : constant Name_Id := N + $;
- Name_No_Create : constant Name_Id := N + $;
- Name_Num_Gangs : constant Name_Id := N + $;
- Name_Num_Workers : constant Name_Id := N + $;
- Name_Present : constant Name_Id := N + $;
- Name_Reduction : constant Name_Id := N + $;
- Name_Vector_Length : constant Name_Id := N + $;
- Name_Wait : constant Name_Id := N + $;
-
- -- Loop
+ -- used by Repinfo JSON I/O
- Name_Auto : constant Name_Id := N + $;
- Name_Collapse : constant Name_Id := N + $;
- Name_Gang : constant Name_Id := N + $;
- Name_Seq : constant Name_Id := N + $;
- Name_Tile : constant Name_Id := N + $;
- Name_Worker : constant Name_Id := N + $;
+ Name_Present : constant Name_Id := N + $;
-- Names of recognized attributes. The entries with the comment "Ada 83"
-- are attributes that are defined in Ada 83, but not in Ada 95. These
@@ -956,8 +958,8 @@ package Snames is
Name_Has_Same_Storage : constant Name_Id := N + $; -- Ada 12
Name_Has_Tagged_Values : constant Name_Id := N + $; -- GNAT
Name_Identity : constant Name_Id := N + $;
- Name_Img : constant Name_Id := N + $; -- GNAT
Name_Implicit_Dereference : constant Name_Id := N + $; -- GNAT
+ Name_Initialized : constant Name_Id := N + $; -- GNAT
Name_Integer_Value : constant Name_Id := N + $; -- GNAT
Name_Invalid_Value : constant Name_Id := N + $; -- GNAT
Name_Iterator_Element : constant Name_Id := N + $; -- GNAT
@@ -1002,7 +1004,7 @@ package Snames is
Name_Priority : constant Name_Id := N + $; -- Ada 05
Name_Range : constant Name_Id := N + $;
Name_Range_Length : constant Name_Id := N + $; -- GNAT
- Name_Reduce : constant Name_Id := N + $;
+ Name_Reduce : constant Name_Id := N + $; -- GNAT
Name_Ref : constant Name_Id := N + $; -- GNAT
Name_Restriction_Set : constant Name_Id := N + $; -- GNAT
Name_Result : constant Name_Id := N + $; -- GNAT
@@ -1059,6 +1061,7 @@ package Snames is
Name_Fraction : constant Name_Id := N + $;
Name_From_Any : constant Name_Id := N + $; -- GNAT
Name_Image : constant Name_Id := N + $;
+ Name_Img : constant Name_Id := N + $; -- GNAT
Name_Input : constant Name_Id := N + $;
Name_Machine : constant Name_Id := N + $;
Name_Max : constant Name_Id := N + $;
@@ -1082,6 +1085,7 @@ package Snames is
First_Procedure_Attribute : constant Name_Id := N + $;
Name_Output : constant Name_Id := N + $;
+ Name_Put_Image : constant Name_Id := N + $;
Name_Read : constant Name_Id := N + $;
Name_Write : constant Name_Id := N + $;
Last_Procedure_Attribute : constant Name_Id := N + $;
@@ -1189,14 +1193,14 @@ package Snames is
Name_Unsigned_32 : constant Name_Id := N + $; -- GNAT
Name_Unsigned_64 : constant Name_Id := N + $; -- GNAT
- subtype Scalar_Id is Name_Id range
- Name_Short_Float .. Name_Unsigned_64;
+ subtype Scalar_Id is Name_Id
+ range Name_Short_Float .. Name_Unsigned_64;
- subtype Float_Scalar_Id is Name_Id range
- Name_Short_Float .. Name_Long_Long_Float;
+ subtype Float_Scalar_Id is Name_Id
+ range Name_Short_Float .. Name_Long_Long_Float;
- subtype Integer_Scalar_Id is Name_Id range
- Name_Signed_8 .. Name_Unsigned_64;
+ subtype Integer_Scalar_Id is Name_Id
+ range Name_Signed_8 .. Name_Unsigned_64;
-- Names of recognized checks for pragma Suppress
@@ -1209,20 +1213,29 @@ package Snames is
Name_Alignment_Check : constant Name_Id := N + $; -- GNAT
Name_Allocation_Check : constant Name_Id := N + $;
Name_Atomic_Synchronization : constant Name_Id := N + $; -- GNAT
+ Name_Characters_Assertion_Check : constant Name_Id := N + $;
+ Name_Containers_Assertion_Check : constant Name_Id := N + $;
Name_Discriminant_Check : constant Name_Id := N + $;
Name_Division_Check : constant Name_Id := N + $;
Name_Duplicated_Tag_Check : constant Name_Id := N + $; -- GNAT
Name_Elaboration_Check : constant Name_Id := N + $;
Name_Index_Check : constant Name_Id := N + $;
+ Name_Interfaces_Assertion_Check : constant Name_Id := N + $;
+ Name_IO_Assertion_Check : constant Name_Id := N + $;
Name_Length_Check : constant Name_Id := N + $;
+ Name_Numerics_Assertion_Check : constant Name_Id := N + $;
Name_Overflow_Check : constant Name_Id := N + $;
Name_Predicate_Check : constant Name_Id := N + $; -- GNAT
+ Name_Program_Error_Check : constant Name_Id := N + $;
Name_Range_Check : constant Name_Id := N + $;
Name_Storage_Check : constant Name_Id := N + $;
+ Name_Strings_Assertion_Check : constant Name_Id := N + $;
+ Name_System_Assertion_Check : constant Name_Id := N + $;
Name_Tag_Check : constant Name_Id := N + $;
Name_Validity_Check : constant Name_Id := N + $; -- GNAT
Name_Container_Checks : constant Name_Id := N + $; -- GNAT
Name_Tampering_Check : constant Name_Id := N + $; -- GNAT
+ Name_Tasking_Check : constant Name_Id := N + $;
Name_All_Checks : constant Name_Id := N + $;
Last_Check_Name : constant Name_Id := N + $;
@@ -1335,8 +1348,8 @@ package Snames is
Name_Tagged : constant Name_Id := N + $;
Last_95_Reserved_Word : constant Name_Id := N + $;
- subtype Ada_95_Reserved_Words is
- Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word;
+ subtype Ada_95_Reserved_Words is Name_Id
+ range First_95_Reserved_Word .. Last_95_Reserved_Word;
-- Miscellaneous names used in semantic checking
@@ -1539,6 +1552,15 @@ package Snames is
Name_Reference_Control_Type : constant Name_Id := N + $;
Name_Get_Element_Access : constant Name_Id := N + $;
+ -- Names for Ada 202x Aggregate aspect. Name_Aggregate is already
+ -- present for gprbuild.
+
+ Name_Empty : constant Name_Id := N + $;
+ Name_Add_Named : constant Name_Id := N + $;
+ Name_Add_Unnamed : constant Name_Id := N + $;
+ Name_New_Indexed : constant Name_Id := N + $;
+ Name_Assign_Indexed : constant Name_Id := N + $;
+
-- Ada 2005 reserved words
First_2005_Reserved_Word : constant Name_Id := N + $;
@@ -1547,8 +1569,8 @@ package Snames is
Name_Synchronized : constant Name_Id := N + $;
Last_2005_Reserved_Word : constant Name_Id := N + $;
- subtype Ada_2005_Reserved_Words is
- Name_Id range First_2005_Reserved_Word .. Last_2005_Reserved_Word;
+ subtype Ada_2005_Reserved_Words is Name_Id
+ range First_2005_Reserved_Word .. Last_2005_Reserved_Word;
-- Ada 2012 reserved words
@@ -1556,8 +1578,8 @@ package Snames is
Name_Some : constant Name_Id := N + $;
Last_2012_Reserved_Word : constant Name_Id := N + $;
- subtype Ada_2012_Reserved_Words is
- Name_Id range First_2012_Reserved_Word .. Last_2012_Reserved_Word;
+ subtype Ada_2012_Reserved_Words is Name_Id
+ range First_2012_Reserved_Word .. Last_2012_Reserved_Word;
-- Mark last defined name for consistency check in Snames body
@@ -1567,11 +1589,11 @@ package Snames is
-- Subtypes Defining Name Categories --
---------------------------------------
- subtype Any_Operator_Name is Name_Id range
- First_Operator_Name .. Last_Operator_Name;
+ subtype Any_Operator_Name is Name_Id
+ range First_Operator_Name .. Last_Operator_Name;
- subtype Configuration_Pragma_Names is Name_Id range
- First_Pragma_Name .. Last_Configuration_Pragma_Name;
+ subtype Configuration_Pragma_Names is Name_Id
+ range First_Pragma_Name .. Last_Configuration_Pragma_Name;
------------------------------
-- Attribute ID Definitions --
@@ -1629,8 +1651,8 @@ package Snames is
Attribute_Has_Same_Storage,
Attribute_Has_Tagged_Values,
Attribute_Identity,
- Attribute_Img,
Attribute_Implicit_Dereference,
+ Attribute_Initialized,
Attribute_Integer_Value,
Attribute_Invalid_Value,
Attribute_Iterator_Element,
@@ -1729,6 +1751,7 @@ package Snames is
Attribute_Fraction,
Attribute_From_Any,
Attribute_Image,
+ Attribute_Img,
Attribute_Input,
Attribute_Machine,
Attribute_Max,
@@ -1750,6 +1773,7 @@ package Snames is
-- Attributes designating procedures
Attribute_Output,
+ Attribute_Put_Image,
Attribute_Read,
Attribute_Write,
@@ -1775,8 +1799,8 @@ package Snames is
Attribute_Dispatching_Domain,
Attribute_Interrupt_Priority);
- subtype Internal_Attribute_Id is Attribute_Id range
- Attribute_CPU .. Attribute_Interrupt_Priority;
+ subtype Internal_Attribute_Id is Attribute_Id
+ range Attribute_CPU .. Attribute_Interrupt_Priority;
type Attribute_Class_Array is array (Attribute_Id) of Boolean;
-- Type used to build attribute classification flag arrays
@@ -1804,12 +1828,29 @@ package Snames is
-- The remaining conventions are foreign language conventions
- Convention_Assembler, -- also Asm, Assembly
- Convention_C, -- also Default, External
- Convention_COBOL,
+ Convention_Assembler, -- also Asm, Assembly
+ Convention_C, -- also Default, External
+ Convention_C_Variadic_0,
+ Convention_C_Variadic_1,
+ Convention_C_Variadic_2,
+ Convention_C_Variadic_3,
+ Convention_C_Variadic_4,
+ Convention_C_Variadic_5,
+ Convention_C_Variadic_6,
+ Convention_C_Variadic_7,
+ Convention_C_Variadic_8,
+ Convention_C_Variadic_9,
+ Convention_C_Variadic_10,
+ Convention_C_Variadic_11,
+ Convention_C_Variadic_12,
+ Convention_C_Variadic_13,
+ Convention_C_Variadic_14,
+ Convention_C_Variadic_15,
+ Convention_C_Variadic_16,
Convention_CPP,
+ Convention_COBOL,
Convention_Fortran,
- Convention_Stdcall); -- also DLL, Win32
+ Convention_Stdcall); -- also DLL, Win32
-- Note: Convention C_Pass_By_Copy is allowed only for record types
-- (where it is treated like C except that the appropriate flag is set
@@ -1819,8 +1860,14 @@ package Snames is
for Convention_Id'Size use 8;
-- Plenty of space for expansion
- subtype Foreign_Convention is
- Convention_Id range Convention_Assembler .. Convention_Id'Last;
+ subtype Convention_C_Family is Convention_Id
+ range Convention_C .. Convention_CPP;
+
+ subtype Convention_C_Variadic is Convention_Id
+ range Convention_C_Variadic_0 .. Convention_C_Variadic_16;
+
+ subtype Foreign_Convention is Convention_Id
+ range Convention_Assembler .. Convention_Stdcall;
-----------------------------------
-- Locking Policy ID Definitions --
@@ -1929,10 +1976,6 @@ package Snames is
Pragma_Abort_Defer,
Pragma_Abstract_State,
- Pragma_Acc_Data,
- Pragma_Acc_Kernels,
- Pragma_Acc_Loop,
- Pragma_Acc_Parallel,
Pragma_All_Calls_Remote,
Pragma_Assert,
Pragma_Assert_And_Cut,
@@ -1957,6 +2000,8 @@ package Snames is
Pragma_CPP_Constructor,
Pragma_CPP_Virtual,
Pragma_CPP_Vtable,
+ Pragma_CUDA_Execute,
+ Pragma_CUDA_Global,
Pragma_Deadline_Floor,
Pragma_Debug,
Pragma_Default_Initial_Condition,
@@ -2061,10 +2106,10 @@ package Snames is
Pragma_Suppress_Debug_Info,
Pragma_Suppress_Initialization,
Pragma_System_Name,
- Pragma_Test_Case,
Pragma_Task_Info,
Pragma_Task_Name,
Pragma_Task_Storage,
+ Pragma_Test_Case,
Pragma_Thread_Local_Storage,
Pragma_Time_Slice,
Pragma_Title,
@@ -2250,13 +2295,17 @@ package Snames is
private
pragma Inline (Is_Attribute_Name);
+ pragma Inline (Is_Configuration_Pragma_Name);
pragma Inline (Is_Entity_Attribute_Name);
- pragma Inline (Is_Type_Attribute_Name);
+ pragma Inline (Is_Function_Attribute_Name);
+ pragma Inline (Is_Internal_Attribute_Name);
pragma Inline (Is_Locking_Policy_Name);
pragma Inline (Is_Partition_Elaboration_Policy_Name);
pragma Inline (Is_Operator_Symbol_Name);
- pragma Inline (Is_Queuing_Policy_Name);
pragma Inline (Is_Pragma_Name);
+ pragma Inline (Is_Procedure_Attribute_Name);
+ pragma Inline (Is_Queuing_Policy_Name);
pragma Inline (Is_Task_Dispatching_Policy_Name);
+ pragma Inline (Is_Type_Attribute_Name);
end Snames;
diff --git a/gcc/ada/socket.c b/gcc/ada/socket.c
index 6ca9d50..8333b6b 100644
--- a/gcc/ada/socket.c
+++ b/gcc/ada/socket.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2003-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2003-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -333,8 +333,8 @@ __gnat_getservbyport (int port, const char *proto,
}
#else
int
-__gnat_gethostbyname (const char *name,
- struct hostent *ret, char *buf, size_t buflen,
+__gnat_gethostbyname (const char *name, struct hostent *ret,
+ char *buf ATTRIBUTE_UNUSED, size_t buflen ATTRIBUTE_UNUSED,
int *h_errnop)
{
struct hostent *rh;
@@ -349,8 +349,8 @@ __gnat_gethostbyname (const char *name,
}
int
-__gnat_gethostbyaddr (const char *addr, int len, int type,
- struct hostent *ret, char *buf, size_t buflen,
+__gnat_gethostbyaddr (const char *addr, int len, int type, struct hostent *ret,
+ char *buf ATTRIBUTE_UNUSED, size_t buflen ATTRIBUTE_UNUSED,
int *h_errnop)
{
struct hostent *rh;
@@ -365,8 +365,8 @@ __gnat_gethostbyaddr (const char *addr, int len, int type,
}
int
-__gnat_getservbyname (const char *name, const char *proto,
- struct servent *ret, char *buf, size_t buflen)
+__gnat_getservbyname (const char *name, const char *proto, struct servent *ret,
+ char *buf ATTRIBUTE_UNUSED, size_t buflen ATTRIBUTE_UNUSED)
{
struct servent *rh;
rh = getservbyname (name, proto);
@@ -377,8 +377,8 @@ __gnat_getservbyname (const char *name, const char *proto,
}
int
-__gnat_getservbyport (int port, const char *proto,
- struct servent *ret, char *buf, size_t buflen)
+__gnat_getservbyport (int port, const char *proto, struct servent *ret,
+ char *buf ATTRIBUTE_UNUSED, size_t buflen ATTRIBUTE_UNUSED)
{
struct servent *rh;
rh = getservbyport (port, proto);
@@ -397,19 +397,18 @@ __gnat_getservbyport (int port, const char *proto,
void
__gnat_last_socket_in_set (fd_set *set, int *last)
{
- int s;
int l;
l = -1;
#ifdef _WIN32
/* More efficient method for NT. */
- for (s = 0; s < set->fd_count; s++)
+ for (unsigned int s = 0; s < set->fd_count; s++)
if ((int) set->fd_array[s] > l)
l = set->fd_array[s];
#else
- for (s = *last; s != -1; s--)
+ for (int s = *last; s != -1; s--)
if (FD_ISSET (s, set))
{
l = s;
@@ -517,7 +516,7 @@ __gnat_get_h_errno (void) {
int
__gnat_socket_ioctl (int fd, IOCTL_Req_T req, int *arg) {
#if defined (_WIN32)
- return ioctlsocket (fd, req, arg);
+ return ioctlsocket (fd, req, (unsigned long *)arg);
#elif defined (__APPLE__)
/*
* On Darwin, req is an unsigned long, and we want to convert without sign
@@ -553,7 +552,8 @@ __gnat_inet_pton (int af, const char *src, void *dst) {
int rc;
ss.ss_family = af;
- rc = WSAStringToAddressA (src, af, NULL, (struct sockaddr *)&ss, &sslen);
+ rc = WSAStringToAddressA ((char *)src, af, NULL, (struct sockaddr *)&ss,
+ &sslen);
if (rc == 0) {
switch (af) {
case AF_INET:
@@ -803,10 +803,22 @@ int __gnat_minus_500ms() {
#if defined (_WIN32)
// Windows Server 2019 and Windows 8.0 do not need 500 millisecond socket
// timeout correction.
- return !(IsWindows8OrGreater() && !IsWindowsServer()
- || IsWindowsVersionOrGreater(10, 0, 17763));
+ if (IsWindowsServer()) {
+ OSVERSIONINFO osvi;
+ ZeroMemory(&osvi, sizeof(OSVERSIONINFO));
+ osvi.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
+ // Documentation proposes to use IsWindowsVersionOrGreater(10, 0, 17763)
+ // but it does not compare by the build number (last parameter).
+ GetVersionEx(&osvi);
+ return osvi.dwMajorVersion < 10
+ || (osvi.dwMajorVersion == 10
+ && osvi.dwMinorVersion == 0
+ && osvi.dwBuildNumber < 17763);
+ } else {
+ return !IsWindows8OrGreater();
+ }
#else
- return 0;
+ return 0;
#endif
}
diff --git a/gcc/ada/spark_xrefs.adb b/gcc/ada/spark_xrefs.adb
index 9acc74f..5b09351 100644
--- a/gcc/ada/spark_xrefs.adb
+++ b/gcc/ada/spark_xrefs.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/spark_xrefs.ads b/gcc/ada/spark_xrefs.ads
index 55a3ffa..88a34c5 100644
--- a/gcc/ada/spark_xrefs.ads
+++ b/gcc/ada/spark_xrefs.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index 8a8139d..3aeb95f 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -176,11 +176,6 @@ package body Sprint is
-- Used to print output lines in Debug_Generated_Code mode (this is used
-- as the argument for a call to Set_Special_Output in package Output).
- procedure Process_TFAI_RR_Flags (Nod : Node_Id);
- -- Given a divide, multiplication or division node, check the flags
- -- Treat_Fixed_As_Integer and Rounded_Flags, and if set, output the
- -- appropriate special syntax characters (# and @).
-
procedure Set_Debug_Sloc;
-- If Dump_Node is non-empty, this routine sets the appropriate value
-- in its Sloc field, from the current location in the debug source file
@@ -471,21 +466,6 @@ package body Sprint is
Write_Debug_Line (S, Debug_Sloc);
end Print_Debug_Line;
- ---------------------------
- -- Process_TFAI_RR_Flags --
- ---------------------------
-
- procedure Process_TFAI_RR_Flags (Nod : Node_Id) is
- begin
- if Treat_Fixed_As_Integer (Nod) then
- Write_Char ('#');
- end if;
-
- if Rounded_Result (Nod) then
- Write_Char ('@');
- end if;
- end Process_TFAI_RR_Flags;
-
--------
-- ps --
--------
@@ -552,7 +532,7 @@ package body Sprint is
-- We do not know the actual end location in the generated code and
-- it could be much closer than in the source code, so play safe.
- if Nkind_In (Dump_Node, N_Case_Statement, N_If_Statement) then
+ if Nkind (Dump_Node) in N_Case_Statement | N_If_Statement then
Set_End_Location (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1));
end if;
@@ -1345,6 +1325,22 @@ package body Sprint is
Write_Str (" => ");
Sprint_Node (Expression (Node));
+ when N_Iterated_Element_Association =>
+ Set_Debug_Sloc;
+ if Present (Iterator_Specification (Node)) then
+ Sprint_Node (Iterator_Specification (Node));
+ else
+ Sprint_Node (Loop_Parameter_Specification (Node));
+ end if;
+
+ if Present (Key_Expression (Node)) then
+ Write_Str (" use ");
+ Sprint_Node (Key_Expression (Node));
+ end if;
+
+ Write_Str (" => ");
+ Sprint_Node (Expression (Node));
+
when N_Component_Clause =>
Write_Indent;
Sprint_Node (Component_Name (Node));
@@ -2411,6 +2407,7 @@ package body Sprint is
if Present (Expression (Node))
and then Expression (Node) /= Error
+ and then not No_Initialization (Node)
then
Write_Str (" := ");
Sprint_Node (Expression (Node));
@@ -2461,14 +2458,15 @@ package body Sprint is
Write_Indent;
Set_Debug_Sloc;
Sprint_Node (Defining_Identifier (Node));
- Write_Str (" : ");
-- Ada 2005 (AI-230): Access renamings
if Present (Access_Definition (Node)) then
+ Write_Str (" : ");
Sprint_Node (Access_Definition (Node));
elsif Present (Subtype_Mark (Node)) then
+ Write_Str (" : ");
-- Ada 2005 (AI-423): Object renaming with a null exclusion
@@ -2478,8 +2476,13 @@ package body Sprint is
Sprint_Node (Subtype_Mark (Node));
+ -- AI12-0275: Object_Renaming_Declaration without explicit subtype
+
+ elsif Ada_Version >= Ada_2020 then
+ null;
+
else
- Write_Str (" ??? ");
+ Write_Str (" : ??? ");
end if;
Write_Str_With_Col_Check (" renames ");
@@ -2508,7 +2511,9 @@ package body Sprint is
when N_Op_Divide =>
Sprint_Left_Opnd (Node);
Write_Char (' ');
- Process_TFAI_RR_Flags (Node);
+ if Rounded_Result (Node) then
+ Write_Char ('@');
+ end if;
Write_Operator (Node, "/ ");
Sprint_Right_Opnd (Node);
@@ -2548,18 +2553,15 @@ package body Sprint is
when N_Op_Mod =>
Sprint_Left_Opnd (Node);
-
- if Treat_Fixed_As_Integer (Node) then
- Write_Str (" #");
- end if;
-
Write_Operator (Node, " mod ");
Sprint_Right_Opnd (Node);
when N_Op_Multiply =>
Sprint_Left_Opnd (Node);
Write_Char (' ');
- Process_TFAI_RR_Flags (Node);
+ if Rounded_Result (Node) then
+ Write_Char ('@');
+ end if;
Write_Operator (Node, "* ");
Sprint_Right_Opnd (Node);
@@ -2583,11 +2585,6 @@ package body Sprint is
when N_Op_Rem =>
Sprint_Left_Opnd (Node);
-
- if Treat_Fixed_As_Integer (Node) then
- Write_Str (" #");
- end if;
-
Write_Operator (Node, " rem ");
Sprint_Right_Opnd (Node);
@@ -3540,8 +3537,8 @@ package body Sprint is
-- where the aspects are printed inside the package specification.
if Has_Aspects (Node)
- and then not Nkind_In (Node, N_Generic_Package_Declaration,
- N_Package_Declaration)
+ and then Nkind (Node) not in
+ N_Generic_Package_Declaration | N_Package_Declaration
and then not Is_Empty_List (Aspect_Specifications (Node))
then
Sprint_Aspect_Specifications (Node, Semicolon => True);
@@ -4509,6 +4506,43 @@ package body Sprint is
Write_Str (", ");
end loop;
+ if Present (Extra_Formals (Typ)) then
+ Param := Extra_Formals (Typ);
+
+ while Present (Param) loop
+ Write_Str (", ");
+ Write_Id (Param);
+ Write_Str (" : ");
+ Write_Id (Etype (Param));
+
+ Param := Extra_Formal (Param);
+ end loop;
+ end if;
+
+ Write_Char (')');
+ end;
+
+ elsif Present (Extra_Formals (Typ)) then
+ declare
+ Param : Entity_Id;
+
+ begin
+ Write_Str (" (");
+
+ Param := Extra_Formals (Typ);
+
+ while Present (Param) loop
+ Write_Id (Param);
+ Write_Str (" : ");
+ Write_Id (Etype (Param));
+
+ if Present (Extra_Formal (Param)) then
+ Write_Str (", ");
+ end if;
+
+ Param := Extra_Formal (Param);
+ end loop;
+
Write_Char (')');
end;
end if;
@@ -4711,9 +4745,7 @@ package body Sprint is
-- See if we have extra formals
- if Nkind_In (N, N_Function_Specification,
- N_Procedure_Specification)
- then
+ if Nkind (N) in N_Function_Specification | N_Procedure_Specification then
Ent := Defining_Entity (N);
-- Loop to write extra formals (if any)
diff --git a/gcc/ada/sprint.ads b/gcc/ada/sprint.ads
index c510ac6..5cdf754 100644
--- a/gcc/ada/sprint.ads
+++ b/gcc/ada/sprint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -51,7 +51,6 @@ package Sprint is
-- Convert wi Conversion_OK target?(source)
-- Convert wi Float_Truncate target^(source)
-- Convert wi Rounded_Result target@(source)
- -- Divide wi Treat_Fixed_As_Integer x #/ y
-- Divide wi Rounded_Result x @/ y
-- Expression with actions do action; .. action; in expr end
-- Expression with range check {expression}
@@ -66,9 +65,7 @@ package Sprint is
-- Itype declaration [(sub)type declaration without ;]
-- Itype reference reference itype
-- Label declaration labelname : label
- -- Mod wi Treat_Fixed_As_Integer x #mod y
-- Multiple concatenation expr && expr && expr ... && expr
- -- Multiply wi Treat_Fixed_As_Integer x #* y
-- Multiply wi Rounded_Result x @* y
-- Operator with overflow check {operator} (e.g. {+})
-- Others choice for cleanup when all others
@@ -77,7 +74,6 @@ package Sprint is
-- Raise xxx error [xxx_error [when cond]]
-- Raise xxx error with msg [xxx_error [when cond], "msg"]
-- Rational literal [expression]
- -- Rem wi Treat_Fixed_As_Integer x #rem y
-- Reference expression'reference
-- Shift nodes shift_name!(expr, count)
-- Static declaration name : static xxx
diff --git a/gcc/ada/stand.adb b/gcc/ada/stand.adb
deleted file mode 100644
index 66dbcd6..0000000
--- a/gcc/ada/stand.adb
+++ /dev/null
@@ -1,190 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S T A N D --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Elists; use Elists;
-with System; use System;
-with Tree_IO; use Tree_IO;
-
-package body Stand is
-
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- Tree_Read_Data (Standard_Entity'Address,
- Standard_Entity_Array_Type'Size / Storage_Unit);
-
- Tree_Read_Int (Int (Standard_Package_Node));
- Tree_Read_Int (Int (Last_Standard_Node_Id));
- Tree_Read_Int (Int (Last_Standard_List_Id));
-
- Tree_Read_Int (Int (Boolean_Literals (False)));
- Tree_Read_Int (Int (Boolean_Literals (True)));
-
- Tree_Read_Int (Int (Standard_Void_Type));
- Tree_Read_Int (Int (Standard_Exception_Type));
- Tree_Read_Int (Int (Standard_A_String));
- Tree_Read_Int (Int (Standard_A_Char));
- Tree_Read_Int (Int (Standard_Debug_Renaming_Type));
-
- -- Deal with Predefined_Float_Types, which is an Elist. We wrote the
- -- entities out in sequence, terminated by an Empty entry.
-
- declare
- Elmt : Entity_Id;
- begin
- Predefined_Float_Types := New_Elmt_List;
- loop
- Tree_Read_Int (Int (Elmt));
- exit when Elmt = Empty;
- Append_Elmt (Elmt, Predefined_Float_Types);
- end loop;
- end;
-
- -- Remainder of special entities
-
- Tree_Read_Int (Int (Any_Id));
- Tree_Read_Int (Int (Any_Type));
- Tree_Read_Int (Int (Any_Access));
- Tree_Read_Int (Int (Any_Array));
- Tree_Read_Int (Int (Any_Boolean));
- Tree_Read_Int (Int (Any_Character));
- Tree_Read_Int (Int (Any_Composite));
- Tree_Read_Int (Int (Any_Discrete));
- Tree_Read_Int (Int (Any_Fixed));
- Tree_Read_Int (Int (Any_Integer));
- Tree_Read_Int (Int (Any_Modular));
- Tree_Read_Int (Int (Any_Numeric));
- Tree_Read_Int (Int (Any_Real));
- Tree_Read_Int (Int (Any_Scalar));
- Tree_Read_Int (Int (Any_String));
- Tree_Read_Int (Int (Raise_Type));
- Tree_Read_Int (Int (Universal_Integer));
- Tree_Read_Int (Int (Universal_Real));
- Tree_Read_Int (Int (Universal_Fixed));
- Tree_Read_Int (Int (Standard_Integer_8));
- Tree_Read_Int (Int (Standard_Integer_16));
- Tree_Read_Int (Int (Standard_Integer_32));
- Tree_Read_Int (Int (Standard_Integer_64));
- Tree_Read_Int (Int (Standard_Short_Short_Unsigned));
- Tree_Read_Int (Int (Standard_Short_Unsigned));
- Tree_Read_Int (Int (Standard_Unsigned));
- Tree_Read_Int (Int (Standard_Long_Unsigned));
- Tree_Read_Int (Int (Standard_Long_Long_Unsigned));
- Tree_Read_Int (Int (Standard_Unsigned_64));
- Tree_Read_Int (Int (Abort_Signal));
- Tree_Read_Int (Int (Standard_Op_Rotate_Left));
- Tree_Read_Int (Int (Standard_Op_Rotate_Right));
- Tree_Read_Int (Int (Standard_Op_Shift_Left));
- Tree_Read_Int (Int (Standard_Op_Shift_Right));
- Tree_Read_Int (Int (Standard_Op_Shift_Right_Arithmetic));
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Tree_Write_Data (Standard_Entity'Address,
- Standard_Entity_Array_Type'Size / Storage_Unit);
-
- Tree_Write_Int (Int (Standard_Package_Node));
- Tree_Write_Int (Int (Last_Standard_Node_Id));
- Tree_Write_Int (Int (Last_Standard_List_Id));
-
- Tree_Write_Int (Int (Boolean_Literals (False)));
- Tree_Write_Int (Int (Boolean_Literals (True)));
-
- Tree_Write_Int (Int (Standard_Void_Type));
- Tree_Write_Int (Int (Standard_Exception_Type));
- Tree_Write_Int (Int (Standard_A_String));
- Tree_Write_Int (Int (Standard_A_Char));
- Tree_Write_Int (Int (Standard_Debug_Renaming_Type));
-
- -- Deal with Predefined_Float_Types, which is an Elist. Write the
- -- entities out in sequence, terminated by an Empty entry.
-
- declare
- Elmt : Elmt_Id;
-
- begin
- Elmt := First_Elmt (Predefined_Float_Types);
- while Present (Elmt) loop
- Tree_Write_Int (Int (Node (Elmt)));
- Next_Elmt (Elmt);
- end loop;
-
- Tree_Write_Int (Int (Empty));
- end;
-
- -- Remainder of special entries
-
- Tree_Write_Int (Int (Any_Id));
- Tree_Write_Int (Int (Any_Type));
- Tree_Write_Int (Int (Any_Access));
- Tree_Write_Int (Int (Any_Array));
- Tree_Write_Int (Int (Any_Boolean));
- Tree_Write_Int (Int (Any_Character));
- Tree_Write_Int (Int (Any_Composite));
- Tree_Write_Int (Int (Any_Discrete));
- Tree_Write_Int (Int (Any_Fixed));
- Tree_Write_Int (Int (Any_Integer));
- Tree_Write_Int (Int (Any_Modular));
- Tree_Write_Int (Int (Any_Numeric));
- Tree_Write_Int (Int (Any_Real));
- Tree_Write_Int (Int (Any_Scalar));
- Tree_Write_Int (Int (Any_String));
- Tree_Write_Int (Int (Raise_Type));
- Tree_Write_Int (Int (Universal_Integer));
- Tree_Write_Int (Int (Universal_Real));
- Tree_Write_Int (Int (Universal_Fixed));
- Tree_Write_Int (Int (Standard_Integer_8));
- Tree_Write_Int (Int (Standard_Integer_16));
- Tree_Write_Int (Int (Standard_Integer_32));
- Tree_Write_Int (Int (Standard_Integer_64));
- Tree_Write_Int (Int (Standard_Short_Short_Unsigned));
- Tree_Write_Int (Int (Standard_Short_Unsigned));
- Tree_Write_Int (Int (Standard_Unsigned));
- Tree_Write_Int (Int (Standard_Long_Unsigned));
- Tree_Write_Int (Int (Standard_Long_Long_Unsigned));
- Tree_Write_Int (Int (Standard_Unsigned_64));
- Tree_Write_Int (Int (Abort_Signal));
- Tree_Write_Int (Int (Standard_Op_Rotate_Left));
- Tree_Write_Int (Int (Standard_Op_Rotate_Right));
- Tree_Write_Int (Int (Standard_Op_Shift_Left));
- Tree_Write_Int (Int (Standard_Op_Shift_Right));
- Tree_Write_Int (Int (Standard_Op_Shift_Right_Arithmetic));
- end Tree_Write;
-
-end Stand;
diff --git a/gcc/ada/stand.ads b/gcc/ada/stand.ads
index 6f3b4e6..f3f7eb5 100644
--- a/gcc/ada/stand.ads
+++ b/gcc/ada/stand.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -52,7 +52,7 @@ package Stand is
-- Types and subtypes defined in package Standard (in the order in which
-- they appear in the RM, so that the declarations are in the right
- -- order for the purposes of ASIS traversals
+ -- order for the purposes of e.g. ASIS traversals
S_Boolean,
@@ -468,7 +468,11 @@ package Stand is
-- Unsigned types with same Esize as corresponding signed integer types
Standard_Unsigned_64 : Entity_Id;
- -- An unsigned type, mod 2 ** 64, size of 64 bits.
+ -- Entity for an unsigned type mod 2 ** 64, size of 64 bits.
+
+ Standard_Address : Entity_Id;
+ -- Entity for an unsigned type mod 2 ** System_Address_Size, size of
+ -- System_Address_Size bits. Used for implementing Allow_Integer_Address.
Abort_Signal : Entity_Id;
-- Entity for abort signal exception
@@ -480,17 +484,4 @@ package Stand is
Standard_Op_Shift_Right_Arithmetic : Entity_Id;
-- These entities are used for shift operators generated by the expander
- -----------------
- -- Subprograms --
- -----------------
-
- procedure Tree_Read;
- -- Initializes entity values in this package from the current tree file
- -- using Tree_IO. Note that Tree_Read includes all the initialization that
- -- is carried out by Create_Standard.
-
- procedure Tree_Write;
- -- Writes out the entity values in this package to the current tree file
- -- using Tree_IO.
-
end Stand;
diff --git a/gcc/ada/stringt.adb b/gcc/ada/stringt.adb
index 545705a..35e9028 100644
--- a/gcc/ada/stringt.adb
+++ b/gcc/ada/stringt.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -360,26 +360,6 @@ package body Stringt is
return To_String (Buf);
end To_String;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- String_Chars.Tree_Read;
- Strings.Tree_Read;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- String_Chars.Tree_Write;
- Strings.Tree_Write;
- end Tree_Write;
-
------------
-- Unlock --
------------
diff --git a/gcc/ada/stringt.ads b/gcc/ada/stringt.ads
index 2ceb20c..ede7bfd 100644
--- a/gcc/ada/stringt.ads
+++ b/gcc/ada/stringt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,7 +30,7 @@
------------------------------------------------------------------------------
with Namet; use Namet;
-with System; use System;
+with System;
with Types; use Types;
package Stringt is
@@ -62,8 +62,7 @@ package Stringt is
--------------------------------------
procedure Initialize;
- -- Initializes the strings table for a new compilation. Note that
- -- Initialize must not be called if Tree_Read is used.
+ -- Initializes the strings table for a new compilation.
procedure Lock;
-- Lock internal tables before calling back end
@@ -148,15 +147,6 @@ package Stringt is
function Strings_Address return System.Address;
-- Return address of Strings table (used by Back_End call to Gigi)
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines. Note that Initialize should not be called if
- -- Tree_Read is used. Tree_Read includes all necessary initialization.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
procedure Write_Char_Code (Code : Char_Code);
-- Procedure to write a character code value, used for debugging purposes
-- for writing character codes. If the character code is in the range
diff --git a/gcc/ada/stringt.h b/gcc/ada/stringt.h
index 911c61b..5cbb301 100644
--- a/gcc/ada/stringt.h
+++ b/gcc/ada/stringt.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/style.adb b/gcc/ada/style.adb
index 2778127..4b39fe7 100644
--- a/gcc/ada/style.adb
+++ b/gcc/ada/style.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/style.ads b/gcc/ada/style.ads
index 0e75389..dce4f1e 100644
--- a/gcc/ada/style.ads
+++ b/gcc/ada/style.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb
index 375664b..565c41a 100644
--- a/gcc/ada/styleg.adb
+++ b/gcc/ada/styleg.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -207,13 +207,13 @@ package body Styleg is
function OK_Boolean_Operand (N : Node_Id) return Boolean is
begin
- if Nkind_In (N, N_Identifier, N_Expanded_Name) then
+ if Nkind (N) in N_Identifier | N_Expanded_Name then
return True;
elsif Nkind (N) = N_Op_Not then
return OK_Boolean_Operand (Original_Node (Right_Opnd (N)));
- elsif Nkind_In (N, N_Op_And, N_Op_Or) then
+ elsif Nkind (N) in N_Op_And | N_Op_Or then
return OK_Boolean_Operand (Original_Node (Left_Opnd (N)))
and then
OK_Boolean_Operand (Original_Node (Right_Opnd (N)));
@@ -233,7 +233,7 @@ package body Styleg is
Orig : constant Node_Id := Original_Node (Node);
begin
- if Nkind_In (Orig, N_Op_And, N_Op_Or) then
+ if Nkind (Orig) in N_Op_And | N_Op_Or then
declare
L : constant Node_Id := Original_Node (Left_Opnd (Orig));
R : constant Node_Id := Original_Node (Right_Opnd (Orig));
diff --git a/gcc/ada/styleg.ads b/gcc/ada/styleg.ads
index f176c02..ef645a8 100644
--- a/gcc/ada/styleg.ads
+++ b/gcc/ada/styleg.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/stylesw.adb b/gcc/ada/stylesw.adb
index 929e2d7..43f6e1a 100644
--- a/gcc/ada/stylesw.adb
+++ b/gcc/ada/stylesw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/stylesw.ads b/gcc/ada/stylesw.ads
index de1f92d..f78b01d 100644
--- a/gcc/ada/stylesw.ads
+++ b/gcc/ada/stylesw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb
index 3902b66..4ae5c30 100644
--- a/gcc/ada/switch-b.adb
+++ b/gcc/ada/switch-b.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/switch-b.ads b/gcc/ada/switch-b.ads
index 64a4b7d..a1461b5 100644
--- a/gcc/ada/switch-b.ads
+++ b/gcc/ada/switch-b.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb
index 5af71c6..c5f2e1c 100644
--- a/gcc/ada/switch-c.adb
+++ b/gcc/ada/switch-c.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1170,7 +1170,7 @@ package body Switch.C is
when 'Q' =>
Ptr := Ptr + 1;
- Force_ALI_Tree_File := True;
+ Force_ALI_File := True;
Try_Semantics := True;
-- -gnatr (restrictions as warnings)
@@ -1250,13 +1250,6 @@ package body Switch.C is
Print_Standard := True;
Ptr := Ptr + 1;
- -- -gnatt (output tree)
-
- when 't' =>
- Ptr := Ptr + 1;
- Tree_Output := True;
- Back_Annotate_Rep_Info := True;
-
-- -gnatT (change start of internal table sizes)
when 'T' =>
diff --git a/gcc/ada/switch-c.ads b/gcc/ada/switch-c.ads
index c06f250..fd258ca 100644
--- a/gcc/ada/switch-c.ads
+++ b/gcc/ada/switch-c.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb
index 0f6264b..ec4e3ff 100644
--- a/gcc/ada/switch-m.adb
+++ b/gcc/ada/switch-m.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/switch-m.ads b/gcc/ada/switch-m.ads
index dc7ed7c..1165dab 100644
--- a/gcc/ada/switch-m.ads
+++ b/gcc/ada/switch-m.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/switch.adb b/gcc/ada/switch.adb
index 7cdaa19..5da63eb 100644
--- a/gcc/ada/switch.adb
+++ b/gcc/ada/switch.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -163,9 +163,9 @@ package body Switch is
return Is_Switch (Switch_Chars)
and then
(Switch_Chars (First .. Last) = "-param" or else
+ Switch_Chars (First .. Last) = "dumpdir" or else
Switch_Chars (First .. Last) = "dumpbase" or else
- Switch_Chars (First .. Last) = "auxbase-strip" or else
- Switch_Chars (First .. Last) = "auxbase");
+ Switch_Chars (First .. Last) = "dumpbase-ext");
end Is_Internal_GCC_Switch;
---------------
diff --git a/gcc/ada/switch.ads b/gcc/ada/switch.ads
index 708d329..7fdfb52 100644
--- a/gcc/ada/switch.ads
+++ b/gcc/ada/switch.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -77,7 +77,7 @@ package Switch is
function Is_Internal_GCC_Switch (Switch_Chars : String) return Boolean;
-- Returns True iff Switch_Chars represents an internal GCC switch to be
- -- followed by a single argument, such as -dumpbase, --param or -auxbase.
+ -- followed by a single argument, such as -dumpbase, or --param.
-- Even though passed by the "gcc" driver, these need not be stored in ALI
-- files and may safely be ignored by non GCC back-ends.
diff --git a/gcc/ada/symbols.adb b/gcc/ada/symbols.adb
index 481593c..d8d4992 100644
--- a/gcc/ada/symbols.adb
+++ b/gcc/ada/symbols.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/symbols.ads b/gcc/ada/symbols.ads
index 9a1e7f5..0193830 100644
--- a/gcc/ada/symbols.ads
+++ b/gcc/ada/symbols.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c
index 1e1f5ee..51ffbd5 100644
--- a/gcc/ada/sysdep.c
+++ b/gcc/ada/sysdep.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -703,7 +703,7 @@ __gnat_localtime_tzoff (const time_t *timer, const int *is_historic, long *off)
to get timezone settings that depend on the year. We cannot use them as
we still support Windows XP and Windows 2003. */
- status = (tzi_status >= 0 && tzi_status <= 2)
+ status = tzi_status <= 2
&& FileTimeToSystemTime (&utc_time.ft_time, &utc_sys_time)
&& SystemTimeToTzSpecificLocalTime (&tzi, &utc_sys_time, &local_sys_time)
&& SystemTimeToFileTime (&local_sys_time, &local_time.ft_time);
diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb
index 9794047..cd7cbef 100644
--- a/gcc/ada/table.adb
+++ b/gcc/ada/table.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,7 +33,6 @@ with Debug; use Debug;
with Opt; use Opt;
with Output; use Output;
with System; use System;
-with Tree_IO; use Tree_IO;
with System.Memory; use System.Memory;
@@ -60,10 +59,6 @@ package body Table is
-- in Max. Works correctly to do an initial allocation if the table
-- is currently null.
- function Tree_Get_Table_Address return Address;
- -- Return Null_Address if the table length is zero,
- -- Table (First)'Address if not.
-
pragma Warnings (Off);
-- Turn off warnings. The following unchecked conversions are only used
-- internally in this package, and cannot never result in any instances
@@ -400,60 +395,6 @@ package body Table is
end if;
end Set_Last;
- ----------------------------
- -- Tree_Get_Table_Address --
- ----------------------------
-
- function Tree_Get_Table_Address return Address is
- begin
- if Length = 0 then
- return Null_Address;
- else
- return Table (First)'Address;
- end if;
- end Tree_Get_Table_Address;
-
- ---------------
- -- Tree_Read --
- ---------------
-
- -- Note: we allocate only the space required to accommodate the data
- -- actually written, which means that a Tree_Write/Tree_Read sequence
- -- does an implicit Release.
-
- procedure Tree_Read is
- begin
- Tree_Read_Int (Max);
- Last_Val := Max;
- Length := Max - Min + 1;
- Reallocate;
-
- Tree_Read_Data
- (Tree_Get_Table_Address,
- (Last_Val - Int (First) + 1) *
-
- -- Note the importance of parenthesizing the following division
- -- to avoid the possibility of intermediate overflow.
-
- (Table_Type'Component_Size / Storage_Unit));
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- -- Note: we write out only the currently valid data, not the entire
- -- contents of the allocated array. See note above on Tree_Read.
-
- procedure Tree_Write is
- begin
- Tree_Write_Int (Int (Last));
- Tree_Write_Data
- (Tree_Get_Table_Address,
- (Last_Val - Int (First) + 1) *
- (Table_Type'Component_Size / Storage_Unit));
- end Tree_Write;
-
begin
Init;
end Table;
diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads
index 5f03cf3..e8cbe81 100644
--- a/gcc/ada/table.ads
+++ b/gcc/ada/table.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -221,13 +221,6 @@ package Table is
-- Given a Saved_Table value returned by a prior call to Save, restores
-- the table to the state it was in at the time of the Save call.
- procedure Tree_Write;
- -- Writes out contents of table using Tree_IO
-
- procedure Tree_Read;
- -- Initializes table by reading contents previously written with the
- -- Tree_Write call (also using Tree_IO).
-
private
Last_Val : Int;
diff --git a/gcc/ada/targext.c b/gcc/ada/targext.c
index d761b2a..2dea975 100644
--- a/gcc/ada/targext.c
+++ b/gcc/ada/targext.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2005-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2005-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb
index 3aa638a..9e15710 100644
--- a/gcc/ada/targparm.adb
+++ b/gcc/ada/targparm.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -334,6 +334,14 @@ package body Targparm is
Opt.Locking_Policy := 'C';
goto Line_Loop_Continue;
+ -- Test for pragma Profile (Jorvik);
+
+ elsif Looking_At_Skip ("pragma Profile (Jorvik);") then
+ Set_Profile_Restrictions (Jorvik);
+ Opt.Task_Dispatching_Policy := 'F';
+ Opt.Locking_Policy := 'C';
+ goto Line_Loop_Continue;
+
-- Test for pragma Profile (GNAT_Extended_Ravenscar);
elsif Looking_At_Skip
diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads
index d9465b5..7f98a1d 100644
--- a/gcc/ada/targparm.ads
+++ b/gcc/ada/targparm.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/tb-gcc.c b/gcc/ada/tb-gcc.c
deleted file mode 100644
index 74d0c21..0000000
--- a/gcc/ada/tb-gcc.c
+++ /dev/null
@@ -1,125 +0,0 @@
-/****************************************************************************
- * *
- * GNAT RUN-TIME COMPONENTS *
- * *
- * T R A C E B A C K - G C C t a b l e s *
- * *
- * C Implementation File *
- * *
- * Copyright (C) 2004-2019, Free Software Foundation, Inc. *
- * *
- * GNAT is free software; you can redistribute it and/or modify it under *
- * terms of the GNU General Public License as published by the Free Soft- *
- * ware Foundation; either version 3, or (at your option) any later ver- *
- * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
- * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
- * or FITNESS FOR A PARTICULAR PURPOSE. *
- * *
- * As a special exception under Section 7 of GPL version 3, you are granted *
- * additional permissions described in the GCC Runtime Library Exception, *
- * version 3.1, as published by the Free Software Foundation. *
- * *
- * You should have received a copy of the GNU General Public License and *
- * a copy of the GCC Runtime Library Exception along with this program; *
- * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see *
- * <http://www.gnu.org/licenses/>. *
- * *
- * GNAT was originally developed by the GNAT team at New York University. *
- * Extensive contributions were provided by Ada Core Technologies Inc. *
- * *
- ****************************************************************************/
-
-/* This is an implementation of the __gnat_backtrace routine using the
- underlying GCC unwinding support associated with the exception handling
- infrastructure. This will only work for ZCX based applications. */
-
-#include <unwind.h>
-
-/* The implementation boils down to a call to _Unwind_Backtrace with a
- tailored callback and carried-on data structure to keep track of the
- input parameters we got as well as of the basic processing state. */
-
-/******************
- * trace_callback *
- ******************/
-
-#if !defined (__USING_SJLJ_EXCEPTIONS__)
-
-typedef struct {
- void ** traceback;
- int max_len;
- void * exclude_min;
- void * exclude_max;
- int n_frames_to_skip;
- int n_frames_skipped;
- int n_entries_filled;
-} uw_data_t;
-
-#if defined (__ia64__) && defined (__hpux__)
-#include <uwx.h>
-#endif
-
-static _Unwind_Reason_Code
-trace_callback (struct _Unwind_Context * uw_context, uw_data_t * uw_data)
-{
- char * pc;
-
-#if defined (__ia64__) && defined (__hpux__) && defined (USE_LIBUNWIND_EXCEPTIONS)
- /* Work around problem with _Unwind_GetIP on ia64 HP-UX. */
- uwx_get_reg ((struct uwx_env *) uw_context, UWX_REG_IP, (uint64_t *) &pc);
-#else
- pc = (char *) _Unwind_GetIP (uw_context);
-#endif
-
- if (uw_data->n_frames_skipped < uw_data->n_frames_to_skip)
- {
- uw_data->n_frames_skipped ++;
- return _URC_NO_REASON;
- }
-
- if (uw_data->n_entries_filled >= uw_data->max_len)
- return _URC_NORMAL_STOP;
-
- if (pc < (char *)uw_data->exclude_min || pc > (char *)uw_data->exclude_max)
- uw_data->traceback [uw_data->n_entries_filled ++] = pc + PC_ADJUST;
-
- return _URC_NO_REASON;
-}
-
-#endif
-
-/********************
- * __gnat_backtrace *
- ********************/
-
-int
-__gnat_backtrace (void ** traceback __attribute__((unused)),
- int max_len __attribute__((unused)),
- void * exclude_min __attribute__((unused)),
- void * exclude_max __attribute__((unused)),
- int skip_frames __attribute__((unused)))
-{
-#if defined (__USING_SJLJ_EXCEPTIONS__)
- /* We have no unwind material (tables) at hand with sjlj eh, and no
- way to retrieve complete and accurate call chain information from
- the context stack we maintain. */
- return 0;
-#else
- uw_data_t uw_data;
- /* State carried over during the whole unwinding process. */
-
- uw_data.traceback = traceback;
- uw_data.max_len = max_len;
- uw_data.exclude_min = exclude_min;
- uw_data.exclude_max = exclude_max;
-
- uw_data.n_frames_to_skip = skip_frames;
-
- uw_data.n_frames_skipped = 0;
- uw_data.n_entries_filled = 0;
-
- _Unwind_Backtrace ((_Unwind_Trace_Fn)trace_callback, &uw_data);
-
- return uw_data.n_entries_filled;
-#endif
-}
diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb
index bb5532d..3b33ee7 100644
--- a/gcc/ada/tbuild.adb
+++ b/gcc/ada/tbuild.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -116,10 +116,9 @@ package body Tbuild is
Result : Node_Id;
begin
- if Present (Etype (Expr))
- and then (Etype (Expr)) = Typ
- then
+ if Present (Etype (Expr)) and then Etype (Expr) = Typ then
return Relocate_Node (Expr);
+
else
Result :=
Make_Type_Conversion (Sloc (Expr),
@@ -176,8 +175,8 @@ package body Tbuild is
Attribute_Name => Attribute_Name);
begin
- pragma Assert (Nam_In (Attribute_Name, Name_Address,
- Name_Unrestricted_Access));
+ pragma Assert
+ (Attribute_Name in Name_Address | Name_Unrestricted_Access);
Set_Must_Be_Byte_Aligned (N, True);
return N;
end Make_Byte_Aligned_Attribute_Reference;
@@ -353,6 +352,7 @@ package body Tbuild is
Check_Restriction (No_Implicit_Loops, Node);
if Present (Iteration_Scheme)
+ and then Nkind (Iteration_Scheme) /= N_Iterator_Specification
and then Present (Condition (Iteration_Scheme))
then
Check_Restriction (No_Implicit_Conditionals, Node);
@@ -366,6 +366,24 @@ package body Tbuild is
End_Label => End_Label);
end Make_Implicit_Loop_Statement;
+ --------------------
+ -- Make_Increment --
+ --------------------
+
+ function Make_Increment
+ (Loc : Source_Ptr; Index : Entity_Id; Typ : Entity_Id) return Node_Id is
+ begin
+ return Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Index, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Typ, Loc),
+ Attribute_Name => Name_Succ,
+ Expressions => New_List (
+ New_Occurrence_Of (Index, Loc))));
+ end Make_Increment;
+
--------------------------
-- Make_Integer_Literal --
---------------------------
@@ -779,6 +797,23 @@ package body Tbuild is
return Result;
end OK_Convert_To;
+ --------------
+ -- Sel_Comp --
+ --------------
+
+ function Sel_Comp (Pre : Node_Id; Sel : String) return Node_Id is
+ begin
+ return Make_Selected_Component
+ (Sloc => Sloc (Pre),
+ Prefix => Pre,
+ Selector_Name => Make_Identifier (Sloc (Pre), Name_Find (Sel)));
+ end Sel_Comp;
+
+ function Sel_Comp (Pre, Sel : String; Loc : Source_Ptr) return Node_Id is
+ begin
+ return Sel_Comp (Make_Identifier (Loc, Name_Find (Pre)), Sel);
+ end Sel_Comp;
+
-------------
-- Set_NOD --
-------------
@@ -853,8 +888,8 @@ package body Tbuild is
then
return Relocate_Node (Expr);
- -- Cases where the inner expression is itself an unchecked conversion
- -- to the same type, and we can thus eliminate the outer conversion.
+ -- Case where the expression is itself an unchecked conversion to
+ -- the same type, and we can thus eliminate the outer conversion.
elsif Nkind (Expr) = N_Unchecked_Type_Conversion
and then Entity (Subtype_Mark (Expr)) = Typ
diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads
index b7bee82..70bf653 100644
--- a/gcc/ada/tbuild.ads
+++ b/gcc/ada/tbuild.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -140,6 +140,10 @@ package Tbuild is
-- all cases, and the second only for while loops), and if one of these
-- restrictions is being violated, an error message is posted on Node.
+ function Make_Increment
+ (Loc : Source_Ptr; Index : Entity_Id; Typ : Entity_Id) return Node_Id;
+ -- Return an assignment statement of the form "Index := Typ'Succ (Index);"
+
function Make_Integer_Literal
(Loc : Source_Ptr;
Intval : Int) return Node_Id;
@@ -331,6 +335,11 @@ package Tbuild is
-- fixed-point small is called typ_SMALL where typ is the name of the
-- fixed-point type (as passed in Related_Id), and Suffix is "SMALL".
+ function Sel_Comp (Pre, Sel : String; Loc : Source_Ptr) return Node_Id;
+ function Sel_Comp (Pre : Node_Id; Sel : String) return Node_Id;
+ -- Create a selected component of the form Pre.Sel; that is, Pre is the
+ -- prefix, and Sel is the selector name.
+
function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id;
-- Like Convert_To, except that a conversion node is always generated, and
-- the Conversion_OK flag is set on this conversion node.
diff --git a/gcc/ada/tempdir.adb b/gcc/ada/tempdir.adb
index e13a729..c707395 100644
--- a/gcc/ada/tempdir.adb
+++ b/gcc/ada/tempdir.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/tempdir.ads b/gcc/ada/tempdir.ads
index c7babe8..dbd6564 100644
--- a/gcc/ada/tempdir.ads
+++ b/gcc/ada/tempdir.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/terminals.c b/gcc/ada/terminals.c
index af4417f..81388a7 100644
--- a/gcc/ada/terminals.c
+++ b/gcc/ada/terminals.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2008-2019, AdaCore *
+ * Copyright (C) 2008-2020, AdaCore *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -153,6 +153,7 @@ __gnat_setup_winsize (void *desc ATTRIBUTE_UNUSED,
#include <windows.h>
#include <winternl.h>
+#include <io.h>
#define MAXPATHLEN 1024
@@ -194,9 +195,6 @@ is_gui_app (char *exe)
{
HANDLE hImage;
- DWORD bytes;
- DWORD iSection;
- DWORD SectionOffset;
DWORD CoffHeaderOffset;
DWORD MoreDosHeader[16];
CHAR *file;
@@ -207,7 +205,6 @@ is_gui_app (char *exe)
IMAGE_DOS_HEADER image_dos_header;
IMAGE_FILE_HEADER image_file_header;
IMAGE_OPTIONAL_HEADER image_optional_header;
- IMAGE_SECTION_HEADER image_section_header;
/*
* Open the reference file.
@@ -264,7 +261,7 @@ is_gui_app (char *exe)
*/
CoffHeaderOffset = AbsoluteSeek(hImage, image_dos_header.e_lfanew) +
sizeof(ULONG);
- if (CoffHeaderOffset < 0) {
+ if (CoffHeaderOffset == (DWORD) -1) {
CloseHandle (hImage);
return -1;
}
@@ -278,9 +275,6 @@ is_gui_app (char *exe)
return -1;
}
- SectionOffset = CoffHeaderOffset + IMAGE_SIZEOF_FILE_HEADER +
- IMAGE_SIZEOF_NT_OPTIONAL_HEADER;
-
ReadBytes(hImage, &image_file_header, IMAGE_SIZEOF_FILE_HEADER);
/*
@@ -351,18 +345,18 @@ ReadBytes (HANDLE hFile, LPVOID buffer, DWORD size)
}
static int
-nt_spawnve (char *exe, char **argv, char *env, struct TTY_Process *process)
+nt_spawnve (char *exe ATTRIBUTE_UNUSED, char **argv, char *env,
+ struct TTY_Process *process)
{
STARTUPINFO start;
SECURITY_ATTRIBUTES sec_attrs;
SECURITY_DESCRIPTOR sec_desc;
DWORD flags;
- char dir[ MAXPATHLEN ];
int pid;
int is_gui, use_cmd;
char *cmdline, *parg, **targ;
int do_quoting = 0;
- char escape_char;
+ char escape_char = 0;
int arglen;
/* we have to do some conjuring here to put argv and envp into the
@@ -483,12 +477,8 @@ nt_spawnve (char *exe, char **argv, char *env, struct TTY_Process *process)
if (need_quotes)
{
int escape_char_run = 0;
- char * first;
- char * last;
p = *targ;
- first = p;
- last = p + strlen (p) - 1;
*parg++ = '"';
for ( ; *p; p++)
{
@@ -572,8 +562,8 @@ nt_spawnve (char *exe, char **argv, char *env, struct TTY_Process *process)
flags, env, NULL, &start, &process->procinfo))
goto EH_Fail;
- pid = (int) process->procinfo.hProcess;
- process->pid=pid;
+ pid = (int) (intptr_t) process->procinfo.hProcess;
+ process->pid = pid;
return pid;
@@ -635,7 +625,6 @@ __gnat_setup_child_communication
int Use_Pipes)
{
int cpid;
- HANDLE parent;
SECURITY_ATTRIBUTES sec_attrs;
char slavePath [MAX_PATH];
char **nargv;
@@ -644,8 +633,6 @@ __gnat_setup_child_communication
char pipeNameIn[100];
HANDLE hSlaveInDrv = NULL; /* Handle to communicate with slave driver */
- parent = GetCurrentProcess ();
-
/* Set inheritance for the pipe handles */
sec_attrs.nLength = sizeof (SECURITY_ATTRIBUTES);
sec_attrs.bInheritHandle = TRUE;
@@ -674,7 +661,7 @@ __gnat_setup_child_communication
/* We create a named pipe for Input, as we handle input by sending special
commands to the explaunch process, that uses it to feed the actual input
of the process */
- sprintf(pipeNameIn, "%sIn%08x_%08x", EXP_PIPE_BASENAME,
+ sprintf(pipeNameIn, "%sIn%08lx_%08x", EXP_PIPE_BASENAME,
GetCurrentProcessId(), pipeNameId);
pipeNameId++;
@@ -765,8 +752,8 @@ __gnat_setup_parent_communication
int* err,
int* pid)
{
- *in = _open_osfhandle ((long) process->w_infd, 0);
- *out = _open_osfhandle ((long) process->w_outfd, 0);
+ *in = _open_osfhandle ((intptr_t) process->w_infd, 0);
+ *out = _open_osfhandle ((intptr_t) process->w_outfd, 0);
/* child's stderr is always redirected to outfd */
*err = *out;
*pid = process->pid;
@@ -811,13 +798,13 @@ cache_system_info (void)
os_subtype = OS_NT;
}
-static BOOL CALLBACK
-find_child_console (HWND hwnd, child_process * cp)
+static WINBOOL CALLBACK
+find_child_console (HWND hwnd, LPARAM param)
{
- DWORD thread_id;
+ child_process *cp = (child_process *) param;
DWORD process_id;
- thread_id = GetWindowThreadProcessId (hwnd, &process_id);
+ (void) GetWindowThreadProcessId (hwnd, &process_id);
if (process_id == cp->procinfo->dwProcessId)
{
char window_class[32];
@@ -837,27 +824,6 @@ find_child_console (HWND hwnd, child_process * cp)
}
int
-__gnat_interrupt_process (struct TTY_Process* p)
-{
- char buf[2];
- DWORD written;
- BOOL bret;
-
- if (p->usePipe == TRUE) {
- bret = FALSE;
- } else {
- buf[0] = EXP_SLAVE_KILL;
- buf[1] = EXP_KILL_CTRL_C;
- bret = WriteFile (p->w_infd, buf, 2, &written, NULL);
- }
-
- if (bret == FALSE) {
- return __gnat_interrupt_pid (p->procinfo.dwProcessId);
- }
- return 0;
-}
-
-int
__gnat_interrupt_pid (int pid)
{
volatile child_process cp;
@@ -943,6 +909,27 @@ __gnat_interrupt_pid (int pid)
return rc;
}
+int
+__gnat_interrupt_process (struct TTY_Process* p)
+{
+ char buf[2];
+ DWORD written;
+ BOOL bret;
+
+ if (p->usePipe == TRUE) {
+ bret = FALSE;
+ } else {
+ buf[0] = EXP_SLAVE_KILL;
+ buf[1] = EXP_KILL_CTRL_C;
+ bret = WriteFile (p->w_infd, buf, 2, &written, NULL);
+ }
+
+ if (bret == FALSE) {
+ return __gnat_interrupt_pid (p->procinfo.dwProcessId);
+ }
+ return 0;
+}
+
/* kill a process, as this implementation use CreateProcess on Win32 we need
to use Win32 TerminateProcess API */
int
@@ -974,13 +961,13 @@ typedef struct {
HANDLE hwnd;
} pid_struct;
-static BOOL CALLBACK
-find_process_handle (HWND hwnd, pid_struct * ps)
+static WINBOOL CALLBACK
+find_process_handle (HWND hwnd, LPARAM param)
{
- DWORD thread_id;
+ pid_struct *ps = (pid_struct *) param;
DWORD process_id;
- thread_id = GetWindowThreadProcessId (hwnd, &process_id);
+ (void) GetWindowThreadProcessId (hwnd, &process_id);
if (process_id == ps->dwProcessId)
{
ps->hwnd = hwnd;
@@ -1085,9 +1072,8 @@ __gnat_new_tty (void)
}
void
-__gnat_reset_tty (TTY_Handle* t)
+__gnat_reset_tty (TTY_Handle* t ATTRIBUTE_UNUSED)
{
- return;
}
void
@@ -1097,7 +1083,8 @@ __gnat_close_tty (TTY_Handle* t)
}
void
-__gnat_setup_winsize (void *desc, int rows, int columns)
+__gnat_setup_winsize (void *desc ATTRIBUTE_UNUSED,
+ int rows ATTRIBUTE_UNUSED, int columns ATTRIBUTE_UNUSED)
{
}
diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c
index 9e74282..d643cfc 100644
--- a/gcc/ada/tracebak.c
+++ b/gcc/ada/tracebak.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2000-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 2000-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -588,7 +588,101 @@ is_return_from(void *symbol_addr, void *ret_addr)
define it to a reasonable value to avoid a compilation error. */
#define _URC_NORMAL_STOP 0
#endif
-#include "tb-gcc.c"
+
+/* This is an implementation of the __gnat_backtrace routine using the
+ underlying GCC unwinding support associated with the exception handling
+ infrastructure. This will only work for ZCX based applications. */
+
+#include <unwind.h>
+
+/* The implementation boils down to a call to _Unwind_Backtrace with a
+ tailored callback and carried-on data structure to keep track of the
+ input parameters we got as well as of the basic processing state. */
+
+/******************
+ * trace_callback *
+ ******************/
+
+#if !defined (__USING_SJLJ_EXCEPTIONS__)
+
+typedef struct {
+ void ** traceback;
+ int max_len;
+ void * exclude_min;
+ void * exclude_max;
+ int n_frames_to_skip;
+ int n_frames_skipped;
+ int n_entries_filled;
+} uw_data_t;
+
+#if defined (__ia64__) && defined (__hpux__)
+#include <uwx.h>
+#endif
+
+static _Unwind_Reason_Code
+trace_callback (struct _Unwind_Context * uw_context, uw_data_t * uw_data)
+{
+ char * pc;
+
+#if defined (__ia64__) && defined (__hpux__) && defined (USE_LIBUNWIND_EXCEPTIONS)
+ /* Work around problem with _Unwind_GetIP on ia64 HP-UX. */
+ uwx_get_reg ((struct uwx_env *) uw_context, UWX_REG_IP, (uint64_t *) &pc);
+#else
+ pc = (char *) _Unwind_GetIP (uw_context);
+#endif
+
+ if (uw_data->n_frames_skipped < uw_data->n_frames_to_skip)
+ {
+ uw_data->n_frames_skipped ++;
+ return _URC_NO_REASON;
+ }
+
+ if (uw_data->n_entries_filled >= uw_data->max_len)
+ return _URC_NORMAL_STOP;
+
+ if (pc < (char *)uw_data->exclude_min || pc > (char *)uw_data->exclude_max)
+ uw_data->traceback [uw_data->n_entries_filled ++] = pc + PC_ADJUST;
+
+ return _URC_NO_REASON;
+}
+
+#endif
+
+/********************
+ * __gnat_backtrace *
+ ********************/
+
+int
+__gnat_backtrace (void ** traceback __attribute__((unused)),
+ int max_len __attribute__((unused)),
+ void * exclude_min __attribute__((unused)),
+ void * exclude_max __attribute__((unused)),
+ int skip_frames __attribute__((unused)))
+{
+#if defined (__USING_SJLJ_EXCEPTIONS__)
+ /* We have no unwind material (tables) at hand with sjlj eh, and no
+ way to retrieve complete and accurate call chain information from
+ the context stack we maintain. */
+ return 0;
+#else
+ uw_data_t uw_data;
+ /* State carried over during the whole unwinding process. */
+
+ uw_data.traceback = traceback;
+ uw_data.max_len = max_len;
+ uw_data.exclude_min = exclude_min;
+ uw_data.exclude_max = exclude_max;
+
+ uw_data.n_frames_to_skip = skip_frames;
+
+ uw_data.n_frames_skipped = 0;
+ uw_data.n_entries_filled = 0;
+
+ _Unwind_Backtrace ((_Unwind_Trace_Fn)trace_callback, &uw_data);
+
+ return uw_data.n_entries_filled;
+#endif
+}
/*------------------------------------------------------------------*
*-- The generic implementation based on frame layout assumptions --*
@@ -596,6 +690,9 @@ is_return_from(void *symbol_addr, void *ret_addr)
#elif defined (USE_GENERIC_UNWINDER)
+/* No warning since the cases where FRAME_LEVEL > 0 are known to work. */
+#pragma GCC diagnostic ignored "-Wframe-address"
+
#ifndef CURRENT_STACK_FRAME
# define CURRENT_STACK_FRAME ({ char __csf; &__csf; })
#endif
diff --git a/gcc/ada/tree_gen.adb b/gcc/ada/tree_gen.adb
deleted file mode 100644
index 16efca0..0000000
--- a/gcc/ada/tree_gen.adb
+++ /dev/null
@@ -1,72 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- T R E E _ G E N --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT 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 distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Aspects;
-with Atree;
-with Elists;
-with Fname;
-with Lib;
-with Namet;
-with Nlists;
-with Opt;
-with Osint.C;
-with Repinfo;
-with Sem_Aux;
-with Sinput;
-with Stand;
-with Stringt;
-with Uintp;
-with Urealp;
-
-with Tree_In;
-pragma Warnings (Off, Tree_In);
--- We do not use Tree_In in the compiler, but it is small, and worth including
--- so that we get the proper license check for Tree_In when the compiler is
--- built. This will avoid adding bad dependencies to Tree_In and blowing ASIS.
-
-procedure Tree_Gen is
-begin
- if Opt.Tree_Output then
- Osint.C.Tree_Create;
-
- Opt.Tree_Write;
- Atree.Tree_Write;
- Elists.Tree_Write;
- Fname.Tree_Write;
- Lib.Tree_Write;
- Namet.Tree_Write;
- Nlists.Tree_Write;
- Sem_Aux.Tree_Write;
- Sinput.Tree_Write;
- Stand.Tree_Write;
- Stringt.Tree_Write;
- Uintp.Tree_Write;
- Urealp.Tree_Write;
- Repinfo.Tree_Write;
- Aspects.Tree_Write;
-
- Osint.C.Tree_Close;
- end if;
-end Tree_Gen;
diff --git a/gcc/ada/tree_gen.ads b/gcc/ada/tree_gen.ads
deleted file mode 100644
index 19c51b2..0000000
--- a/gcc/ada/tree_gen.ads
+++ /dev/null
@@ -1,28 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- T R E E _ G E N --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT 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 distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This procedure is used to write out the tree if the option is set
-
-procedure Tree_Gen;
diff --git a/gcc/ada/tree_io.adb b/gcc/ada/tree_io.adb
deleted file mode 100644
index 63f198e..0000000
--- a/gcc/ada/tree_io.adb
+++ /dev/null
@@ -1,661 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- T R E E _ I O --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Debug; use Debug;
-with Output; use Output;
-with Unchecked_Conversion;
-
-package body Tree_IO is
- Debug_Flag_Tree : Boolean := False;
- -- Debug flag for debug output from tree read/write
-
- -------------------------------------------
- -- Compression Scheme Used for Tree File --
- -------------------------------------------
-
- -- We don't just write the data directly, but instead do a mild form
- -- of compression, since we expect lots of compressible zeroes and
- -- blanks. The compression scheme is as follows:
-
- -- 00nnnnnn followed by nnnnnn bytes (non compressed data)
- -- 01nnnnnn indicates nnnnnn binary zero bytes
- -- 10nnnnnn indicates nnnnnn ASCII space bytes
- -- 11nnnnnn bbbbbbbb indicates nnnnnnnn occurrences of byte bbbbbbbb
-
- -- Since we expect many zeroes in trees, and many spaces in sources,
- -- this compression should be reasonably efficient. We can put in
- -- something better later on.
-
- -- Note that this compression applies to the Write_Tree_Data and
- -- Read_Tree_Data calls, not to the calls to read and write single
- -- scalar values, which are written in memory format without any
- -- compression.
-
- C_Noncomp : constant := 2#00_000000#;
- C_Zeros : constant := 2#01_000000#;
- C_Spaces : constant := 2#10_000000#;
- C_Repeat : constant := 2#11_000000#;
- -- Codes for compression sequences
-
- Max_Count : constant := 63;
- -- Maximum data length for one compression sequence
-
- -- The above compression scheme applies only to data written with the
- -- Tree_Write routine and read with Tree_Read. Data written using the
- -- Tree_Write_Char or Tree_Write_Int routines and read using the
- -- corresponding input routines is not compressed.
-
- type Int_Bytes is array (1 .. 4) of Byte;
- for Int_Bytes'Size use 32;
-
- function To_Int_Bytes is new Unchecked_Conversion (Int, Int_Bytes);
- function To_Int is new Unchecked_Conversion (Int_Bytes, Int);
-
- ----------------------
- -- Global Variables --
- ----------------------
-
- Tree_FD : File_Descriptor;
- -- File descriptor for tree
-
- Buflen : constant Int := 8_192;
- -- Length of buffer for read and write file data
-
- Buf : array (Pos range 1 .. Buflen) of Byte;
- -- Read/write file data buffer
-
- Bufn : Nat;
- -- Number of bytes read/written from/to buffer
-
- Buft : Nat;
- -- Total number of bytes in input buffer containing valid data. Used only
- -- for input operations. There is data left to be processed in the buffer
- -- if Buft > Bufn. A value of zero for Buft means that the buffer is empty.
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Read_Buffer;
- -- Reads data into buffer, setting Bufn appropriately
-
- function Read_Byte return Byte;
- pragma Inline (Read_Byte);
- -- Returns next byte from input file, raises Tree_Format_Error if none left
-
- procedure Write_Buffer;
- -- Writes out current buffer contents
-
- procedure Write_Byte (B : Byte);
- pragma Inline (Write_Byte);
- -- Write one byte to output buffer, checking for buffer-full condition
-
- -----------------
- -- Read_Buffer --
- -----------------
-
- procedure Read_Buffer is
- begin
- Buft := Int (Read (Tree_FD, Buf (1)'Address, Integer (Buflen)));
-
- if Buft = 0 then
- raise Tree_Format_Error;
- else
- Bufn := 0;
- end if;
- end Read_Buffer;
-
- ---------------
- -- Read_Byte --
- ---------------
-
- function Read_Byte return Byte is
- begin
- if Bufn = Buft then
- Read_Buffer;
- end if;
-
- Bufn := Bufn + 1;
- return Buf (Bufn);
- end Read_Byte;
-
- --------------------
- -- Tree_Read_Bool --
- --------------------
-
- procedure Tree_Read_Bool (B : out Boolean) is
- begin
- B := Boolean'Val (Read_Byte);
-
- if Debug_Flag_Tree then
- if B then
- Write_Str ("True");
- else
- Write_Str ("False");
- end if;
-
- Write_Eol;
- end if;
- end Tree_Read_Bool;
-
- --------------------
- -- Tree_Read_Char --
- --------------------
-
- procedure Tree_Read_Char (C : out Character) is
- begin
- C := Character'Val (Read_Byte);
-
- if Debug_Flag_Tree then
- Write_Str ("==> transmitting Character = ");
- Write_Char (C);
- Write_Eol;
- end if;
- end Tree_Read_Char;
-
- --------------------
- -- Tree_Read_Data --
- --------------------
-
- procedure Tree_Read_Data (Addr : Address; Length : Int) is
-
- type S is array (Pos) of Byte;
- -- This is a big array, for which we have to suppress the warning
-
- type SP is access all S;
-
- function To_SP is new Unchecked_Conversion (Address, SP);
-
- Data : constant SP := To_SP (Addr);
- -- Data buffer to be read as an indexable array of bytes
-
- OP : Pos := 1;
- -- Pointer to next byte of data buffer to be read into
-
- B : Byte;
- C : Byte;
- L : Int;
-
- begin
- if Debug_Flag_Tree then
- Write_Str ("==> transmitting ");
- Write_Int (Length);
- Write_Str (" data bytes");
- Write_Eol;
- end if;
-
- -- Verify data length
-
- Tree_Read_Int (L);
-
- if L /= Length then
- Write_Str ("==> transmitting, expected ");
- Write_Int (Length);
- Write_Str (" bytes, found length = ");
- Write_Int (L);
- Write_Eol;
- raise Tree_Format_Error;
- end if;
-
- -- Loop to read data
-
- while OP <= Length loop
-
- -- Get compression control character
-
- B := Read_Byte;
- C := B and 2#00_111111#;
- B := B and 2#11_000000#;
-
- -- Non-repeat case
-
- if B = C_Noncomp then
- if Debug_Flag_Tree then
- Write_Str ("==> uncompressed: ");
- Write_Int (Int (C));
- Write_Str (", starting at ");
- Write_Int (OP);
- Write_Eol;
- end if;
-
- for J in 1 .. C loop
- Data (OP) := Read_Byte;
- OP := OP + 1;
- end loop;
-
- -- Repeated zeroes
-
- elsif B = C_Zeros then
- if Debug_Flag_Tree then
- Write_Str ("==> zeroes: ");
- Write_Int (Int (C));
- Write_Str (", starting at ");
- Write_Int (OP);
- Write_Eol;
- end if;
-
- for J in 1 .. C loop
- Data (OP) := 0;
- OP := OP + 1;
- end loop;
-
- -- Repeated spaces
-
- elsif B = C_Spaces then
- if Debug_Flag_Tree then
- Write_Str ("==> spaces: ");
- Write_Int (Int (C));
- Write_Str (", starting at ");
- Write_Int (OP);
- Write_Eol;
- end if;
-
- for J in 1 .. C loop
- Data (OP) := Character'Pos (' ');
- OP := OP + 1;
- end loop;
-
- -- Specified repeated character
-
- else -- B = C_Repeat
- B := Read_Byte;
-
- if Debug_Flag_Tree then
- Write_Str ("==> other char: ");
- Write_Int (Int (C));
- Write_Str (" (");
- Write_Int (Int (B));
- Write_Char (')');
- Write_Str (", starting at ");
- Write_Int (OP);
- Write_Eol;
- end if;
-
- for J in 1 .. C loop
- Data (OP) := B;
- OP := OP + 1;
- end loop;
- end if;
- end loop;
-
- -- At end of loop, data item must be exactly filled
-
- if OP /= Length + 1 then
- raise Tree_Format_Error;
- end if;
-
- end Tree_Read_Data;
-
- --------------------------
- -- Tree_Read_Initialize --
- --------------------------
-
- procedure Tree_Read_Initialize (Desc : File_Descriptor) is
- begin
- Buft := 0;
- Bufn := 0;
- Tree_FD := Desc;
- Debug_Flag_Tree := Debug_Flag_5;
- end Tree_Read_Initialize;
-
- -------------------
- -- Tree_Read_Int --
- -------------------
-
- procedure Tree_Read_Int (N : out Int) is
- N_Bytes : Int_Bytes;
-
- begin
- for J in 1 .. 4 loop
- N_Bytes (J) := Read_Byte;
- end loop;
-
- N := To_Int (N_Bytes);
-
- if Debug_Flag_Tree then
- Write_Str ("==> transmitting Int = ");
- Write_Int (N);
- Write_Eol;
- end if;
- end Tree_Read_Int;
-
- -------------------
- -- Tree_Read_Str --
- -------------------
-
- procedure Tree_Read_Str (S : out String_Ptr) is
- N : Nat;
-
- begin
- Tree_Read_Int (N);
- S := new String (1 .. Natural (N));
- Tree_Read_Data (S.all (1)'Address, N);
- end Tree_Read_Str;
-
- -------------------------
- -- Tree_Read_Terminate --
- -------------------------
-
- procedure Tree_Read_Terminate is
- begin
- -- Must be at end of input buffer, so we should get Tree_Format_Error
- -- if we try to read one more byte, if not, we have a format error.
-
- declare
- B : Byte;
- pragma Warnings (Off, B);
-
- begin
- B := Read_Byte;
-
- exception
- when Tree_Format_Error => return;
- end;
-
- raise Tree_Format_Error;
- end Tree_Read_Terminate;
-
- ---------------------
- -- Tree_Write_Bool --
- ---------------------
-
- procedure Tree_Write_Bool (B : Boolean) is
- begin
- if Debug_Flag_Tree then
- Write_Str ("==> transmitting Boolean = ");
-
- if B then
- Write_Str ("True");
- else
- Write_Str ("False");
- end if;
-
- Write_Eol;
- end if;
-
- Write_Byte (Boolean'Pos (B));
- end Tree_Write_Bool;
-
- ---------------------
- -- Tree_Write_Char --
- ---------------------
-
- procedure Tree_Write_Char (C : Character) is
- begin
- if Debug_Flag_Tree then
- Write_Str ("==> transmitting Character = ");
- Write_Char (C);
- Write_Eol;
- end if;
-
- Write_Byte (Character'Pos (C));
- end Tree_Write_Char;
-
- ---------------------
- -- Tree_Write_Data --
- ---------------------
-
- procedure Tree_Write_Data (Addr : Address; Length : Int) is
-
- type S is array (Pos) of Byte;
- -- This is a big array, for which we have to suppress the warning
-
- type SP is access all S;
-
- function To_SP is new Unchecked_Conversion (Address, SP);
-
- Data : constant SP := To_SP (Addr);
- -- Pointer to data to be written, converted to array type
-
- IP : Pos := 1;
- -- Input buffer pointer, next byte to be processed
-
- NC : Nat range 0 .. Max_Count := 0;
- -- Number of bytes of non-compressible sequence
-
- C : Byte;
-
- procedure Write_Non_Compressed_Sequence;
- -- Output currently collected sequence of non-compressible data
-
- -----------------------------------
- -- Write_Non_Compressed_Sequence --
- -----------------------------------
-
- procedure Write_Non_Compressed_Sequence is
- begin
- if NC > 0 then
- Write_Byte (C_Noncomp + Byte (NC));
-
- if Debug_Flag_Tree then
- Write_Str ("==> uncompressed: ");
- Write_Int (NC);
- Write_Str (", starting at ");
- Write_Int (IP - NC);
- Write_Eol;
- end if;
-
- for J in reverse 1 .. NC loop
- Write_Byte (Data (IP - J));
- end loop;
-
- NC := 0;
- end if;
- end Write_Non_Compressed_Sequence;
-
- -- Start of processing for Tree_Write_Data
-
- begin
- if Debug_Flag_Tree then
- Write_Str ("==> transmitting ");
- Write_Int (Length);
- Write_Str (" data bytes");
- Write_Eol;
- end if;
-
- -- We write the count at the start, so that we can check it on
- -- the corresponding read to make sure that reads and writes match
-
- Tree_Write_Int (Length);
-
- -- Conversion loop
- -- IP is index of next input character
- -- NC is number of non-compressible bytes saved up
-
- loop
- -- If input is completely processed, then we are all done
-
- if IP > Length then
- Write_Non_Compressed_Sequence;
- return;
- end if;
-
- -- Test for compressible sequence, must be at least three identical
- -- bytes in a row to be worthwhile compressing.
-
- if IP + 2 <= Length
- and then Data (IP) = Data (IP + 1)
- and then Data (IP) = Data (IP + 2)
- then
- Write_Non_Compressed_Sequence;
-
- -- Count length of new compression sequence
-
- C := 3;
- IP := IP + 3;
-
- while IP < Length
- and then Data (IP) = Data (IP - 1)
- and then C < Max_Count
- loop
- C := C + 1;
- IP := IP + 1;
- end loop;
-
- -- Output compression sequence
-
- if Data (IP - 1) = 0 then
- if Debug_Flag_Tree then
- Write_Str ("==> zeroes: ");
- Write_Int (Int (C));
- Write_Str (", starting at ");
- Write_Int (IP - Int (C));
- Write_Eol;
- end if;
-
- Write_Byte (C_Zeros + C);
-
- elsif Data (IP - 1) = Character'Pos (' ') then
- if Debug_Flag_Tree then
- Write_Str ("==> spaces: ");
- Write_Int (Int (C));
- Write_Str (", starting at ");
- Write_Int (IP - Int (C));
- Write_Eol;
- end if;
-
- Write_Byte (C_Spaces + C);
-
- else
- if Debug_Flag_Tree then
- Write_Str ("==> other char: ");
- Write_Int (Int (C));
- Write_Str (" (");
- Write_Int (Int (Data (IP - 1)));
- Write_Char (')');
- Write_Str (", starting at ");
- Write_Int (IP - Int (C));
- Write_Eol;
- end if;
-
- Write_Byte (C_Repeat + C);
- Write_Byte (Data (IP - 1));
- end if;
-
- -- No compression possible here
-
- else
- -- Output non-compressed sequence if at maximum length
-
- if NC = Max_Count then
- Write_Non_Compressed_Sequence;
- end if;
-
- NC := NC + 1;
- IP := IP + 1;
- end if;
- end loop;
-
- end Tree_Write_Data;
-
- ---------------------------
- -- Tree_Write_Initialize --
- ---------------------------
-
- procedure Tree_Write_Initialize (Desc : File_Descriptor) is
- begin
- Bufn := 0;
- Tree_FD := Desc;
- Set_Standard_Error;
- Debug_Flag_Tree := Debug_Flag_5;
- end Tree_Write_Initialize;
-
- --------------------
- -- Tree_Write_Int --
- --------------------
-
- procedure Tree_Write_Int (N : Int) is
- N_Bytes : constant Int_Bytes := To_Int_Bytes (N);
-
- begin
- if Debug_Flag_Tree then
- Write_Str ("==> transmitting Int = ");
- Write_Int (N);
- Write_Eol;
- end if;
-
- for J in 1 .. 4 loop
- Write_Byte (N_Bytes (J));
- end loop;
- end Tree_Write_Int;
-
- --------------------
- -- Tree_Write_Str --
- --------------------
-
- procedure Tree_Write_Str (S : String_Ptr) is
- begin
- Tree_Write_Int (S'Length);
- Tree_Write_Data (S (1)'Address, S'Length);
- end Tree_Write_Str;
-
- --------------------------
- -- Tree_Write_Terminate --
- --------------------------
-
- procedure Tree_Write_Terminate is
- begin
- if Bufn > 0 then
- Write_Buffer;
- end if;
- end Tree_Write_Terminate;
-
- ------------------
- -- Write_Buffer --
- ------------------
-
- procedure Write_Buffer is
- begin
- if Integer (Bufn) = Write (Tree_FD, Buf'Address, Integer (Bufn)) then
- Bufn := 0;
-
- else
- Set_Standard_Error;
- Write_Str ("fatal error: disk full");
- OS_Exit (2);
- end if;
- end Write_Buffer;
-
- ----------------
- -- Write_Byte --
- ----------------
-
- procedure Write_Byte (B : Byte) is
- begin
- Bufn := Bufn + 1;
- Buf (Bufn) := B;
-
- if Bufn = Buflen then
- Write_Buffer;
- end if;
- end Write_Byte;
-
-end Tree_IO;
diff --git a/gcc/ada/tree_io.ads b/gcc/ada/tree_io.ads
deleted file mode 100644
index 78ee4e1..0000000
--- a/gcc/ada/tree_io.ads
+++ /dev/null
@@ -1,128 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- T R E E _ I O --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the routines used to read and write the tree files
--- used by ASIS. Only the actual read and write routines are here. The open,
--- create and close routines are elsewhere (in Osint in the compiler, and in
--- the tree read driver for the tree read interface).
-
-with Types; use Types;
-with System; use System;
-
-pragma Warnings (Off);
--- This package is used also by gnatcoll
-with System.OS_Lib; use System.OS_Lib;
-pragma Warnings (On);
-
-package Tree_IO is
-
- Tree_Format_Error : exception;
- -- Raised if a format error is detected in the input file
-
- ASIS_Version_Number : constant := 34;
- -- ASIS Version. This is used to check for consistency between the compiler
- -- used to generate trees and an ASIS application that is reading the
- -- trees. It must be incremented whenever a change is made to the tree
- -- format that would result in the compiler being incompatible with an
- -- older version of ASIS.
- --
- -- 27 Changes in the tree structures for expression functions
- -- 28 Changes in Snames
- -- 29 Changes in Sem_Ch3 (tree copying in case of discriminant constraint
- -- for concurrent types).
- -- 30 Add Check_Float_Overflow boolean to tree file
- -- 31 Remove read/write of Debug_Pragmas_Disabled/Debug_Pragmas_Enabled
- -- 32 Change the way entities are changed through Next_Entity field in
- -- the hierarchy of child units
- -- 33 Add copying subtrees for rewriting infix calls of operator
- -- functions for the corresponding original nodes.
- -- 34 Add read/write of Address_Is_Private, Ignore_Rep_Clauses,
- -- Ignore_Style_Check_Pragmas, Multiple_Unit_Index. Also this
- -- is the version where rep clauses are removed by -gnatI.
-
- procedure Tree_Read_Initialize (Desc : File_Descriptor);
- -- Called to initialize reading of a tree file. This call must be made
- -- before calls to Tree_Read_xx. No calls to Tree_Write_xx are permitted
- -- after this call.
-
- procedure Tree_Read_Data (Addr : Address; Length : Int);
- -- Checks that the Length provided is the same as what has been provided
- -- to the corresponding Tree_Write_Data from the current tree file,
- -- Tree_Format_Error is raised if it is not the case. If Length is
- -- correct and non zero, reads Length bytes of information into memory
- -- starting at Addr from the current tree file.
-
- procedure Tree_Read_Bool (B : out Boolean);
- -- Reads a single boolean value. The boolean value must have been written
- -- with a call to the Tree_Write_Bool procedure.
-
- procedure Tree_Read_Char (C : out Character);
- -- Reads a single character. The character must have been written with a
- -- call to the Tree_Write_Char procedure.
-
- procedure Tree_Read_Int (N : out Int);
- -- Reads a single integer value. The integer must have been written with
- -- a call to the Tree_Write_Int procedure.
-
- procedure Tree_Read_Str (S : out String_Ptr);
- -- Read string, allocate on heap, and return pointer to allocated string
- -- which always has a lower bound of 1.
-
- procedure Tree_Read_Terminate;
- -- Called after reading all data, checks that the buffer pointers is at
- -- the end of file, raising Tree_Format_Error if not.
-
- procedure Tree_Write_Initialize (Desc : File_Descriptor);
- -- Called to initialize writing of a tree file. This call must be made
- -- before calls to Tree_Write_xx. No calls to Tree_Read_xx are permitted
- -- after this call.
-
- procedure Tree_Write_Data (Addr : Address; Length : Int);
- -- Writes Length then, if Length is not null, Length bytes of data
- -- starting at Addr to current tree file
-
- procedure Tree_Write_Bool (B : Boolean);
- -- Writes a single boolean value to the current tree file
-
- procedure Tree_Write_Char (C : Character);
- -- Writes a single character to the current tree file
-
- procedure Tree_Write_Int (N : Int);
- -- Writes a single integer value to the current tree file
-
- procedure Tree_Write_Str (S : String_Ptr);
- -- Write out string value referenced by S (low bound of S must be 1)
-
- procedure Tree_Write_Terminate;
- -- Terminates writing of the file (flushing the buffer), but does not
- -- close the file (the caller is responsible for closing the file).
-
-end Tree_IO;
diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb
index 55ecbdb..e76b138 100644
--- a/gcc/ada/treepr.adb
+++ b/gcc/ada/treepr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1006,6 +1006,15 @@ package body Treepr is
return;
end if;
+ -- Similarly, if N points to an extension, avoid crashing
+
+ if Atree_Private_Part.Nodes.Table (N).Is_Extension then
+ Print_Int (Int (N));
+ Print_Str (" is an extension, not a node");
+ Print_Eol;
+ return;
+ end if;
+
Prefix_Str_Char (Prefix_Str'Range) := Prefix_Str;
Prefix_Str_Char (Prefix_Str'Last + 1) := Prefix_Char;
@@ -1131,12 +1140,6 @@ package body Treepr is
Print_Eol;
end if;
- if Has_Dynamic_Range_Check (N) then
- Print_Str (Prefix_Str_Char);
- Print_Str ("Has_Dynamic_Range_Check = True");
- Print_Eol;
- end if;
-
if Is_Controlling_Actual (N) then
Print_Str (Prefix_Str_Char);
Print_Str ("Is_Controlling_Actual = True");
@@ -1170,7 +1173,7 @@ package body Treepr is
if Raises_Constraint_Error (N) then
Print_Str (Prefix_Str_Char);
- Print_Str ("Raise_Constraint_Error = True");
+ Print_Str ("Raises_Constraint_Error = True");
Print_Eol;
end if;
@@ -1271,7 +1274,7 @@ package body Treepr is
-- Special case End_Span = Uint5
when F_Field5 =>
- if Nkind_In (N, N_Case_Statement, N_If_Statement) then
+ if Nkind (N) in N_Case_Statement | N_If_Statement then
Print_End_Span (N);
else
Print_Field (Field5 (N), Fmt);
@@ -2185,7 +2188,7 @@ package body Treepr is
Nod := N;
while Present (Nod) loop
Visit_Descendant (Union_Id (Next_Entity (Nod)));
- Nod := Next_Entity (Nod);
+ Next_Entity (Nod);
end loop;
end;
end if;
diff --git a/gcc/ada/treepr.ads b/gcc/ada/treepr.ads
index a63329b..b8a086e 100644
--- a/gcc/ada/treepr.ads
+++ b/gcc/ada/treepr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/ttypes.ads b/gcc/ada/ttypes.ads
index 71be644..88542c8 100644
--- a/gcc/ada/ttypes.ads
+++ b/gcc/ada/ttypes.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/types.adb b/gcc/ada/types.adb
index 6cd8569..732e070 100644
--- a/gcc/ada/types.adb
+++ b/gcc/ada/types.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads
index e649c4e..6a1d94d 100644
--- a/gcc/ada/types.ads
+++ b/gcc/ada/types.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -668,30 +668,39 @@ package Types is
No_Check_Id : constant := 0;
-- Check_Id value used to indicate no check
- Access_Check : constant := 1;
- Accessibility_Check : constant := 2;
- Alignment_Check : constant := 3;
- Allocation_Check : constant := 4;
- Atomic_Synchronization : constant := 5;
- Discriminant_Check : constant := 6;
- Division_Check : constant := 7;
- Duplicated_Tag_Check : constant := 8;
- Elaboration_Check : constant := 9;
- Index_Check : constant := 10;
- Length_Check : constant := 11;
- Overflow_Check : constant := 12;
- Predicate_Check : constant := 13;
- Range_Check : constant := 14;
- Storage_Check : constant := 15;
- Tag_Check : constant := 16;
- Validity_Check : constant := 17;
- Container_Checks : constant := 18;
- Tampering_Check : constant := 19;
+ Access_Check : constant := 1;
+ Accessibility_Check : constant := 2;
+ Alignment_Check : constant := 3;
+ Allocation_Check : constant := 4;
+ Atomic_Synchronization : constant := 5;
+ Characters_Assertion_Check : constant := 6;
+ Containers_Assertion_Check : constant := 7;
+ Discriminant_Check : constant := 8;
+ Division_Check : constant := 9;
+ Duplicated_Tag_Check : constant := 10;
+ Elaboration_Check : constant := 11;
+ Index_Check : constant := 12;
+ Interfaces_Assertion_Check : constant := 13;
+ IO_Assertion_Check : constant := 14;
+ Length_Check : constant := 15;
+ Numerics_Assertion_Check : constant := 16;
+ Overflow_Check : constant := 17;
+ Predicate_Check : constant := 18;
+ Program_Error_Check : constant := 19;
+ Range_Check : constant := 20;
+ Storage_Check : constant := 21;
+ Strings_Assertion_Check : constant := 22;
+ System_Assertion_Check : constant := 23;
+ Tag_Check : constant := 24;
+ Validity_Check : constant := 25;
+ Container_Checks : constant := 26;
+ Tampering_Check : constant := 27;
+ Tasking_Check : constant := 28;
-- Values used to represent individual predefined checks (including the
-- setting of Atomic_Synchronization, which is implemented internally using
-- a "check" whose name is Atomic_Synchronization).
- All_Checks : constant := 20;
+ All_Checks : constant := 29;
-- Value used to represent All_Checks value
subtype Predefined_Check_Id is Check_Id range 1 .. All_Checks;
@@ -715,7 +724,8 @@ package Types is
-- To add a new check type to GNAT, the following steps are required:
-- 1. Add an entry to Snames spec for the new name
- -- 2. Add an entry to the definition of Check_Id above
+ -- 2. Add an entry to the definition of Check_Id above (very important:
+ -- these definitions should be in the same order in Snames and here)
-- 3. Add a new function to Checks to handle the new check test
-- 4. Add a new Do_xxx_Check flag to Sinfo (if required)
-- 5. Add appropriate checks for the new test
diff --git a/gcc/ada/types.h b/gcc/ada/types.h
index a87340d..e7eeae0 100644
--- a/gcc/ada/types.h
+++ b/gcc/ada/types.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -139,10 +139,13 @@ typedef Text_Ptr Source_Ptr;
/* Used for Sloc in all nodes in the representation of package Standard. */
#define Standard_Location -2
-/* Instance identifiers */
+/* Convention identifiers. */
+typedef Byte Convention_Id;
+
+/* Instance identifiers. */
typedef Nat Instance_Id;
-/* Type used for union of all possible ID values covering all ranges */
+/* Type used for union of all possible ID values covering all ranges. */
typedef int Union_Id;
/* Range definitions for Tree Data: */
diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb
index 61e9f3d..5f479b4 100644
--- a/gcc/ada/uintp.adb
+++ b/gcc/ada/uintp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,8 +29,7 @@
-- --
------------------------------------------------------------------------------
-with Output; use Output;
-with Tree_IO; use Tree_IO;
+with Output; use Output;
with GNAT.HTable; use GNAT.HTable;
@@ -716,58 +715,6 @@ package body Uintp is
end if;
end Release_And_Save;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- Uints.Tree_Read;
- Udigits.Tree_Read;
-
- Tree_Read_Int (Int (Uint_Int_First));
- Tree_Read_Int (Int (Uint_Int_Last));
- Tree_Read_Int (UI_Power_2_Set);
- Tree_Read_Int (UI_Power_10_Set);
- Tree_Read_Int (Int (Uints_Min));
- Tree_Read_Int (Udigits_Min);
-
- for J in 0 .. UI_Power_2_Set loop
- Tree_Read_Int (Int (UI_Power_2 (J)));
- end loop;
-
- for J in 0 .. UI_Power_10_Set loop
- Tree_Read_Int (Int (UI_Power_10 (J)));
- end loop;
-
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Uints.Tree_Write;
- Udigits.Tree_Write;
-
- Tree_Write_Int (Int (Uint_Int_First));
- Tree_Write_Int (Int (Uint_Int_Last));
- Tree_Write_Int (UI_Power_2_Set);
- Tree_Write_Int (UI_Power_10_Set);
- Tree_Write_Int (Int (Uints_Min));
- Tree_Write_Int (Udigits_Min);
-
- for J in 0 .. UI_Power_2_Set loop
- Tree_Write_Int (Int (UI_Power_2 (J)));
- end loop;
-
- for J in 0 .. UI_Power_10_Set loop
- Tree_Write_Int (Int (UI_Power_10 (J)));
- end loop;
-
- end Tree_Write;
-
-------------
-- UI_Abs --
-------------
@@ -1294,6 +1241,7 @@ package body Uintp is
Discard_Int : Int;
pragma Warnings (Off, Discard_Int);
begin
+ pragma Assert (D /= Int'(0));
UI_Div_Vector
(Dividend (Dividend'Last - R_Length + 1 .. Dividend'Last),
D,
diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads
index d8342ba..652145e 100644
--- a/gcc/ada/uintp.ads
+++ b/gcc/ada/uintp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -107,20 +107,10 @@ package Uintp is
-----------------
procedure Initialize;
- -- Initialize Uint tables. Note that Initialize must not be called if
- -- Tree_Read is used. Note also that there is no lock routine in this
+ -- Initialize Uint tables. Note also that there is no lock routine in this
-- unit, these are among the few tables that can be expanded during
-- gigi processing.
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines. Note that Initialize should not be called if
- -- Tree_Read is used. Tree_Read includes all necessary initialization.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
function UI_Abs (Right : Uint) return Uint;
pragma Inline (UI_Abs);
-- Returns abs function of universal integer
diff --git a/gcc/ada/uintp.h b/gcc/ada/uintp.h
index ed106ef..222ff07 100644
--- a/gcc/ada/uintp.h
+++ b/gcc/ada/uintp.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/uname.adb b/gcc/ada/uname.adb
index 9094cf8..203d1c7 100644
--- a/gcc/ada/uname.adb
+++ b/gcc/ada/uname.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/uname.ads b/gcc/ada/uname.ads
index e103c96..2a55c84 100644
--- a/gcc/ada/uname.ads
+++ b/gcc/ada/uname.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/urealp.adb b/gcc/ada/urealp.adb
index cf79c07..31151c5 100644
--- a/gcc/ada/urealp.adb
+++ b/gcc/ada/urealp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,9 +30,8 @@
------------------------------------------------------------------------------
with Alloc;
-with Output; use Output;
+with Output; use Output;
with Table;
-with Tree_IO; use Tree_IO;
package body Urealp is
@@ -57,7 +56,7 @@ package body Urealp is
-- The following representation clause ensures that the above record
-- has no holes. We do this so that when instances of this record are
- -- written by Tree_Gen, we do not write uninitialized values to the file.
+ -- written, we do not write uninitialized values to the file.
for Ureal_Entry use record
Num at 0 range 0 .. 31;
@@ -95,10 +94,6 @@ package body Urealp is
UR_2_M_128 : Ureal;
UR_2_M_80 : Ureal;
- Num_Ureal_Constants : constant := 10;
- -- This is used for an assertion check in Tree_Read and Tree_Write to
- -- help remember to add values to these routines when we add to the list.
-
Normalized_Real : Ureal := No_Ureal;
-- Used to memoize Norm_Num and Norm_Den, if either of these functions
-- is called, this value is set and Normalized_Entry contains the result
@@ -114,13 +109,13 @@ package body Urealp is
function Decimal_Exponent_Hi (V : Ureal) return Int;
-- Returns an estimate of the exponent of Val represented as a normalized
- -- decimal number (non-zero digit before decimal point), The estimate is
+ -- decimal number (non-zero digit before decimal point), the estimate is
-- either correct, or high, but never low. The accuracy of the estimate
-- affects only the efficiency of the comparison routines.
function Decimal_Exponent_Lo (V : Ureal) return Int;
-- Returns an estimate of the exponent of Val represented as a normalized
- -- decimal number (non-zero digit before decimal point), The estimate is
+ -- decimal number (non-zero digit before decimal point), the estimate is
-- either correct, or low, but never high. The accuracy of the estimate
-- affects only the efficiency of the comparison routines.
@@ -487,52 +482,6 @@ package body Urealp is
return Store_Ureal (Normalize (Val));
end Store_Ureal_Normalized;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- pragma Assert (Num_Ureal_Constants = 10);
-
- Ureals.Tree_Read;
- Tree_Read_Int (Int (UR_0));
- Tree_Read_Int (Int (UR_M_0));
- Tree_Read_Int (Int (UR_Tenth));
- Tree_Read_Int (Int (UR_Half));
- Tree_Read_Int (Int (UR_1));
- Tree_Read_Int (Int (UR_2));
- Tree_Read_Int (Int (UR_10));
- Tree_Read_Int (Int (UR_100));
- Tree_Read_Int (Int (UR_2_128));
- Tree_Read_Int (Int (UR_2_M_128));
-
- -- Clear the normalization cache
-
- Normalized_Real := No_Ureal;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- pragma Assert (Num_Ureal_Constants = 10);
-
- Ureals.Tree_Write;
- Tree_Write_Int (Int (UR_0));
- Tree_Write_Int (Int (UR_M_0));
- Tree_Write_Int (Int (UR_Tenth));
- Tree_Write_Int (Int (UR_Half));
- Tree_Write_Int (Int (UR_1));
- Tree_Write_Int (Int (UR_2));
- Tree_Write_Int (Int (UR_10));
- Tree_Write_Int (Int (UR_100));
- Tree_Write_Int (Int (UR_2_128));
- Tree_Write_Int (Int (UR_2_M_128));
- end Tree_Write;
-
------------
-- UR_Abs --
------------
@@ -568,6 +517,9 @@ package body Urealp is
Num : Uint;
begin
+ pragma Annotate (CodePeer, Modified, Lval);
+ pragma Annotate (CodePeer, Modified, Rval);
+
-- Note, in the temporary Ureal_Entry values used in this procedure,
-- we store the sign as the sign of the numerator (i.e. xxx.Num may
-- be negative, even though in stored entries this can never be so)
@@ -685,6 +637,8 @@ package body Urealp is
Rneg : constant Boolean := Rval.Negative xor Lval.Negative;
begin
+ pragma Annotate (CodePeer, Modified, Lval);
+ pragma Annotate (CodePeer, Modified, Rval);
pragma Assert (Rval.Num /= Uint_0);
if Lval.Rbase = 0 then
diff --git a/gcc/ada/urealp.ads b/gcc/ada/urealp.ads
index 55a82f2..394bfed 100644
--- a/gcc/ada/urealp.ads
+++ b/gcc/ada/urealp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -135,20 +135,10 @@ package Urealp is
-----------------
procedure Initialize;
- -- Initialize Ureal tables. Note that Initialize must not be called if
- -- Tree_Read is used. Note also that there is no Lock routine in this
+ -- Initialize Ureal tables. Note that there is no Lock routine in this
-- unit. These tables are among the few tables that can be expanded
-- during Gigi processing.
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines. Note that Initialize should not be called if
- -- Tree_Read is used. Tree_Read includes all necessary initialization.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
function Rbase (Real : Ureal) return Nat;
-- Return the base of the universal real
diff --git a/gcc/ada/urealp.h b/gcc/ada/urealp.h
index ab8656b..a87e3ca 100644
--- a/gcc/ada/urealp.h
+++ b/gcc/ada/urealp.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb
index fb261e5..2afd3fc 100644
--- a/gcc/ada/usage.adb
+++ b/gcc/ada/usage.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -418,11 +418,6 @@ begin
Write_Switch_Char ("S");
Write_Line ("Print listing of package Standard");
- -- Line for -gnatt switch
-
- Write_Switch_Char ("t");
- Write_Line ("Tree output file to be generated");
-
-- Line for -gnatTnn switch
Write_Switch_Char ("Tnn");
@@ -495,6 +490,10 @@ begin
Write_Line (" C* turn off warnings for constant conditional");
Write_Line (" .c+ turn on warnings for unrepped components");
Write_Line (" .C* turn off warnings for unrepped components");
+ Write_Line (" _c* turn on warnings for unknown " &
+ "Compile_Time_Warning");
+ Write_Line (" _C turn off warnings for unknown " &
+ "Compile_Time_Warning");
Write_Line (" d turn on warnings for implicit dereference");
Write_Line (" D* turn off warnings for implicit dereference");
Write_Line (" .d turn on tagging of warnings with -gnatw switch");
@@ -571,6 +570,8 @@ begin
Write_Line (" R* turn off warnings for redundant construct");
Write_Line (" .r+ turn on warnings for object renaming function");
Write_Line (" .R* turn off warnings for object renaming function");
+ Write_Line (" _r turn on warnings for components out of order");
+ Write_Line (" _R turn off warnings for components out of order");
Write_Line (" s suppress all info/warnings");
Write_Line (" .s turn on warnings for overridden size clause");
Write_Line (" .S* turn off warnings for overridden size clause");
diff --git a/gcc/ada/usage.ads b/gcc/ada/usage.ads
index a23233f..9d842c0 100644
--- a/gcc/ada/usage.ads
+++ b/gcc/ada/usage.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/validsw.adb b/gcc/ada/validsw.adb
index ae155c3..dd3b6a0 100644
--- a/gcc/ada/validsw.adb
+++ b/gcc/ada/validsw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/validsw.ads b/gcc/ada/validsw.ads
index 5197bdf..4b2e4b7 100644
--- a/gcc/ada/validsw.ads
+++ b/gcc/ada/validsw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/tree_in.adb b/gcc/ada/vast.adb
index a62bf6f..87de26e 100644
--- a/gcc/ada/tree_in.adb
+++ b/gcc/ada/vast.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- T R E E _ I N --
+-- V A S T --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,43 +29,18 @@
-- --
------------------------------------------------------------------------------
-with Aspects;
-with Atree;
-with Csets;
-with Elists;
-with Fname;
-with Lib;
-with Namet;
-with Nlists;
-with Opt;
-with Repinfo;
-with Sem_Aux;
-with Sinput;
-with Stand;
-with Stringt;
-with Tree_IO;
-with Uintp;
-with Urealp;
+-- Dummy implementation
-procedure Tree_In (Desc : File_Descriptor) is
-begin
- Tree_IO.Tree_Read_Initialize (Desc);
+package body VAST is
- Opt.Tree_Read;
- Atree.Tree_Read;
- Elists.Tree_Read;
- Fname.Tree_Read;
- Lib.Tree_Read;
- Namet.Tree_Read;
- Nlists.Tree_Read;
- Sem_Aux.Tree_Read;
- Sinput.Tree_Read;
- Stand.Tree_Read;
- Stringt.Tree_Read;
- Uintp.Tree_Read;
- Urealp.Tree_Read;
- Repinfo.Tree_Read;
- Aspects.Tree_Read;
+ ----------------
+ -- Check_Tree --
+ ----------------
- Csets.Initialize;
-end Tree_In;
+ procedure Check_Tree (GNAT_Root : Node_Id) is
+ pragma Unreferenced (GNAT_Root);
+ begin
+ null;
+ end Check_Tree;
+
+end VAST;
diff --git a/gcc/ada/tree_in.ads b/gcc/ada/vast.ads
index 00fff15..01dfbfd 100644
--- a/gcc/ada/tree_in.ads
+++ b/gcc/ada/vast.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- T R E E _ I N --
+-- V A S T --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,14 +29,14 @@
-- --
------------------------------------------------------------------------------
--- This procedure is used to read in a tree if the option is set. Note that
--- it is not part of the compiler proper, but rather the interface from
--- tools that need to read the tree to the tree reading routines, and is
--- thus bound as part of such tools.
+-- This package is the entry point for VAST: Verifier for the Ada Semantic
+-- Tree.
-with System.OS_Lib; use System.OS_Lib;
+with Types; use Types;
-procedure Tree_In (Desc : File_Descriptor);
--- Desc is the file descriptor for the file containing the tree, as written
--- by the compiler in a previous compilation using Tree_Gen. On return the
--- global data structures are appropriately initialized.
+package VAST is
+
+ procedure Check_Tree (GNAT_Root : Node_Id);
+ -- Check the validity of the given Root tree
+
+end VAST;
diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb
index a5096dc..0701cfc 100644
--- a/gcc/ada/warnsw.adb
+++ b/gcc/ada/warnsw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/warnsw.ads b/gcc/ada/warnsw.ads
index c82f36d..6c0a448 100644
--- a/gcc/ada/warnsw.ads
+++ b/gcc/ada/warnsw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -49,8 +49,8 @@ package Warnsw is
-- extensions.
Warn_On_Unknown_Compile_Time_Warning : Boolean := True;
- -- Warn on a pragma Compile_Time_Warning or Compile_Time_Error whose
- -- condition has a value that is not known at compile time.
+ -- Warn on a pragma Compile_Time_Warning whose condition has a value that
+ -- is not known at compile time.
Warn_On_Overridden_Size : Boolean := False;
-- Warn when explicit record component clause or array component_size
diff --git a/gcc/ada/widechar.adb b/gcc/ada/widechar.adb
index b465dcd..3d3ebaf 100644
--- a/gcc/ada/widechar.adb
+++ b/gcc/ada/widechar.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -203,7 +203,16 @@ package body Widechar is
-- Start of processing for Skip_Wide
begin
- Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method);
+ -- Capture invalid wide characters errors since we are going to discard
+ -- the result anyway. We just want to move past it.
+
+ begin
+ Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method);
+ exception
+ when Constraint_Error =>
+ null;
+ end;
+
Wide_Char_Byte_Count := Wide_Char_Byte_Count + Nat (P - P_Init - 1);
end Skip_Wide;
@@ -235,7 +244,16 @@ package body Widechar is
-- Start of processing for Skip_Wide
begin
- Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method);
+ -- Capture invalid wide characters errors since we are going to discard
+ -- the result anyway. We just want to move past it.
+
+ begin
+ Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method);
+ exception
+ when Constraint_Error =>
+ null;
+ end;
+
Wide_Char_Byte_Count := Wide_Char_Byte_Count + Nat (P - P_Init - 1);
end Skip_Wide;
diff --git a/gcc/ada/widechar.ads b/gcc/ada/widechar.ads
index d7ea6d4..f81a19b 100644
--- a/gcc/ada/widechar.ads
+++ b/gcc/ada/widechar.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -81,9 +81,7 @@ package Widechar is
-- On entry, S (P) points to an ESC character for a wide character escape
-- sequence or to an upper half character if the encoding method uses the
-- upper bit, or to a left bracket if the brackets encoding method is in
- -- use. On exit, P is bumped past the wide character sequence. No error
- -- checking is done, since this is only used on escape sequences generated
- -- by Set_Wide, which are known to be correct.
+ -- use. On exit, P is bumped past the wide character sequence.
procedure Skip_Wide (S : Source_Buffer_Ptr; P : in out Source_Ptr);
-- Similar to the above procedure, but operates on a source buffer
diff --git a/gcc/ada/xeinfo.adb b/gcc/ada/xeinfo.adb
index cda2298..170a5c6 100644
--- a/gcc/ada/xeinfo.adb
+++ b/gcc/ada/xeinfo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -126,10 +126,10 @@ procedure XEinfo is
Get_Cmnt : constant Pattern := BreakX ('-') * A & "--";
Get_Expr : constant Pattern := wsp & "return " & Break (';') * Expr;
Chek_End : constant Pattern := wsp & "end" & BreakX (';') & ';';
+ Get_B0 : constant Pattern := BreakX (' ') * A & " or else " & Rest * B;
Get_B1 : constant Pattern := BreakX (' ') * A & " in " & Rest * B;
Get_B2 : constant Pattern := BreakX (' ') * A & " = " & Rest * B;
Get_B3 : constant Pattern := BreakX (' ') * A & " /= " & Rest * B;
- Get_B4 : constant Pattern := BreakX (' ') * A & " or else " & Rest * B;
To_Paren : constant Pattern := wsp * Filler & '(';
Get_Fml : constant Pattern := Break (" :") * Formal & wsp & ':' & wsp
& BreakX (" );") * Formaltyp;
@@ -164,6 +164,9 @@ procedure XEinfo is
procedure Sethead (Line : in out VString; Term : String);
-- Process function header into C
+ procedure Translate_Expr (Expr : in out VString);
+ -- Translate expression from Ada to C
+
-------------
-- Badfunc --
-------------
@@ -242,6 +245,22 @@ procedure XEinfo is
end if;
end Sethead;
+ --------------------
+ -- Translate_Expr --
+ --------------------
+
+ procedure Translate_Expr (Expr : in out VString) is
+ M : Match_Result;
+
+ begin
+ Match (Expr, Get_B1, M);
+ Replace (M, "IN (" & A & ", " & B & ')');
+ Match (Expr, Get_B2, M);
+ Replace (M, A & " == " & B);
+ Match (Expr, Get_B3, M);
+ Replace (M, A & " != " & B);
+ end Translate_Expr;
+
-- Start of processing for XEinfo
begin
@@ -485,14 +504,21 @@ begin
Badfunc;
end if;
- Match (Expr, Get_B1, M);
- Replace (M, "IN (" & A & ", " & B & ')');
- Match (Expr, Get_B2, M);
- Replace (M, A & " == " & B);
- Match (Expr, Get_B3, M);
- Replace (M, A & " != " & B);
- Match (Expr, Get_B4, M);
- Replace (M, A & " || " & B);
+ -- Process expression
+
+ if Match (Expr, Get_B0, M) then
+ declare
+ Saved_A : VString := A;
+ Saved_B : VString := B;
+ begin
+ Translate_Expr (Saved_A);
+ Translate_Expr (Saved_B);
+ Replace (M, Saved_A & " || " & Saved_B);
+ end;
+ else
+ Translate_Expr (Expr);
+ end if;
+
Put_Line (Ofile, "");
Sethead (Fline, "");
Put_Line (Ofile, C & " { return " & Expr & "; }");
diff --git a/gcc/ada/xnmake.adb b/gcc/ada/xnmake.adb
index 395381c..0a18538 100644
--- a/gcc/ada/xnmake.adb
+++ b/gcc/ada/xnmake.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/xoscons.adb b/gcc/ada/xoscons.adb
index 7c72e4e..f92b627 100644
--- a/gcc/ada/xoscons.adb
+++ b/gcc/ada/xoscons.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -494,6 +494,9 @@ procedure XOSCons is
Value1 := Get_Value (Slice (Sline, 2));
Value2 := Get_Value (Slice (Sline, 4));
+ pragma Annotate (CodePeer, Modified, Value1);
+ pragma Annotate (CodePeer, Modified, Value2);
+
if Slice (Sline, 3) = ">" then
Res := Cond and (Value1 > Value2);
@@ -619,7 +622,7 @@ procedure XOSCons is
Current_Line : Integer;
Current_Info : Integer;
In_Comment : Boolean;
- In_Template : Boolean;
+ In_Template : Boolean := False;
-- Start of processing for XOSCons
diff --git a/gcc/ada/xr_tabls.adb b/gcc/ada/xr_tabls.adb
index a3c9623..b2e7c02 100644
--- a/gcc/ada/xr_tabls.adb
+++ b/gcc/ada/xr_tabls.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1015,12 +1015,12 @@ package body Xr_Tabls is
Decl : Declaration_Reference := Entities_HTable.Get_First;
Arr : Reference_Array_Access;
Index : Natural;
- End_Index : Natural;
+ End_Index : Natural := 0;
Current_File : File_Reference;
Current_Line : Cst_String_Access;
Buffer : GNAT.OS_Lib.String_Access;
Ref : Reference;
- Line : Natural;
+ Line : Natural := Natural'Last;
begin
-- Create a temporary array, where all references will be
diff --git a/gcc/ada/xr_tabls.ads b/gcc/ada/xr_tabls.ads
index 199d272..3a29823 100644
--- a/gcc/ada/xr_tabls.ads
+++ b/gcc/ada/xr_tabls.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb
index eabf8b4..8d29f6e 100644
--- a/gcc/ada/xref_lib.adb
+++ b/gcc/ada/xref_lib.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -23,6 +23,8 @@
-- --
------------------------------------------------------------------------------
+pragma Ada_2012;
+
with Osint;
with Output; use Output;
with Types; use Types;
@@ -767,13 +769,14 @@ package body Xref_Lib is
E_Line : Natural; -- Line number of current entity
E_Col : Natural; -- Column number of current entity
- E_Type : Character; -- Type of current entity
E_Name : Positive; -- Pointer to begin of entity name
E_Global : Boolean; -- True iff entity is global
+ E_Type : Character; -- Type of current entity
R_Line : Natural; -- Line number of current reference
R_Col : Natural; -- Column number of current reference
- R_Type : Character; -- Type of current reference
+
+ R_Type : Character := ASCII.NUL; -- Type of current reference
Decl_Ref : Declaration_Reference;
File_Ref : File_Reference := Current_Xref_File (File);
@@ -876,18 +879,19 @@ package body Xref_Lib is
if Ali (Ptr) > ' ' then
E_Type := Ali (Ptr);
Ptr := Ptr + 1;
- end if;
- -- Ignore some of the entities (labels,...)
+ -- Ignore some of the entities (labels,...)
- case E_Type is
- when 'l' | 'L' | 'q' =>
+ if E_Type in 'l' | 'L' | 'q' then
Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
return;
+ end if;
+ else
+ -- Unexpected contents, skip line and return
- when others =>
- null;
- end case;
+ Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
+ return;
+ end if;
Parse_Number (Ali, Ptr, E_Col);
@@ -966,7 +970,7 @@ package body Xref_Lib is
Parse_Derived_Info : declare
P_Line : Natural; -- parent entity line
P_Column : Natural; -- parent entity column
- P_Eun : Positive; -- parent entity file number
+ P_Eun : Natural := 0; -- parent entity file number
begin
Parse_Number (Ali, Ptr, P_Line);
@@ -1010,6 +1014,8 @@ package body Xref_Lib is
-- on or if we want to output the type hierarchy
if Der_Info or else Type_Tree then
+ pragma Assert (P_Eun /= 0);
+
declare
Symbol : constant String :=
Get_Symbol_Name (P_Eun, P_Line, P_Column);
@@ -1126,8 +1132,8 @@ package body Xref_Lib is
-- 5U14*Foo2 5>20 6b<c,myfoo2>22 # Imported entity
-- 5U14*Foo2 5>20 6i<c,myfoo2>22 # Exported entity
- if (R_Type = 'b' or else R_Type = 'i')
- and then Ali (Ptr) = '<'
+ if Ali (Ptr) = '<'
+ and then (R_Type = 'b' or else R_Type = 'i')
then
while Ptr <= Ali'Last
and then Ali (Ptr) /= '>'
@@ -1139,6 +1145,8 @@ package body Xref_Lib is
Parse_Number (Ali, Ptr, R_Col);
+ pragma Assert (R_Type /= ASCII.NUL);
+
-- Insert the reference or body in the table
Add_Reference
diff --git a/gcc/ada/xref_lib.ads b/gcc/ada/xref_lib.ads
index 60ce8bd..aa78d09 100644
--- a/gcc/ada/xref_lib.ads
+++ b/gcc/ada/xref_lib.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/xsinfo.adb b/gcc/ada/xsinfo.adb
index 778a8bd..a717d72 100644
--- a/gcc/ada/xsinfo.adb
+++ b/gcc/ada/xsinfo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/xsnamest.adb b/gcc/ada/xsnamest.adb
index 7ec2975..834d3c4 100644
--- a/gcc/ada/xsnamest.adb
+++ b/gcc/ada/xsnamest.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -58,6 +58,7 @@ procedure XSnamesT is
Line : VString := Nul;
Name0 : VString := Nul;
Name1 : VString := Nul;
+ Name2 : VString := Nul;
Oval : VString := Nul;
Restl : VString := Nul;
@@ -69,6 +70,7 @@ procedure XSnamesT is
Get_Name : constant Pattern := "Name_" & Rest * Name1;
Chk_Low : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1);
Findu : constant Pattern := Span ('u') * A;
+ Is_Conv : constant Pattern := "Convention_" & Rest;
Val : Natural;
@@ -98,12 +100,18 @@ procedure XSnamesT is
-- Patterns used in the spec file
- Get_Attr : constant Pattern := Span (' ') & "Attribute_"
- & Break (",)") * Name1;
- Get_Conv : constant Pattern := Span (' ') & "Convention_"
- & Break (",)") * Name1;
- Get_Prag : constant Pattern := Span (' ') & "Pragma_"
- & Break (",)") * Name1;
+ Get_Attr : constant Pattern := Span (' ') & "Attribute_"
+ & Break (",)") * Name1;
+ Get_Conv : constant Pattern := Span (' ') & "Convention_"
+ & Break (",)") * Name1;
+ Get_Prag : constant Pattern := Span (' ') & "Pragma_"
+ & Break (",)") * Name1;
+ Get_Subt1 : constant Pattern := Span (' ') & "subtype "
+ & Break (' ') * Name1
+ & " is " & Rest * Name2;
+ Get_Subt2 : constant Pattern := Span (' ') & "range "
+ & Break (' ') * Name1
+ & " .. " & Break (";") * Name2;
type Header_Symbol_Counter is array (Header_Symbol) of Natural;
Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0, 0);
@@ -143,7 +151,6 @@ procedure XSnamesT is
if Header_Current_Symbol /= S then
declare
- Name2 : VString;
Pat : constant Pattern := "#define "
& Header_Prefix (S).all
& Break (' ') * Name2;
@@ -227,6 +234,11 @@ begin
Output_Header_Line (Conv);
elsif Match (Line, Get_Prag) then
Output_Header_Line (Prag);
+ elsif Match (Line, Get_Subt1) and then Match (Name2, Is_Conv) then
+ New_Line (OutH);
+ Put_Line (OutH, "SUBTYPE (" & Name1 & ", " & Name2 & ", ");
+ elsif Match (Line, Get_Subt2) and then Match (Name1, Is_Conv) then
+ Put_Line (OutH, " " & Name1 & ", " & Name2 & ')');
end if;
else
diff --git a/gcc/ada/xtreeprs.adb b/gcc/ada/xtreeprs.adb
index 110b7bc..9469e28 100644
--- a/gcc/ada/xtreeprs.adb
+++ b/gcc/ada/xtreeprs.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/xutil.adb b/gcc/ada/xutil.adb
index ab94ccd..8f85668 100644
--- a/gcc/ada/xutil.adb
+++ b/gcc/ada/xutil.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/xutil.ads b/gcc/ada/xutil.ads
index b78e97c..8172595 100644
--- a/gcc/ada/xutil.ads
+++ b/gcc/ada/xutil.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --